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)