From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 22 Jun 2000 03:48:03 +0000 (+0000)
Subject: First cut at BinHex support.  This just does the decoding, without
X-Git-Tag: 20090517-FFI~3464
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fd889754c341d499b619aed9d6896a2d32aa9d21;p=mit-scheme.git

First cut at BinHex support.  This just does the decoding, without
understanding the structure of the data stream.
---

diff --git a/v7/src/runtime/mime-codec.scm b/v7/src/runtime/mime-codec.scm
index 32a7d935f..2a41e2484 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.3 2000/06/15 15:11:29 cph Exp $
+;;; $Id: mime-codec.scm,v 14.4 2000/06/22 03:45:16 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -537,4 +537,154 @@
   (do-char (char->integer #\/) 63)
   (set! base64-char-table char-table)
   (set! base64-digit-table digit-table)
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+;;;; Decode BinHex 4.0
+
+(define-structure (binhex40-decoding-context
+		   (conc-name binhex40-decoding-context/)
+		   (constructor make-binhex40-decoding-context (port)))
+  (port #f read-only #t)
+  (state 'SEEKING-COMMENT)
+  (line-buffer "")
+  (input-buffer (make-string 4) read-only #t)
+  (input-index 0)
+  (output-buffer (make-string 3) read-only #t))
+
+(define (decode-binhex40:initialize port text?)
+  text?					;ignored
+  (make-binhex40-decoding-context port))
+
+(define (decode-binhex40:finalize context)
+  (let ((state (binhex40-decoding-context/state context)))
+    (case (binhex40-decoding-context/state context)
+      ((SEEKING-COMMENT)
+       (error "Missing BinHex 4.0 initial comment line."))
+      ((SEEKING-COLON)
+       (error "Missing BinHex 4.0 starting character."))
+      ((DECODING)
+       (error "Missing BinHex 4.0 terminating character."))
+      ((IGNORING)
+       unspecific)
+      (else
+       (error "Illegal decoder state:" state)))))
+
+(define (decode-binhex40:update context string start end)
+  (let ((state (binhex40-decoding-context/state context)))
+    (case (binhex40-decoding-context/state context)
+      ((SEEKING-COMMENT)
+       (decode-binhex40-seeking-comment context string start end))
+      ((SEEKING-COLON)
+       (decode-binhex40-seeking-colon context string start end))
+      ((DECODING)
+       (decode-binhex40-decoding context string start end))
+      ((IGNORING)
+       unspecific)
+      (else
+       (error "Illegal decoder state:" state)))))
+
+(define (decode-binhex40-seeking-comment context string start end)
+  (let loop
+      ((s
+	(string-append (binhex40-decoding-context/line-buffer context)
+		       (substring string start end))))
+    (let ((index (string-find-next-char s #\newline)))
+      (cond ((not index)
+	     (set-binhex40-decoding-context/line-buffer! context s))
+	    ((re-substring-match binhex40-initial-comment s 0 index)
+	     (set-binhex40-decoding-context/state! context
+						   'SEEKING-COLON)
+	     (set-binhex40-decoding-context/line-buffer! context #f)
+	     (decode-binhex40:update context s
+				     (fix:+ index 1)
+				     (string-length s)))
+	    (else
+	     (loop (string-tail s (fix:+ index 1))))))))
+
+(define (decode-binhex40-seeking-colon context string start end)
+  (let ((index (substring-find-next-char string start end #\:)))
+    (if index
+	(begin
+	  (set-binhex40-decoding-context/state! context 'DECODING)
+	  (decode-binhex40:update context string (fix:+ index 1) end)))))
+
+(define (decode-binhex40-decoding context string start end)   
+  (let ((buffer (binhex40-decoding-context/input-buffer context)))
+    (let loop
+	((start start)
+	 (index (binhex40-decoding-context/input-index context)))
+      (if (fix:< start end)
+	  (let ((char (string-ref string start))
+		(start (fix:+ start 1)))
+	    (cond ((char=? char #\:)
+		   (if (fix:> index 0)
+		       (begin
+			 (string-set! buffer index char)
+			 (decode-binhex40-quantum context)))
+		   (set-binhex40-decoding-context/state! context 'IGNORING))
+		  ((fix:< (vector-8b-ref binhex40-char-table
+					 (char->integer char))
+			  #x40)
+		   (string-set! buffer index char)
+		   (if (fix:< index 3)
+		       (loop start (fix:+ index 1))
+		       (begin
+			 (decode-binhex40-quantum context)
+			 (loop start 0))))
+		  (else
+		   (loop start index))))
+	  (set-binhex40-decoding-context/input-index! context index)))))
+
+(define (decode-binhex40-quantum context)
+  (let ((input (binhex40-decoding-context/input-buffer context))
+	(output (binhex40-decoding-context/output-buffer context))
+	(port (binhex40-decoding-context/port context)))
+    (write-substring output 0
+		     (decode-binhex40-quantum-1 input output)
+		     port)))
+
+(define (decode-binhex40-quantum-1 input output)
+  (let ((d1 (decode-binhex40-char input 0))
+	(d2 (decode-binhex40-char input 1)))
+    (cond ((char=? (string-ref input 2) #\:)
+	   (vector-8b-set! output 0 (fix:+ (fix:lsh d1 2) (fix:lsh d2 -4)))
+	   1)
+	  ((char=? (string-ref input 3) #\:)
+	   (let ((n
+		  (fix:+ (fix:+ (fix:lsh d1 10) (fix:lsh d2 4))
+			 (fix:lsh (decode-binhex40-char input 2) -2))))
+	     (vector-8b-set! output 0 (fix:lsh n -8))
+	     (vector-8b-set! output 1 (fix:and #xFF n)))
+	   2)
+	  (else
+	   (let ((n
+		  (fix:+ (fix:+ (fix:lsh d1 18)
+				(fix:lsh d2 12))
+			 (fix:+ (fix:lsh (decode-binhex40-char input 2) 6)
+				(decode-binhex40-char input 3)))))
+	     (vector-8b-set! output 0 (fix:lsh n -16))
+	     (vector-8b-set! output 1 (fix:and #xFF (fix:lsh n -8)))
+	     (vector-8b-set! output 2 (fix:and #xFF n))
+	     3)))))
+
+(define (decode-binhex40-char input index)
+  (let ((digit
+	 (vector-8b-ref binhex40-char-table (vector-8b-ref input index))))
+    (if (fix:> digit #x40)
+	(error "Misplaced #\: in BinHex 4.0 input."))
+    digit))
+
+(define binhex40-initial-comment
+  "^(This file must be converted with BinHex 4\\.0)[ \t]*$")
+
+(define binhex40-digit-table
+  "!\"#$%&\'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr")
+
+(define binhex40-char-table
+  (make-string 256 (integer->char #xff)))
+
+(do ((code 0 (fix:+ code 1)))
+    ((fix:= code 64))
+  (vector-8b-set! binhex40-char-table
+		  (vector-8b-ref binhex40-digit-table code)
+		  code))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 162bdd10a..e08db7219 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.350 2000/06/08 16:31:53 cph Exp $
+$Id: runtime.pkg,v 14.351 2000/06/22 03:48:03 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -3635,12 +3635,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  decode-base64:finalize
 	  decode-base64:initialize
 	  decode-base64:update
+	  decode-binhex40:finalize
+	  decode-binhex40:initialize
+	  decode-binhex40:update
 	  decode-quoted-printable:finalize
 	  decode-quoted-printable:initialize
 	  decode-quoted-printable:update
 	  encode-base64:finalize
 	  encode-base64:initialize
-	  encode-base64:update
+	  encode-binhex40:finalize
+	  encode-binhex40:initialize
+	  encode-binhex40:update
+	  encode-binhex40:update
 	  encode-quoted-printable:finalize
 	  encode-quoted-printable:initialize
 	  encode-quoted-printable:update))
\ No newline at end of file