Changeset 12842 in project
- Timestamp:
- 12/17/08 22:10:49 (12 years ago)
- Location:
- release/3/uri-generic/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/uri-generic/trunk
- Property svn:mergeinfo changed
/release/4/uri-generic/trunk merged: 12841
- Property svn:mergeinfo changed
-
release/3/uri-generic/trunk/tests/run.scm
r12828 r12842 196 196 encode/decode-cases)) 197 197 198 (define update-cases199 '(("/foo" (path: (/ "bar")) "/bar")200 ("/foo" (path: ("bar")) "bar")201 ("/foo" (host: "localhost") "//localhost/foo")202 ("http://foo" (query: "a=b&c&d?=%2fe") "http://foo?a=b&c&d?=%2fe")203 ("http://foo" (host: #f) "http:")204 ("http://foo" (authority: #f) "http:")))205 206 (test-group "update-uri test"207 (for-each (lambda (p)208 (let ((expected (uri-reference (third p)))209 (updated (apply update-uri (uri-reference (first p)) (second p))))210 (test (sprintf "~S * ~S -> ~S" (first p) (second p) (third p)) expected updated)))211 update-cases))212 213 198 (define normalize-case-cases 214 199 '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar") … … 226 211 (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass)))))) 227 212 normalize-case-cases)) 213 214 (define internal-representation-cases 215 `((,uri-scheme 216 ;; pct-encoding not allowed in scheme 217 ("http.:" http.) 218 ("http+:" http+) 219 ("http-:" http-) 220 ("HTTP:" HTTP) 221 ("" #f) 222 ("/foo" #f) 223 (":" ||)) 224 (,uri-path 225 ("foo%20bar" ("foo%20bar")) 226 ("foo%2Fbar" ("foo/bar")) 227 ("foo%2ebar" ("foo.bar") "foo.bar") 228 ("foo/bar%2Fqux" ("foo" "bar/qux")) 229 ("foo/" ("foo" "")) 230 ("foo/bar:qux" ("foo" "bar:qux")) 231 ("/foo%2Fbar" (/ "foo/bar")) 232 ("/foo/" (/ "foo" "")) 233 ("/foo:bar" (/ "foo:bar"))))) 234 235 (test-group "internal representations" 236 (for-each (lambda (p) 237 (for-each (lambda (u) 238 (let ((in (first u)) 239 (internal (second u)) 240 (out (if (null? (cddr u)) 241 (first u) 242 (third u))) 243 (uri (uri-reference (first u)))) 244 (test (sprintf "~S decoded as ~S" in internal) 245 internal ((car p) uri)) 246 (test (sprintf "~S encoded to ~S" internal out) 247 out (uri->string uri)))) 248 (cdr p))) 249 internal-representation-cases)) 250 251 (test-group "miscellaneous" 252 ;; Special case, see section 4.2 253 (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar"))))) -
release/3/uri-generic/trunk/uri-generic.scm
r12828 r12842 243 243 ;; Returns a 'pct-encoded' sequence of octets. 244 244 ;; 245 (define (pct-encode lst) 246 (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i))))) 247 (reverse (fold (lambda (x ax) 248 (let ((h1 (hex-digit (quotient x 16))) 249 (h2 (hex-digit (remainder x 16)))) 250 (cons `(#\% ,h1 ,h2) ax))) 251 (list) lst))) 245 (define (pct-encode char-list #!optional (char-set char-set:unreserved)) 246 (define (hex-digit i) 247 (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i))))) 248 (reverse (fold (lambda (c cl) 249 (if (char-set-contains? char-set c) 250 (let* ((x (char->integer c)) 251 (h1 (hex-digit (quotient x 16))) 252 (h2 (hex-digit (remainder x 16)))) 253 (cons `(#\% ,h1 ,h2) cl)) 254 (cons c cl))) 255 (list) char-list))) 252 256 253 257 … … 296 300 297 301 (define (uri-path-list->path pcl) 298 (match pcl 299 (('/ . rst) (cons '/ (map uri-char-list->string rst))) 300 (else (map uri-char-list->string pcl)))) 302 (let ((cs (char-set-union char-set:unreserved (char-set #\/)))) 303 (match pcl 304 (('/ . rst) (cons '/ (map (compose uri-char-list->string (cute pct-decode <> cs)) rst))) 305 (else (map (compose uri-char-list->string (cute pct-decode <> cs)) pcl))))) 301 306 302 307 (define (hier-part s) … … 718 723 (define (path->string path) 719 724 (match path 720 (('/ . segments) (string-join segments "/" 'prefix)) 721 (else (string-join path "/" 'infix)))) 725 (('/ . segments) (string-append "/" (join-segments segments))) 726 (((? protect?) . _) (join-segments (cons "." path))) 727 (else (join-segments path)))) 728 729 (define (join-segments segments) 730 (string-intersperse 731 (map (lambda (segment) 732 (string-translate* segment '(("/" . "%2F")))) 733 segments) "/")) 734 735 ;; Section 4.2; if the first segment contains a colon, it must be prefixed "./" 736 (define (protect? sa) (string-index sa #\:)) 722 737 723 738 ; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)). … … 739 754 ;; Percent encoding and decoding 740 755 741 (define (char-list-encode p enc str)742 (reverse743 (fold (lambda (c ax)744 (if (p c) (let* ((os (enc c))745 (cs (pct-encode os)))746 (append (reverse cs) ax))747 (cons c ax)))748 (list) str)))749 750 756 (define (integer->octets i) 751 757 (let loop ((i i) (lst (list))) … … 758 764 (let ((clst (string->list str))) 759 765 (uri-char-list->string 760 ( char-list-encode (disjoin pct? reserved-char?) (compose integer->octets char->integer) clst))))766 (pct-encode clst (char-set-union (char-set #\%) char-set:reserved))))) 761 767 762 768 … … 766 772 (loop (+ i (* (car lst) m)) (* m 256) (cdr lst))))) 767 773 768 (define (pct-decode c) 769 (match c 770 ((#\% h1 h2) (integer->char (octet-decode h1 h2))) 771 (else c))) 774 (define (pct-decode char-list #!optional (char-set char-set:unreserved)) 775 (map (lambda (c) 776 (match c 777 ((#\% h1 h2) (let ((dc (integer->char (octet-decode h1 h2)))) 778 (if (char-set-contains? char-set dc) dc c))) 779 (else c))) 780 char-list)) 772 781 773 782 (define (octet-decode h1 h2) … … 789 798 (define (uri-string->normalized-char-list str) 790 799 (let ((clst (uri-string->char-list str))) 791 (map (lambda (c) (if (pct-encoded? c) 792 (let ((e (pct-decode c))) 793 (if (unreserved-char? e) e c)) c)) 794 clst))) 795 800 (pct-decode clst))) 796 801 797 802
Note: See TracChangeset
for help on using the changeset viewer.