Changeset 12842 in project

Timestamp:

12/17/08 22:10:49 (12 years ago)

Author:

sjamaan

Message:

Merge latest changes of uri-generic release 4

Location:

release/3/uri-generic/trunk

Files:

• . (modified) (1 prop)
• tests/run.scm (modified) (2 diffs)
• uri-generic.scm (modified) (7 diffs)

release/3/uri-generic/trunk/tests/run.scm

@@ -196 +196 @@
             encode/decode-cases))
 
-(define update-cases
-  '(("/foo" (path: (/ "bar")) "/bar")
-    ("/foo" (path: ("bar")) "bar")
-    ("/foo" (host: "localhost") "//localhost/foo")
-    ("http://foo" (query: "a=b&c&d?=%2fe") "http://foo?a=b&c&d?=%2fe")
-    ("http://foo" (host: #f) "http:")
-    ("http://foo" (authority: #f) "http:")))
-
-(test-group "update-uri test"
-  (for-each (lambda (p)
-              (let ((expected (uri-reference (third p)))
-                    (updated (apply update-uri (uri-reference (first p)) (second p))))
-                  (test (sprintf "~S * ~S -> ~S" (first p) (second p) (third p)) expected updated)))
-            update-cases))
-
 (define normalize-case-cases
   '(("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))))))
             normalize-case-cases))
+
+(define internal-representation-cases
+  `((,uri-scheme
+     ;; pct-encoding not allowed in scheme
+     ("http.:" http.)
+     ("http+:" http+)
+     ("http-:" http-)
+     ("HTTP:" HTTP)
+     ("" #f)
+     ("/foo" #f)
+     (":" ||))
+    (,uri-path
+     ("foo%20bar" ("foo%20bar"))
+     ("foo%2Fbar" ("foo/bar"))
+     ("foo%2ebar" ("foo.bar") "foo.bar")
+     ("foo/bar%2Fqux" ("foo" "bar/qux"))
+     ("foo/" ("foo" ""))
+     ("foo/bar:qux" ("foo" "bar:qux"))
+     ("/foo%2Fbar" (/ "foo/bar"))
+     ("/foo/" (/ "foo" ""))
+     ("/foo:bar" (/ "foo:bar")))))
+
+(test-group "internal representations"
+  (for-each (lambda (p)
+              (for-each (lambda (u)
+                          (let ((in (first u))
+                                (internal (second u))
+                                (out (if (null? (cddr u))
+                                         (first u)
+                                         (third u)))
+                                (uri (uri-reference (first u))))
+                            (test (sprintf "~S decoded as ~S" in internal)
+                                  internal ((car p) uri))
+                            (test (sprintf "~S encoded to ~S" internal out)
+                                  out (uri->string uri))))
+                        (cdr p)))
+            internal-representation-cases))
+
+(test-group "miscellaneous"
+  ;; Special case, see section 4.2
+  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))

release/3/uri-generic/trunk/uri-generic.scm

@@ -243 +243 @@
 ;; Returns a 'pct-encoded' sequence of octets.
 ;;
-(define (pct-encode lst)
-  (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
-  (reverse (fold (lambda (x ax)
-                   (let ((h1 (hex-digit (quotient x 16)))
-                         (h2 (hex-digit (remainder x 16))))
-                     (cons `(#\% ,h1 ,h2)  ax)))
-                 (list) lst)))
+(define (pct-encode char-list #!optional (char-set char-set:unreserved))
+  (define (hex-digit i)
+    (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
+  (reverse (fold (lambda (c cl)
+                   (if (char-set-contains? char-set c)
+                       (let* ((x (char->integer c))
+                              (h1 (hex-digit (quotient x 16)))
+                              (h2 (hex-digit (remainder x 16))))
+                         (cons `(#\% ,h1 ,h2) cl))
+                       (cons c cl)))
+                 (list) char-list)))
 
   
@@ -296 +300 @@
 
 (define (uri-path-list->path pcl)
-  (match pcl
-         (('/ . rst) (cons '/ (map uri-char-list->string rst)))
-         (else (map uri-char-list->string pcl))))
+  (let ((cs (char-set-union char-set:unreserved (char-set #\/))))
+    (match pcl
+           (('/ . rst) (cons '/ (map (compose uri-char-list->string (cute pct-decode <> cs)) rst)))
+           (else (map (compose uri-char-list->string (cute pct-decode <> cs)) pcl)))))
 
 (define (hier-part s)
@@ -718 +723 @@
 (define (path->string path)
   (match path
-         (('/ . segments) (string-join segments "/" 'prefix))
-         (else (string-join path "/" 'infix))))
+         (('/ . segments)     (string-append "/" (join-segments segments)))
+         (((? protect?) . _)  (join-segments (cons "." path)))
+         (else                (join-segments path))))
+
+(define (join-segments segments)
+  (string-intersperse
+   (map (lambda (segment)
+          (string-translate* segment '(("/" . "%2F"))))
+        segments) "/"))
+
+;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
+(define (protect? sa) (string-index sa #\:))
 
 ; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
@@ -739 +754 @@
 ;;  Percent encoding and decoding
 
-(define (char-list-encode p enc str)
-  (reverse
-   (fold (lambda (c ax) 
-           (if (p c) (let* ((os (enc c))  
-                            (cs (pct-encode os)))
-                       (append (reverse cs) ax))
-               (cons c ax)))
-         (list) str)))
-
 (define (integer->octets i)
   (let loop ((i i) (lst (list)))
@@ -758 +764 @@
   (let ((clst (string->list str)))
     (uri-char-list->string
-     (char-list-encode (disjoin pct? reserved-char?) (compose integer->octets char->integer) clst))))
+     (pct-encode clst (char-set-union (char-set #\%) char-set:reserved)))))
 
 
@@ -766 +772 @@
         (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
 
-(define (pct-decode c)
-  (match c
-         ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
-         (else c)))
+(define (pct-decode char-list #!optional (char-set char-set:unreserved))
+  (map (lambda (c)
+        (match c
+               ((#\% h1 h2) (let ((dc (integer->char (octet-decode h1 h2))))
+                              (if (char-set-contains? char-set dc) dc c)))
+               (else c)))
+       char-list))
 
 (define (octet-decode h1 h2)
@@ -789 +798 @@
 (define (uri-string->normalized-char-list str)
   (let ((clst (uri-string->char-list str)))
-    (map (lambda (c) (if (pct-encoded? c) 
-                         (let ((e (pct-decode c)))
-                           (if (unreserved-char? e) e c)) c))
-         clst)))
-                         
+    (pct-decode clst)))