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 [EMAIL PROTECTED] +1.734.476.0969
_______________________________________________ Bug-guile mailing list [email protected] http://lists.gnu.org/mailman/listinfo/bug-guile
