From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 27 May 2000 00:11:06 +0000 (+0000)
Subject: Implement BASE64 decoder.
X-Git-Tag: 20090517-FFI~3671
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9872dfcb1f8a5fe27325ba685ea24581c07572c8;p=mit-scheme.git

Implement BASE64 decoder.
---

diff --git a/v7/src/imail/mime-codec.scm b/v7/src/imail/mime-codec.scm
index 204836102..6713be418 100644
--- a/v7/src/imail/mime-codec.scm
+++ b/v7/src/imail/mime-codec.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: mime-codec.scm,v 1.1 2000/05/26 18:45:44 cph Exp $
+;;; $Id: mime-codec.scm,v 1.2 2000/05/27 00:11:06 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -22,6 +22,8 @@
 
 (declare (usual-integrations))
 
+;;;; Decode quoted-printable
+
 (define (decode-quoted-printable-string string)
   (decode-quoted-printable-substring string 0 (string-length string)))
 
@@ -37,31 +39,26 @@
 		(loop (fix:+ i 1)))
 	      (decode-quoted-printable-line string start end port)))))))
 
-(define (decode-quoted-printable-line line start end port)
-  (let ((end
-	 (let loop ((end end))
-	   (if (and (fix:< start end)
-		    (char-lwsp? (string-ref line (fix:- end 1))))
-	       (loop (fix:- end 1))
-	       end))))
+(define (decode-quoted-printable-line string start end port)
+  (let ((end (skip-lwsp-backwards string start end)))
     (let loop ((start start))
       (let ((i
 	     (substring-find-next-char-in-set
-	      line start end char-set:qp-encoded)))
+	      string start end char-set:qp-encoded)))
 	(if i
 	    (begin
-	      (write-substring line start i port)
-	      (cond ((decode-qp-hex-octet line i end)
+	      (write-substring string start i port)
+	      (cond ((decode-qp-hex-octet string i end)
 		     => (lambda (char)
 			  (write-char char port)
 			  (loop (fix:+ i 3))))
-		    ((char=? (string-ref line i) #\=)
+		    ((char=? (string-ref string i) #\=)
 		     (if (fix:< (fix:+ i 1) end)
 			 ;; This case is illegal.  RFC 2045 recommends
 			 ;; leaving it unconverted.
 			 (begin
-			   (write-char (string-ref line i) port)
-			   (write-char (string-ref line (fix:+ i 1)) port)
+			   (write-char (string-ref string i) port)
+			   (write-char (string-ref string (fix:+ i 1)) port)
 			   (loop (fix:+ i 2)))
 			 ;; Soft line break.
 			 #f))
@@ -70,7 +67,7 @@
 		     ;; dropping the char altogether.
 		     (loop (fix:+ i 1)))))
 	    (begin
-	      (write-substring line start end port)
+	      (write-substring string start end port)
 	      ;; Hard line break.
 	      #t))))))
 
@@ -85,4 +82,76 @@
   (char-set-invert
    (char-set-union (char-set-difference (ascii-range->char-set #x21 #x7F)
 					(char-set #\=))
-		   char-set:lwsp)))
\ No newline at end of file
+		   char-set:lwsp)))
+
+;;;; Decode BASE64
+
+(define (decode-base64-string string)
+  (decode-base64-substring string 0 (string-length string)))
+
+(define (decode-base64-substring string start end)
+  (with-string-output-port
+    (lambda (port)
+      (let loop ((start start))
+	(let ((i (substring-find-next-char string start end #\newline)))
+	  (if i
+	      (begin
+		(decode-base64-line string start i port)
+		(loop (fix:+ i 1)))
+	      (decode-base64-line string start end port)))))))
+
+(define (decode-base64-line string start end port)
+  (let ((end (skip-lwsp-backwards string start end)))
+    (if (not (let ((n (fix:- end start)))
+	       (and (fix:<= n 76)
+		    (fix:= 0 (fix:remainder n 4)))))
+	(error:bad-range-argument end 'DECODE-BASE64-LINE))
+    (let loop ((start start))
+      (if (fix:< start end)
+	  (begin
+	    (decode-base64-quantum string start port)
+	    (loop (fix:+ start 4)))))))
+
+(define (decode-base64-quantum string start port)
+  (let ((c1 (string-ref string start))
+	(c2 (string-ref string (fix:+ start 1)))
+	(c3 (string-ref string (fix:+ start 2)))
+	(c4 (string-ref string (fix:+ start 3))))
+    (if (char=? c4 #\=)
+	(if (char=? c3 #\=)
+	    (write-octet (fix:+ (fix:lsh (base64-char->digit c1) 2)
+				(fix:lsh (base64-char->digit c2) -4))
+			 port)
+	    (let ((n
+		   (fix:+ (fix:lsh (base64-char->digit c1) 10)
+			  (fix:+ (fix:lsh (base64-char->digit c2) 4)
+				 (fix:lsh (base64-char->digit c3) -2)))))
+	      (write-octet (fix:lsh n -8) port)
+	      (write-octet n port)))
+	(let ((n
+	       (fix:+ (fix:lsh (base64-char->digit c1) 18)
+		      (fix:+ (fix:lsh (base64-char->digit c2) 12)
+			     (fix:+ (fix:lsh (base64-char->digit c3) 6)
+				    (base64-char->digit c4))))))
+	  (write-octet (fix:lsh n -16) port)
+	  (write-octet (fix:lsh n -8) port)
+	  (write-octet n port)))))
+
+(define-integrable (write-octet n port)
+  (write-char (integer->char (fix:and n #xff)) port))
+
+(define-integrable (base64-char->digit char)
+  (vector-8b-ref base64-char-table (char->integer char)))
+
+(define base64-char-table
+  (let ((table (make-string 256 (integer->char #xff))))
+    (define (do-range low high value)
+      (vector-8b-set! table low value)
+      (if (fix:< low high)
+	  (do-range (fix:+ low 1) high (fix:+ value 1))))
+    (do-range (char->integer #\A) (char->integer #\Z) 0)
+    (do-range (char->integer #\a) (char->integer #\z) 26)
+    (do-range (char->integer #\0) (char->integer #\9) 52)
+    (vector-8b-set! table (char->integer #\+) 62)
+    (vector-8b-set! table (char->integer #\/) 63)
+    table))
\ No newline at end of file