Fix CVS crap

original commit: cc9a1fe584a421095441c48197ad18bb0dae06b7
This commit is contained in:
Michael Burns 2004-08-28 05:24:53 +00:00
parent 9c29860de8
commit a06af27c72

View File

@ -2,7 +2,7 @@
;;; <uri-codec-unit.ss> ---- En/Decode URLs and form-urlencoded data ;;; <uri-codec-unit.ss> ---- En/Decode URLs and form-urlencoded data
;;; Time-stamp: <03/04/25 10:31:31 noel> ;;; 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. ;;; This file is part of Net.
@ -70,29 +70,30 @@
;; sample provided by Eli Barzilay ;; sample provided by Eli Barzilay
(module uri-codec-unit mzscheme (module uri-codec-unit mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "match.ss") (lib "match.ss")
(lib "string.ss")
"uri-codec-sig.ss") "uri-codec-sig.ss")
(provide uri-codec@) (provide uri-codec@)
;; Macro to loop over integers from n (inclusive) to m (exclusive) ;; Macro to loop over integers from n (inclusive) to m (exclusive)
;; Extracted from iteration.ss in macro package at Schematics ;; Extracted from iteration.ss in macro package at Schematics
(define-syntax for (define-syntax for
(syntax-rules () (syntax-rules ()
((for (i n m) forms ...) ((for (i n m) forms ...)
(let ((fixed-m m)) (let ((fixed-m m))
(let loop ((i n)) (let loop ((i n))
(if (< i fixed-m) (if (< i fixed-m)
(begin (begin
forms ... forms ...
(loop (+ i 1))))))))) (loop (+ i 1)))))))))
(define uri-codec@ (define uri-codec@
(unit/sig net:uri-codec^ (unit/sig net:uri-codec^
(import) (import)
;; The characters that always map to themselves ;; The characters that always map to themselves
(define alphanumeric-mapping (define alphanumeric-mapping
(map (lambda (char) (map (lambda (char)
@ -104,16 +105,16 @@
#\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n
#\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
#\y #\z))) #\y #\z)))
;; Characters that sometimes map to themselves ;; Characters that sometimes map to themselves
(define safe-mapping (define safe-mapping
(map (lambda (char) (map (lambda (char)
(cons char char)) (cons char char))
'(#\- #\_ #\. #\! #\~ #\* #\' #\( #\)))) '(#\- #\_ #\. #\! #\~ #\* #\' #\( #\))))
;; The strict URI mapping ;; The strict URI mapping
(define uri-mapping (define uri-mapping
(append alphanumeric-mapping safe-mapping)) (append alphanumeric-mapping safe-mapping))
;; The form-urlencoded mapping ;; The form-urlencoded mapping
(define form-urlencoded-mapping (define form-urlencoded-mapping
@ -123,17 +124,17 @@
(#\_ . #\_) (#\_ . #\_)
(#\space . #\+)) (#\space . #\+))
alphanumeric-mapping)) alphanumeric-mapping))
(define (number->hex-string number) (define (number->hex-string number)
(let ((hex (number->string number 16))) (let ((hex (number->string number 16)))
(string-append "%" (string-append "%"
(if (= (string-length hex) 1) (if (= (string-length hex) 1)
(string-append "0" hex) (string-append "0" hex)
hex)))) hex))))
(define (hex-string->number hex-string) (define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16)) (string->number (substring hex-string 1 3) 16))
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string)) ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(define (make-codec-tables alist) (define (make-codec-tables alist)
(let ((encoding-table (make-vector 256 "")) (let ((encoding-table (make-vector 256 ""))
@ -151,17 +152,17 @@
(string orig))]) (string orig))])
alist) alist)
(values encoding-table decoding-table))) (values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector) (define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping)) (make-codec-tables uri-mapping))
(define-values (form-urlencoded-encoding-vector (define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector) form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping)) (make-codec-tables form-urlencoded-mapping))
;; vector string -> string ;; vector string -> string
(define (encode table str) (define (encode table str)
(apply string-append (apply string-append
(map (lambda (char) (map (lambda (char)
(vector-ref table (char->integer char))) (vector-ref table (char->integer char)))
(string->list str)))) (string->list str))))
@ -172,7 +173,7 @@
(match-lambda (match-lambda
[() (list)] [() (list)]
[(#\% char1 char2 . rest) [(#\% char1 char2 . rest)
(cons (cons
(vector-ref table (vector-ref table
(string->number (string char1 char2) 16)) (string->number (string char1 char2) 16))
(internal-decode rest))] (internal-decode rest))]
@ -187,14 +188,14 @@
(define (uri-encode str) (define (uri-encode str)
(encode uri-encoding-vector str)) (encode uri-encoding-vector str))
;; string -> string ;; string -> string
(define (uri-decode str) (define (uri-decode str)
(decode uri-decoding-vector str)) (decode uri-decoding-vector str))
;; string -> string ;; string -> string
(define (form-urlencoded-encode str) (define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str)) (encode form-urlencoded-encoding-vector str))
;; string -> string ;; string -> string
(define (form-urlencoded-decode str) (define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str)) (decode form-urlencoded-decoding-vector str))
@ -225,7 +226,9 @@
#f #f
(match (regexp-match-positions key-regexp str start) (match (regexp-match-positions key-regexp str start)
[((start . end)) [((start . end))
(vector (form-urlencoded-decode (substring str start end)) (vector (let ([s (form-urlencoded-decode (substring str start end))])
(string-lowercase! s)
(string->symbol s))
(add1 end))] (add1 end))]
[#f #f]))) [#f #f])))
(define (next-value str start) (define (next-value str start)
@ -245,17 +248,17 @@
[#f [#f
(vector (cons key "") (string-length str))])] (vector (cons key "") (string-length str))])]
[#f #f])) [#f #f]))
(let loop ((start 0) (let loop ([start 0]
(end (string-length str)) [end (string-length str)]
(alist '())) [make-alist (lambda (x) x)])
(cond (cond
[(>= start end) alist] [(>= start end) (make-alist '())]
[else [else
(match (next-pair str start) (match (next-pair str start)
[#(pair next-start) [#(pair next-start)
(loop next-start end (cons pair alist))] (loop next-start end (lambda (x) (make-alist (cons pair x))))]
[#f alist])]))) [#f (make-alist '())])])))
)) ))
) )