From f9c4e4eb542b3980d0d27e6c53e10f62399c3ae4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 18:45:16 +0000 Subject: [PATCH] pr7974 + include in release svn: r14132 --- collects/net/cgi-unit.ss | 25 ++++++++++++--- collects/net/scribblings/cgi.scrbl | 6 +++- collects/tests/net/cgi.ss | 50 ++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+), 6 deletions(-) create mode 100644 collects/tests/net/cgi.ss diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss index ce92d4a38f..a42c3da5b3 100644 --- a/collects/net/cgi-unit.ss +++ b/collects/net/cgi-unit.ss @@ -96,32 +96,47 @@ ;; -- operates on the default input port; the second value indicates whether ;; reading stopped because an EOF was hit (as opposed to the delimiter being ;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter) +(define (read-until-char ip delimiter?) (let loop ([chars '()]) (let ([c (read-char ip)]) (cond [(eof-object? c) (values (reverse chars) #t)] - [(char=? c delimiter) (values (reverse chars) #f)] + [(delimiter? c) (values (reverse chars) #f)] [else (loop (cons c chars))])))) +;; delimiter->predicate : +;; symbol -> (char -> bool) +;; returns a predicates to pass to read-until-char +(define (delimiter->predicate delimiter) + (case delimiter + [(eq) (lambda (c) (char=? c #\=))] + [(amp) (lambda (c) (char=? c #\&))] + [(semi) (lambda (c) (char=? c #\;))] + [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + ;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool ;; -- If the first value is false, so is the second, and the third is true, ;; indicating EOF was reached without any input seen. Otherwise, the first ;; and second values contain strings and the third is either true or false ;; depending on whether the EOF has been reached. The strings are processed ;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in `&'. It's not clear this is legal by the CGI spec, +;; an input to end in (current-alist-separator-mode). +;; It's not clear this is legal by the CGI spec, ;; which suggests that the last value binding must end in an EOF. It doesn't ;; look like this matters. It would also introduce needless modality and ;; reduce flexibility. (define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip #\=)]) + (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) (cond [(and eof? (null? name)) (values #f #f #t)] [eof? (generate-error-output (list "Server generated malformed input for POST method:" (string-append "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) (read-until-char ip #\&)]) + [else (let-values ([(value eof?) + (read-until-char + ip + (delimiter->predicate + (current-alist-separator-mode)))]) (values (string->symbol (query-chars->string name)) (query-chars->string value) eof?))]))) diff --git a/collects/net/scribblings/cgi.scrbl b/collects/net/scribblings/cgi.scrbl index abfb1795e2..e81f5ce91f 100644 --- a/collects/net/scribblings/cgi.scrbl +++ b/collects/net/scribblings/cgi.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require "common.ss" (for-label net/cgi + net/uri-codec net/cgi-unit net/cgi-sig)) @@ -41,7 +42,10 @@ Returns the bindings that corresponding to the options specified by the user. The @scheme[get-bindings/post] and @scheme[get-bindings/get] variants work only when POST and GET forms are used, respectively, while @scheme[get-bindings] determines the -kind of form that was used and invokes the appropriate function.} +kind of form that was used and invokes the appropriate function. + +These functions respect @scheme[current-alist-separator-mode]. +} @defproc[(extract-bindings [key? (or/c symbol? string?)] diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss new file mode 100644 index 0000000000..3cc717689b --- /dev/null +++ b/collects/tests/net/cgi.ss @@ -0,0 +1,50 @@ +#lang scheme +(require net/cgi + net/uri-codec) + +(define-syntax test-result + (syntax-rules () + [(test-result expression expected) + (let ([result expression]) + (if (equal? result expected) + (display (format "Ok: `~a' evaluated to `~a'.\n" + 'expression expected)) + (display (format + "Error: `~a' evaluated to `~a', expected `~a'.\n" + 'expression result expected))))])) + +(putenv "REQUEST_METHOD" "GET") + +(test-result (begin + (current-alist-separator-mode 'amp-or-semi) + (putenv "QUERY_STRING" "key1=value1&key2=value2;key3=value3") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2") + (key3 . "value3"))) + +(test-result (begin + (current-alist-separator-mode 'amp) + (putenv "QUERY_STRING" "key1=value1&key2=value2") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2"))) + +(test-result (begin + (current-alist-separator-mode 'amp) + (putenv "QUERY_STRING" "key1=value1;key2=value2") + (get-bindings)) + '((key1 . "value1;key2=value2"))) + +(test-result (begin + (current-alist-separator-mode 'semi) + (putenv "QUERY_STRING" "key1=value1;key2=value2") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2"))) + +(test-result (begin + (current-alist-separator-mode 'semi) + (putenv "QUERY_STRING" "key1=value1&key2=value2") + (get-bindings)) + '((key1 . "value1&key2=value2"))) \ No newline at end of file