From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Jun 2000 22:12:59 +0000 (+0000)
Subject: Implement BinHex decompressor.
X-Git-Tag: 20090517-FFI~3441
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b05b3a50f5f591e9ba30d6d726271b70a090a4c2;p=mit-scheme.git

Implement BinHex decompressor.
---

diff --git a/v7/src/runtime/mime-codec.scm b/v7/src/runtime/mime-codec.scm
index 2a41e2484..0c8a7b19c 100644
--- a/v7/src/runtime/mime-codec.scm
+++ b/v7/src/runtime/mime-codec.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: mime-codec.scm,v 14.4 2000/06/22 03:45:16 cph Exp $
+;;; $Id: mime-codec.scm,v 14.5 2000/06/26 22:12:54 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -157,6 +157,26 @@
 ;;; possible, then save enough state to continue when the next packet
 ;;; comes along.
 
+(define (call-with-decode-quoted-printable-output-port port text? generator)
+  (let ((port (make-decode-quoted-printable-port port text?)))
+    (let ((v (generator port)))
+      (close-output-port port)
+      v)))
+
+(define (make-decode-quoted-printable-port port text?)
+  (make-port decode-quoted-printable-port-type
+	     (decode-quoted-printable:initialize port text?)))
+
+(define decode-quoted-printable-port-type
+  (make-port-type
+   `((WRITE-SUBSTRING
+      ,(lambda (port string start end)
+	 (decode-quoted-printable:update (port/state port) string start end)))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+	 (decode-quoted-printable:finalize (port/state port)))))
+   #f))
+
 (define-structure (qp-decoding-context
 		   (conc-name qp-decoding-context/)
 		   (constructor decode-quoted-printable:initialize
@@ -423,6 +443,25 @@
 
 ;;;; Decode BASE64
 
+(define (call-with-decode-base64-output-port port text? generator)
+  (let ((port (make-decode-base64-port port text?)))
+    (let ((v (generator port)))
+      (close-output-port port)
+      v)))
+
+(define (make-decode-base64-port port text?)
+  (make-port decode-base64-port-type (decode-base64:initialize port text?)))
+
+(define decode-base64-port-type
+  (make-port-type
+   `((WRITE-SUBSTRING
+      ,(lambda (port string start end)
+	 (decode-base64:update (port/state port) string start end)))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+	 (decode-base64:finalize (port/state port)))))
+   #f))
+
 (define-structure (base64-decoding-context
 		   (conc-name base64-decoding-context/)
 		   (constructor decode-base64:initialize (port text?)))
@@ -541,6 +580,26 @@
 
 ;;;; Decode BinHex 4.0
 
+(define (call-with-decode-binhex40-output-port port text? generator)
+  (let ((port (make-decode-binhex40-port port text?)))
+    (let ((v (generator port)))
+      (close-output-port port)
+      v)))
+
+(define (make-decode-binhex40-port port text?)
+  (make-port decode-binhex40-port-type
+	     (decode-binhex40:initialize port text?)))
+
+(define decode-binhex40-port-type
+  (make-port-type
+   `((WRITE-SUBSTRING
+      ,(lambda (port string start end)
+	 (decode-binhex40:update (port/state port) string start end)))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+	 (decode-binhex40:finalize (port/state port)))))
+   #f))
+
 (define-structure (binhex40-decoding-context
 		   (conc-name binhex40-decoding-context/)
 		   (constructor make-binhex40-decoding-context (port)))
@@ -553,7 +612,8 @@
 
 (define (decode-binhex40:initialize port text?)
   text?					;ignored
-  (make-binhex40-decoding-context port))
+  (make-binhex40-decoding-context
+   (make-binhex40-decompressing-port port)))
 
 (define (decode-binhex40:finalize context)
   (let ((state (binhex40-decoding-context/state context)))
@@ -687,4 +747,56 @@
     ((fix:= code 64))
   (vector-8b-set! binhex40-char-table
 		  (vector-8b-ref binhex40-digit-table code)
-		  code))
\ No newline at end of file
+		  code))
+
+;;;; BinHex 4.0 decompression
+
+(define (make-binhex40-decompressing-port port)
+  (make-port binhex40-decompressing-port-type
+	     (make-binhex40-decompressor-state port)))
+
+(define binhex40-decompressing-port-type
+  (make-port-type
+   `((WRITE-CHAR
+      ,(lambda (port char)
+	 (let ((state (port/state port)))
+	   (let ((port (binhex40-decompressor-state/port state))
+		 (char* (binhex40-decompressor-state/char state)))
+	     (cond ((binhex40-decompressor-state/marker-seen? state)
+		    (let ((n (char->integer char)))
+		      (cond ((fix:= n 0)
+			     (if char* (write-char char* port))
+			     (set-binhex40-decompressor-state/char!
+			      state binhex40-compression-marker))
+			    (char*
+			     (do ((i 0 (fix:+ i 1)))
+				 ((fix:= i n))
+			       (write-char char* port))
+			     (set-binhex40-decompressor-state/char! state
+								    #f))))
+		    (set-binhex40-decompressor-state/marker-seen?! state #f))
+		   ((char=? char binhex40-compression-marker)
+		    (set-binhex40-decompressor-state/marker-seen?! state #t))
+		   (else
+		    (if char* (write-char char* port))
+		    (set-binhex40-decompressor-state/char! state char)))))))
+     (CLOSE-OUTPUT
+      ,(lambda (port)
+	 (let ((state (port/state port)))
+	   (let ((port (binhex40-decompressor-state/port state))
+		 (char* (binhex40-decompressor-state/char state)))
+	     (if char*
+		 (write-char char* port))
+	     (if (binhex40-decompressor-state/marker-seen? state)
+		 (write-char binhex40-compression-marker port)))))))
+   #f))
+
+(define-structure (binhex40-decompressor-state
+		   (conc-name binhex40-decompressor-state/)
+		   (constructor make-binhex40-decompressor-state (port)))
+  (port #f read-only #t)
+  (char #f)
+  (marker-seen? #f))
+
+(define-integrable binhex40-compression-marker
+  (integer->char #x90))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 24379a4da..bf4807def 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.353 2000/06/22 03:48:49 cph Exp $
+$Id: runtime.pkg,v 14.354 2000/06/26 22:12:59 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -3632,6 +3632,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (else))
   (parent ())
   (export ()
+	  call-with-decode-base64-output-port
+	  call-with-decode-binhex40-output-port
+	  call-with-decode-quoted-printable-output-port
 	  decode-base64:finalize
 	  decode-base64:initialize
 	  decode-base64:update
@@ -3646,4 +3649,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  encode-base64:update
 	  encode-quoted-printable:finalize
 	  encode-quoted-printable:initialize
-	  encode-quoted-printable:update))
\ No newline at end of file
+	  encode-quoted-printable:update
+	  make-decode-base64-port
+	  make-decode-binhex40-port
+	  make-decode-quoted-printable-port))
\ No newline at end of file