Changeset 12617 in project

Timestamp:

11/27/08 21:28:16 (12 years ago)

Author:

sjamaan

Message:

Merge changes from uri-generic release 4 trunk into release 3

Location:

release/3/uri-generic/trunk

Files:

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

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

@@ -1 +1 @@
 (require-extension srfi-1)
-(require-extension uri-generic)
+(load "../uri-generic.scm")
 
 (require-extension test)
@@ -181 +181 @@
             update-cases))
 
+(define normalize-case-cases
+  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
+    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
+    ("HTTP://example/" "http://example/")
+    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
+    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
+    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
+    ("http://example/#baR%2f" "http://example/#baR%2F")))
+
+(test-group "normalize-case test"
+  (for-each (lambda (p)
+              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
+                    (expected (second p)))
+                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
+            normalize-case-cases))

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

@@ -528 +528 @@
 
 (define reg-name
-  (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 
-                                       (pct-encoded? c) 
+  (count-min-max 0 255 (lambda (c) (or (pct-encoded? c) 
+                                       (unreserved-char? c) 
                                        (char-set-contains? char-set:sub-delims c) ))))
 
@@ -1052 +1052 @@
 ;;
 ;; Case normalization; cf. RFC3986 section 6.2.2.1
-;; NOTE:  authority case normalization is not performed
 
 (define (uri-normalize-case uri)
-  (let ((u1      (udup uri))
-        (scheme  (string->symbol (string-downcase (->string (uri-scheme uri)))))
-        (path    (map (lambda (c) (match c (('% h1 h2)  `(% ,(char-upcase h1) ,(char-upcase h2)))
-                                         (else c))) (uri-path uri))))
-    (URI-scheme-set! u1 scheme)
-    (URI-path-set! u1 path)
-    u1))
-
+  (let* ((normalized-uri (uri-reference (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
+         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
+         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
+    (update-uri normalized-uri scheme: scheme host: host)))
+
+(define (normalize-pct-encoding str)
+  (uri-char-list->string
+   (map (lambda (c) (match c
+                           ((#\% h1 h2)  `(#\% ,(char-upcase h1) ,(char-upcase h2)))
+                           (else c)))
+        (uri-string->normalized-char-list str))))
 
 ;;  Path segment normalization; cf. RFC3986 section 6.2.2.4