suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

CVS screw up

Browse Source 
original commit: fc3f3cad24c763db8e57d98e293ed2e28f8459a9
This commit is contained in:
Michael Burns 2004-08-26 21:20:53 +00:00
parent ea3d91cd0d
commit 9c29860de8
1 changed files with 48 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/net/uri-codec-unit.ss
View File

@ -2,7 +2,7 @@
;;; <uri-codec-unit.ss> ---- En/Decode URLs and form-urlencoded data
;;; Time-stamp: <03/04/25 10:31:31 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of Net.
@ -55,7 +55,7 @@
;; 2. The control names/values are listed in the order they appear
;; in the document. The name is separated from the value by `=' and
;; name/value pairs are separated from each other by `&' or by `;'.
;; name/value pairs are separated from each other by `&'.
;; NB: RFC 2396 supersedes RFC 1738.
@ -70,30 +70,29 @@
;; sample provided by Eli Barzilay
(module uri-codec-unit mzscheme
(require (lib "unitsig.ss")
(lib "match.ss")
(lib "string.ss")
"uri-codec-sig.ss")
(provide uri-codec@)
;; Macro to loop over integers from n (inclusive) to m (exclusive)
;; Extracted from iteration.ss in macro package at Schematics
(define-syntax for
(syntax-rules ()
((for (i n m) forms ...)
(let ((fixed-m m))
(let loop ((i n))
(if (< i fixed-m)
(begin
forms ...
(loop (+ i 1)))))))))
(syntax-rules ()
((for (i n m) forms ...)
(let ((fixed-m m))
(let loop ((i n))
(if (< i fixed-m)
(begin
forms ...
(loop (+ i 1)))))))))
(define uri-codec@
(unit/sig net:uri-codec^
(import)
;; The characters that always map to themselves
(define alphanumeric-mapping
(map (lambda (char)
@ -105,16 +104,16 @@
#\e #\f #\g #\h #\i #\j #\k #\l #\m #\n
#\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
#\y #\z)))
;; Characters that sometimes map to themselves
(define safe-mapping
(map (lambda (char)
(map (lambda (char)
(cons char char))
'(#\- #\_ #\. #\! #\~ #\* #\' #\( #\))))
;; The strict URI mapping
(define uri-mapping
(append alphanumeric-mapping safe-mapping))
(append alphanumeric-mapping safe-mapping))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
@ -124,17 +123,17 @@
(#\_ . #\_)
(#\space . #\+))
alphanumeric-mapping))
(define (number->hex-string number)
(let ((hex (number->string number 16)))
(string-append "%"
(if (= (string-length hex) 1)
(string-append "0" hex)
hex))))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(define (make-codec-tables alist)
(let ((encoding-table (make-vector 256 ""))
@ -152,17 +151,17 @@
(string orig))])
alist)
(values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
;; vector string -> string
(define (encode table str)
(apply string-append
(apply string-append
(map (lambda (char)
(vector-ref table (char->integer char)))
(string->list str))))
@ -173,7 +172,7 @@
(match-lambda
[() (list)]
[(#\% char1 char2 . rest)
(cons
(cons
(vector-ref table
(string->number (string char1 char2) 16))
(internal-decode rest))]
@ -188,42 +187,35 @@
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector str))
;; string -> string
(define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str))
;; listof (cons symbol string) -> string
;; listof (cons string string) -> string
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
(define alist->form-urlencoded
(lambda (args)
(let* ([format-one
(lambda (arg)
(let* ([name (car arg)]
[value (cdr arg)])
(string-append
(form-urlencoded-encode (symbol->string name))
"="
(form-urlencoded-encode value))))]
[strs (let loop ([args args])
(cond
[(null? args) null]
[(null? (cdr args)) (list (format-one (car args)))]
[else (list* (format-one (car args))
;; As per the defacto CGI standard, and
;; HTML 4.01
";"
(loop (cdr args)))]))])
(apply string-append strs))))
(match-lambda
[() ""]
[((name . value))
(string-append (form-urlencoded-encode name)
"="
(form-urlencoded-encode value))]
[((name . value) . rest)
(string-append (form-urlencoded-encode name)
"="
(form-urlencoded-encode value)
";"
(alist->form-urlencoded rest))]))
;; string -> listof (cons string string)
;; string -> listof (cons string string)
;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
(define (form-urlencoded->alist str)
(define key-regexp (regexp "[^=]*"))
@ -233,9 +225,7 @@
#f
(match (regexp-match-positions key-regexp str start)
[((start . end))
(vector (let ([s (form-urlencoded-decode (substring str start end))])
(string-lowercase! s)
(string->symbol s))
(vector (form-urlencoded-decode (substring str start end))
(add1 end))]
[#f #f])))
(define (next-value str start)
@ -255,17 +245,17 @@
[#f
(vector (cons key "") (string-length str))])]
[#f #f]))
(let loop ([start 0]
[end (string-length str)]
[make-alist (lambda (x) x)])
(let loop ((start 0)
(end (string-length str))
(alist '()))
(cond
[(>= start end) (make-alist '())]
[(>= start end) alist]
[else
(match (next-pair str start)
[#(pair next-start)
(loop next-start end (lambda (x) (make-alist (cons pair x))))]
[#f (make-alist '())])])))
(loop next-start end (cons pair alist))]
[#f alist])])))
))
)