From 20e96730286af60a5d5ded2fb64980221974d3b2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 28 Aug 2008 21:00:53 +0000 Subject: [PATCH] more base64-related changes svn: r11470 --- collects/net/base64-unit.ss | 82 +++++++---------- collects/tests/mzscheme/net.ss | 163 ++++++++++++++++++++------------- 2 files changed, 131 insertions(+), 114 deletions(-) diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss index 126ca0b4df..3468b4e2b5 100644 --- a/collects/net/base64-unit.ss +++ b/collects/net/base64-unit.ss @@ -17,58 +17,42 @@ (values (vector->immutable-vector bd) (vector->immutable-vector db)))) (define =byte (bytes-ref #"=" 0)) +(define ones + (vector->immutable-vector + (list->vector (for/list ([i (in-range 9)]) (sub1 (arithmetic-shift 1 i)))))) (define (base64-decode-stream in out) - (let loop ([waiting 0] [waiting-bits 0]) - (if (>= waiting-bits 8) - (begin - (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* ([c (read-byte in)] - [c (if (eof-object? c) =byte c)] - [v (vector-ref base64-digit c)]) - (cond [v (loop (+ (arithmetic-shift waiting 6) v) - (+ waiting-bits 6))] - [(eq? c =byte) (void)] ; done - [else (loop waiting waiting-bits)]))))) + (let loop ([data 0] [bits 0]) + (if (>= bits 8) + (let ([bits (- bits 8)]) + (write-byte (arithmetic-shift data (- bits)) out) + (loop (bitwise-and data (vector-ref ones bits)) bits)) + (let ([c (read-byte in)]) + (unless (or (eof-object? c) (eq? c =byte)) + (let ([v (vector-ref base64-digit c)]) + (if v + (loop (+ (arithmetic-shift data 6) v) (+ bits 6)) + (loop data bits)))))))) -(define base64-encode-stream - (case-lambda - [(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) - (write-byte (vector-ref digit-base64 n) out))] - [done (lambda (fill) - (for ([i (in-range 0 fill)]) (write-byte =byte out)) - (display linesep out))]) - (let loop ([pos 0]) - (if (= pos 72) - ;; Insert newline - (begin (display linesep out) (loop 0)) - ;; Next group of 3 - (let ([n (read-bytes! three in)]) - (if (eof-object? n) - (unless (= pos 0) (done 0)) - (let ([a (bytes-ref three 0)] - [b (if (n . >= . 2) (bytes-ref three 1) 0)] - [c (if (n . >= . 3) (bytes-ref three 2) 0)]) - (outc (arithmetic-shift a -2)) - (outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) - (arithmetic-shift b -4))) - (if (n . < . 2) - (done 2) - (begin (outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) - (arithmetic-shift c -6))) - (if (n . < . 3) - (done 1) - (begin (outc (bitwise-and #x3f c)) - (loop (+ pos 4))))))))))))])) +(define (base64-encode-stream in out [linesep #"\n"]) + (let loop ([data 0] [bits 0] [width 0]) + (define (write-char) + (let ([width (modulo (add1 width) 72)]) + (when (zero? width) (display linesep out)) + (write-byte (vector-ref digit-base64 (arithmetic-shift data (- 6 bits))) + out) + width)) + (if (>= bits 6) + (let ([bits (- bits 6)]) + (loop (bitwise-and data (vector-ref ones bits)) bits (write-char))) + (let ([c (read-byte in)]) + (if (eof-object? c) + ;; flush extra bits + (let ([width (if (> bits 0) (write-char) width)]) + (when (> width 0) + (for ([i (in-range (modulo (- width) 4))]) (write-byte =byte out)) + (display linesep out))) + (loop (+ (arithmetic-shift data 8) c) (+ bits 8) width)))))) (define (base64-decode src) (let ([s (open-output-bytes)]) diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 6e63ec5e0e..12958a1d76 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -9,7 +9,7 @@ ;; (require net/url - net/uri-codec + net/uri-codec mzlib/string ) @@ -35,12 +35,12 @@ form-urlencoded->alist "x=foo&y=bar;z=baz") (parameterize ([current-alist-separator-mode 'semi]) (test '((a . "hel+lo&b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'amp]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) + (parameterize ([current-alist-separator-mode 'amp]) + (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) (parameterize ([current-alist-separator-mode 'amp]) (test '((a . "hel+lo;b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'semi]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) + (parameterize ([current-alist-separator-mode 'semi]) + (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) (test "aNt=Hi" alist->form-urlencoded '((aNt . "Hi"))) (test '((aNt . "Hi")) form-urlencoded->alist (alist->form-urlencoded '((aNt . "Hi")))) (test "aNt=Hi" alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) @@ -57,7 +57,7 @@ (lambda () ;; Test all ASCII chars (let ([p (let loop ([n 0]) - (if (= n 128) + (if (= n 128) null (let ([s (string (char-downcase (integer->char n)))]) (cons (cons (string->symbol s) s) @@ -649,85 +649,118 @@ ;; (require net/base64 - net/qp - mzlib/port) + net/qp + mzlib/port) (define tricky-strings (let ([dir (collection-path "tests" "mzscheme")]) (list (make-bytes 200 32) - (make-bytes 200 9) - (make-bytes 200 (char->integer #\x)) - (list->bytes - (let loop ([i 0]) - (if (= i 256) - null - (cons i (loop (add1 i)))))) - ;; Something that doesn't end with a LF: - (bytes-append - (with-input-from-file (build-path dir "net.ss") (lambda () (read-bytes 500))) - #"xxx") - ;; CRLF: - (regexp-replace - #rx#"\n" - (with-input-from-file (build-path dir "net.ss") (lambda () (read-bytes 500))) - #"\r\n")))) + (make-bytes 200 9) + (make-bytes 200 (char->integer #\x)) + (make-bytes 201 (char->integer #\x)) + (make-bytes 202 (char->integer #\x)) + (make-bytes 203 (char->integer #\x)) + (make-bytes 204 (char->integer #\x)) + (list->bytes + (let loop ([i 0]) + (if (= i 256) + null + (cons i (loop (add1 i)))))) + ;; Something that doesn't end with a LF: + (bytes-append (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"xxx") + ;; CRLF: + (regexp-replace #rx#"\r?\n" + (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"\r\n")))) (define (check-same encode decode port line-rx max-w) (let ([p (open-output-bytes)]) (copy-port port p) (let ([bytes (get-output-bytes p)] - [r (open-output-bytes)]) + [r (open-output-bytes)]) (encode (open-input-bytes bytes) r) (let ([p (open-input-bytes (get-output-bytes r))]) - (let loop () - (let ([l (read-bytes-line p 'any)]) - (unless (eof-object? l) - (unless (<= (bytes-length l) max-w) - (test encode "line too long" l)) - (let ([m (regexp-match-positions line-rx l)]) - (unless (and m - (= (bytes-length l) (cdar m))) - (test encode 'bad-line l))) - (loop)))) - (let ([q (open-output-bytes)]) - (decode (open-input-bytes (get-output-bytes r)) q) - (unless (equal? (get-output-bytes q) bytes) - (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) - (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) - (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) - (error 'decode "failed"))))))) + (let loop () + (let ([l (read-bytes-line p 'any)]) + (unless (eof-object? l) + (unless (<= (bytes-length l) max-w) + (test encode "line too long" l)) + (let ([m (regexp-match-positions line-rx l)]) + (unless (and m (= (bytes-length l) (cdar m))) + (test encode 'bad-line l))) + (loop)))) + (let ([q (open-output-bytes)]) + (decode (open-input-bytes (get-output-bytes r)) q) + (unless (equal? (get-output-bytes q) bytes) + (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) + (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) + (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) + (error 'decode "failed"))))))) -(define (check-same-file encode decode file line-rx max-w) +(define ((check-same-file encode decode line-rx max-w) file) ;; This "test" is really just a progress report: (test #t list? (list file encode)) (call-with-input-file file - (lambda (p) - (check-same encode decode p line-rx max-w)))) + (lambda (p) (check-same encode decode p line-rx max-w)))) (define (check-same-all encode decode line-rx max-w) (for-each (lambda (tricky-string) - (check-same encode decode - (open-input-bytes tricky-string) - line-rx max-w)) - tricky-strings) - (parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) - (random-seed 17) - (let ([dir (collection-path "tests" "mzscheme")]) - (for-each (lambda (p) - (when (regexp-match #rx"[.]ss$" (path->string p)) - (unless (or (positive? (random 10)) ; check random 1/10 of files - (equal? (path->string p) "flat.ss")) - (check-same-file encode decode (build-path dir p) line-rx max-w)))) - (directory-list dir))))) + (check-same encode decode + (open-input-bytes tricky-string) + line-rx max-w)) + tricky-strings) + (let* ([dir (collection-path "tests" "mzscheme")] + [files (filter-map (lambda (f) + ;; check 1/3 of the files, randomly + (let ([p (build-path dir f)]) + (and (zero? (random 3)) + (not (regexp-match + #rx"^flat.*\\.ss$" + (path-element->string f))) + (file-exists? p) + p))) + (directory-list dir))]) + (for-each (check-same-file encode decode line-rx max-w) files))) (check-same-all (lambda (i o) (qp-encode-stream i o)) - qp-decode-stream - #rx#"^(|[\t \41-\176]*[\41-\176]+)$" - 76) + qp-decode-stream + #rx#"^(|[\t \41-\176]*[\41-\176]+)$" + 76) -(check-same-all base64-encode-stream - base64-decode-stream - #rx#"^[0-9a-zA-Z+=/]*$" - 72) +(check-same-all base64-encode-stream + base64-decode-stream + #rx#"^[0-9a-zA-Z+=/]*$" + 72) + +#| +Use this to compare base64 encode/decode against the unix utilities +(require net/base64 scheme/system) +(define (base64-encode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-encode")) + (let* ([o (get-output-bytes o)] + [o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")] + [o (regexp-replace* #rx#"\r?\n" o #"\r\n")]) + o))) +(define (base64-decode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-decode")) + (get-output-bytes o))) +(define (check-base64-encode bstr) + (equal? (base64-encode bstr) (base64-encode* bstr))) +(define (check-base64-decode bstr) + (equal? (base64-decode bstr) (base64-decode* bstr))) +(define (check-base64-both bstr) + (let ([en (base64-encode bstr)]) + (and (equal? en (base64-encode* bstr)) + (equal? (base64-decode en) (base64-decode* en))))) +|# (report-errs)