guile-www-2.9 (www cgi) Tests for query-string parsing

[Alan Grover]

This script tests several interesting cases of query-strings. Add more 
tests to the obvious list (either a string, or a cons pair of the string 
and the expected result). There is a bunch of my debug messages in the 
file, which are turned off. Works under guile 1.6.4.

Line wrapping mangled!

---

#!/bin/sh
#guile --debug -s $0
guile --debug -c "(set! %load-path (cons \".\" %load-path)) (load \"$0\")"
exit;
!#

(use-modules (www cgi))
(use-modules (srfi srfi-1))
(use-modules (www url))

(define kDebug #f)
(if kDebug
        (use-modules (awg debug))
        (define (debug . x) #f))

; Various query-string test values
; After parsing, the test will reassemble the query-string and see if it 
matches
; Does not round-trip a "+" correctly: comes back as a %20 encoded value
(define test-values (list
        ""
        "noval"
        (cons "noval2=" "noval2")
        "val=1"
        (cons "noval&" "noval")
        (cons "val=a&val=" "val=a&val")
        (cons "val=1&" "val=1")
        (cons "val=a=b" "val=a%3db")
        (cons "val=a&=b" "val=a&=b")
        "noval&noval2"
        "val=1&noval2"
        "val=1&val2=2"
        "val=a&val"
        (cons "val=a+b" "val=a%20b")
        (cons "=bad-term"  "=bad-term")
        (cons "noval1&&noval2"  "noval1&noval2")
        "val=a&val=b"
        "val&val"
        "with%26amper=with%3dequal"
        "with%3damper"
        (cons "val=a&val2=c&val=b" "val=a&val=b&val2=c")
        "a=1&b=2&c=3"
        ))


(define (join binder str-list)
        "join binder list => appends the list together with binder between"
                (fold-right
                        (lambda (head done) (if (eq? done '()) head 
(string-append head binder done)))
                        '()
                        str-list))

(define (do-test)
        (letrec (
                (print-if (lambda (bool test-results)
                        "print if bool eq t-or-f"
                        ; could have been a foreach
                        (define (_print-if aResult)
                                (let* ( (status (car aResult)))
                                        (if (eq? status bool) (begin 
(display aResult ) (newline)))))
                        (for-each _print-if test-results)))
                (comparer (lambda (qstring-or-pair)
                        "parse via cgi:init, reassemble, test for equal?"
                        (let* (
                                (qstring (if (pair? qstring-or-pair) 
(car qstring-or-pair) qstring-or-pair))
                                (explicit-wanted (if (pair? 
qstring-or-pair) (cdr qstring-or-pair) #f))
                                (qstring-names
                                        (begin (environ (list 
(string-append "QUERY_STRING=" qstring)))
                                                (debug "qstring '" 
qstring "'")
                                                (cgi:init)
                                                (cgi:names) ))
                                (other-url-encode-bad (string->list 
"+%=&"))
                                (assemble-key-value (lambda (name)
                                        (if (not name)
                                                "<no-name>"
                                                (let* (
                                                        (enc-key (if 
name (url:encode name other-url-encode-bad) "<no-enc-name>"))
                                                        (raw-values (if 
name (cgi:values name) "<no-values>"))
                                                        (assemble-one 
(lambda (raw-value)
                                                                (debug 
"\t\traw " enc-key " => '" raw-value "'")

(string-append

 enc-key

 (if (or (not raw-value)  (equal? raw-value ""))

         ""

         (string-append "=" (url:encode raw-value 
other-url-encode-bad))))))
                                                        )
                                                        (if (not 
raw-values )
                                                                enc-key 
; no "="
                                                                (join 
"&" (map assemble-one raw-values)))
                                                        ))))
                                (rebuilt-key-values
                                        (begin
                                                (debug "cgi:names " 
qstring-names "\n")
                                                (if (or (not 
qstring-names) (eq? qstring-names '()) )
                                                        (list "")
                                                        (map 
assemble-key-value qstring-names) )))
                                (rebuilt-qstring (join "&" 
rebuilt-key-values))
                                ; + and %20 are the same, so normalize
                                (normalized-qstring (or explicit-wanted 
qstring))
                                )
                        (list (equal? normalized-qstring 
rebuilt-qstring) (list (list 'qstring qstring) (list 'wanted 
normalized-qstring) (list 'rebuilt rebuilt-qstring) cgi:names-values)))))
                )
                ; collect results
                ; why can't I put this in the letrec?
                (define results (map comparer test-values))

                ; Print 'em
                (print-if #t results)
                (display " ---Fails:") (newline)
                (print-if #f results)
        ))

(do-test)



--
Alan Grover
address@hidden
+1.734.476.0969