.

original commit: 20af79513911f5b3a4999b88845345240c511b2c

collects/net/base64-unit.ss

@@ -32,7 +32,7 @@
       (let ([each-char (lambda (s e pos)
 			 (let loop ([i (char->integer s)][pos pos])
 			   (unless (> i (char->integer e))
-			     (vector-set! digit-base64 pos (integer->char i))
+			     (vector-set! digit-base64 pos i)
 			     (loop (add1 i) (add1 pos)))))])
 	(each-char #\A #\Z 0)
 	(each-char #\a #\z 26)
@@ -44,35 +44,35 @@
 	(let loop ([waiting 0][waiting-bits 0])
 	  (if (>= waiting-bits 8)
 	      (begin
-		(display (integer->char (arithmetic-shift waiting (- 8 waiting-bits)))
-			 out)
+		(write-byte (arithmetic-shift waiting (- 8 waiting-bits))
+			    out)
 		(let ([waiting-bits (- waiting-bits 8)])
 		  (loop (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))
 			waiting-bits)))
-	      (let* ([c0 (read-char in)]
-		     [c (if (eof-object? c0) #\= c0)]
-		     [v (vector-ref base64-digit (char->integer c))])
+	      (let* ([c0 (read-byte in)]
+		     [c (if (eof-object? c0) (char->integer #\=) c0)]
+		     [v (vector-ref base64-digit c)])
 		(cond
 		 [v (loop (+ (arithmetic-shift waiting 6) v)
 			  (+ waiting-bits 6))]
-		 [(eq? c #\=) (void)] ; done
+		 [(eq? c (char->integer #\=)) (void)] ; done
 		 [else (loop waiting waiting-bits)])))))
 
 
       (define base64-encode-stream
 	(case-lambda
-	 [(in out) (base64-encode-stream in out #\newline)]
+	 [(in out) (base64-encode-stream in out #"\n")]
 	 [(in out linesep)
 	  ;; Process input 3 characters at a time, because 18 bits
 	  ;;  is divisible by both 6 and 8, and 72 (the line length)
 	  ;;  is divisible by 3.
 	  (let ([three (make-bytes 3)]
 		[outc (lambda (n)
-			(display (vector-ref digit-base64 n) out))]
+			(write-byte (vector-ref digit-base64 n) out))]
 		[done (lambda (fill)
 			(let loop ([fill fill])
 			  (unless (zero? fill)
-			    (display #\= out)
+			    (write-byte (char->integer #\=) out)
 			    (loop (sub1 fill))))
 			(display linesep out))])
 	    (let loop ([pos 0])
@@ -114,10 +114,10 @@
 			  (if (eof-object? next)
 			      (done 2)
 			      ;; More to go
-			      (let* ([next (read-char in)]
-				     [c (if (char? next)
-					    (char->integer next)
-					    0)])
+			      (let* ([next (read-byte in)]
+				     [c (if (eof-object? next)
+					    0
+					    next)])
 				(outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
 					 (arithmetic-shift c -6)))
 				(if (eof-object? next)

collects/net/qp-unit.ss

@@ -4,7 +4,7 @@
 ;;; Copyright (C) 2002 by PLT. 
 ;;; Copyright (C) 2001 by Francisco Solsona. 
 ;;;
-;;; This file is part of mime-plt.
+;;; This file was part of mime-plt.
 
 ;;; mime-plt is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -41,73 +41,65 @@
       (define-struct (qp-wrong-input qp-error) ())
       (define-struct (qp-wrong-line-size qp-error) (size))
       
-      ;; qp-encode : string -> string
+      ;; qp-encode : bytes -> bytes
       ;; returns the quoted printable representation of STR.
       (define qp-encode
         (lambda (str)
-          (let ((out (open-output-string)))
-            (qp-encode-stream (open-input-string str) out "\r\n")
-            (get-output-string out))))
+          (let ((out (open-output-bytes)))
+            (qp-encode-stream (open-input-bytes str) out #"\r\n")
+            (get-output-bytes out))))
       
       ;; qp-decode : string -> string
       ;; returns STR unqp.
       (define qp-decode
         (lambda (str)
-          (let ((out (open-output-string)))
-            (qp-decode-stream (open-input-string str) out)
-            (get-output-string out))))
+          (let ((out (open-output-bytes)))
+            (qp-decode-stream (open-input-bytes str) out)
+            (get-output-bytes out))))
       
       (define qp-decode-stream
         (lambda (in out)
-          (let ((iport (cond ((input-port? in) in)
-                             ((string? in) (open-input-string in))
-                             (else
-                              (raise (make-qp-wrong-input))))))
-            (let loop ((ln (read-line iport 'return-linefeed)))
-              (cond ((eof-object? ln) (void)) ;; done reading
-                    (else
-                     (when (> (string-length ln) 76)
-                       (warning "quoted-printable line is too long: ~a" (string-length ln)))
-                     (quoted-printable-decode-line ln out)
-                     (loop (read-line iport 'return-linefeed))))))))
-      
-      (define quoted-printable-decode-line
-        (lambda (line out)
-          (let ((in (open-input-string line)))
-            (let loop ((ch (read-char in)))
-              (if (eof-object? ch)
-		  (newline out) ;; preserve linefeed
-		  (case ch
-		    ((#\=);; quoted-printable stuff
-		     (let ((next (read-char in)))
-		       (cond ((eof-object? next);; end of qp-line
-			      null)
-			     ((hex-digit? next)
-			      (let ((next-next (read-char in)))
-				(cond ((eof-object? next-next)
-				       (warning "Illegal qp sequence: `=~a'" next)
-				       (display "=" out)
-				       (display next out))
-				      ((hex-digit? next-next)
-				       ;; qp-encoded
-				       (display (hex-octet->char
-						 (format "~a~a" next next-next))
-						out))
-				      (else
-				       (warning "Illegal qp sequence: `=~a~a'" next next-next)
-				       (display "=" out)
-				       (display next out)
-				       (display next-next out)))))
-			     (else
-			      ;; Warning: invalid
+	  (let loop ((ch (read-byte in)))
+	    (unless (eof-object? ch)
+	      (case ch
+		((61) ;; A "=", which is quoted-printable stuff
+		 (let ((next (read-byte in)))
+		   (cond 
+		    ((eq? next 10)
+		     ;; Soft-newline -- drop it
+		     (void))
+		    ((eq? next 13)
+		     ;; Expect a newline for a soft CRLF...
+		     (let ((next-next (read-byte in)))
+		       (if (eq? next-next 10)
+			   ;; Good.
+			   (loop (read-byte in))
+			   ;; Not a LF? Well, ok.
+			   (loop next-next))))
+		    ((hex-digit? next)
+		     (let ((next-next (read-byte in)))
+		       (cond ((eof-object? next-next)
 			      (warning "Illegal qp sequence: `=~a'" next)
 			      (display "=" out)
-			      (display next out)))
-		       (unless (eof-object? next) ;; eol is effectively consumed by =
-			 (loop (read-char in)))))
+			      (display next out))
+			     ((hex-digit? next-next)
+			      ;; qp-encoded
+			      (write-byte (hex-bytes->byte next next-next)
+					  out))
+			     (else
+			      (warning "Illegal qp sequence: `=~a~a'" next next-next)
+			      (write-byte 61 out)
+			      (write-byte next out)
+			      (write-byte next-next out)))))
 		    (else
-		     (display ch out)
-		     (loop (read-char in)))))))))
+		     ;; Warning: invalid
+		     (warning "Illegal qp sequence: `=~a'" next)
+		     (write-byte 61 out)
+		     (write-byte next out)))
+		   (loop (read-byte in))))
+		(else
+		 (write-byte ch out)
+		 (loop (read-byte in))))))))
       
       (define warning
         (lambda (msg . args)
@@ -115,84 +107,70 @@
 	    (fprintf (current-error-port)
 		     (apply format msg args))
 	    (newline (current-error-port)))))
-	
-      (define hex-digit?
-        (lambda (char)
-          (regexp-match (regexp "[0-9abcdefABCDEF]")
-                        (string char))))
-      
-      (define hex-octet->char
-        (lambda (str)
-          (integer->char (string->number str 16))))
-      
-      (define qp-blank?
-        (lambda (char)
-          (or (char=? char #\space)
-              (char=? char #\tab))))
-      
-      (define qp-newline
-        (lambda (port)
-          (display #\return port)
-          (display #\linefeed port)))
-      
-      (define qp-uppercase
-        (lambda (hex-octet)
-          (list->string (map char-upcase (string->list hex-octet)))))
-      
-      (define char->hex-octet
-        (lambda (char)
-          (let* ((ans (qp-uppercase
-                       (number->string (char->integer char) 16)))
-                 (padding? (< (string-length ans) 2)))
-            (if padding?
-                (format "=0~a" ans)
-                (format "=~a" ans)))))
-      
-      (define re:blanks (regexp "[ \t]+$"))
-      
-      (define display-qp-encoded
-        (lambda (line out newline-string)
-          (let* ((end-pos (string-length line))
-                 (m (regexp-match-positions re:blanks line))
-                 (force-encoding-pos (if m (caar m) end-pos)))
-            (let loop ([p 0][col 0])
-              (unless (= p end-pos)
-                (if (= col 75)
-                    (begin
-                      (write-char #\= out)
-                      (display newline-string out)
-                      (loop p 0))
-                    (let ([i (char->integer (string-ref line p))])
-                      (cond
-                        [(or (<= 33 i 60) (<= 62 i 126)
-                             (and (or (= i 32) (= i 9)) (< p force-encoding-pos)))
-                         ;; single-char mode:
-                         (write-char (integer->char i) out)
-                         (loop (add1 p) (add1 col))]
-                        [(>= col 73)
-                         ;; need a soft newline first
-                         (write-char #\= out)
-                         (display newline-string out)
-                         ;; now the octect
-                         (display (char->hex-octet (integer->char i)) out)
-                         (loop (add1 p) 3)]
-                        [else
-                         ;; the octect
-                         (display (char->hex-octet (integer->char i)) out)
-                         (loop (add1 p) (+ col 3))]))))))))
 
+      (define (hex-digit? i)
+	(vector-ref hex-values i))
+
+      (define hex-bytes->byte
+        (lambda (b1 b2)
+	  (+ (* 16 (vector-ref hex-values b1))
+	     (vector-ref hex-values b2))))
+
+      (define write-hex-bytes
+        (lambda (byte p)
+	  (write-byte 61 p)
+	  (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
+	  (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
+      
+      (define re:blanks #rx#"[ \t]+$")
+      
       (define qp-encode-stream
-        (opt-lambda (in out [newline-string "\n"])
-          (let ((iport (cond ((input-port? in) in)
-                             ((string? in) (open-input-string in))
-                             (else
-                              (raise (make-qp-wrong-input))))))
-            (let loop ([first? #t])
-              (let ([line (read-line iport 'linefeed)])
-                (unless (eof-object? line)
-                  (unless first?
-                    (display newline-string out))
-                  (display-qp-encoded line out newline-string)
-                  (loop #f))))))))))
+        (opt-lambda (in out [newline-string #"\n"])
+          (let loop ([col 0])
+	    (if (= col 75)
+		(begin
+		  ;; Soft newline:
+		  (write-byte 61 out)
+		  (display newline-string out)
+		  (loop 0))
+		(let ([i (read-byte in)])
+		  (cond
+		   [(eof-object? i) (void)]
+		   [(or (= i 10) (= i 13))
+		    (write-byte i out)
+		    (loop 0)]
+		   [(or (<= 33 i 60) (<= 62 i 126)
+			(and (or (= i 32) (= i 9)) 
+			     (not (let ([next (peek-byte in)])
+				    (or (eof-object? next) (= next 10) (= next 13))))))
+		    ;; single-byte mode:
+		    (write-byte i out)
+		    (loop (add1 col))]
+		   [(>= col 73)
+		    ;; need a soft newline first
+		    (write-byte 61 out)
+		    (display newline-string out)
+		    ;; now the octect
+		    (write-hex-bytes i out)
+		    (loop 3)]
+		   [else
+		    ;; an octect
+		    (write-hex-bytes i out)
+		    (loop (+ col 3))]))))))
+
+      ;; Tables
+      (define hex-values (make-vector 256 #f))
+      (define hex-bytes (make-vector 16))
+      (let loop ([i 0])
+	(unless (= i 10)
+	  (vector-set! hex-values (+ i 48) i)
+	  (vector-set! hex-bytes i (+ i 48))
+	  (loop (add1 i))))
+      (let loop ([i 0])
+	(unless (= i 6)
+	  (vector-set! hex-values (+ i 65) (+ 10 i))
+	  (vector-set! hex-values (+ i 97) (+ 10 i))
+	  (vector-set! hex-bytes (+ 10 i) (+ i 65))
+	  (loop (add1 i)))))))
 
 ;;; qp-unit.ss ends here