more base64-related changes
svn: r11470
This commit is contained in:
Eli Barzilay
parent
8ac94b683c
commit
20e9673028
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user