Changeset 28092 in project for release/4/uri-generic/branches

Timestamp:

01/15/13 06:16:10 (8 years ago)

Author:

Ivan Raikov

Message:

uri-generic: some more work on utf8 branch

Location:

release/4/uri-generic/branches/utf8

Files:

• tests/run.scm (modified) (1 diff)
• uri-generic.scm (modified) (6 diffs)

release/4/uri-generic/branches/utf8/tests/run.scm

@@ -553 +553 @@
   '(;; URI representation of IRIs test cases 
     ("http://example.com/삌계탕"
-     "http://example.com/test")
+     "http://example.com/%EC%82%BC%EA%B3%84%ED%83%95")
     ))
 
 (test-group "URI representation of IRIs"
   (for-each (lambda (s) 
-              (test (cadr s) (uri->string (iri/uri-map (car s)))))
+              (test (cadr s) (uri->string (utf8-string->uri (car s)))))
             utf8-cases))
 

release/4/uri-generic/branches/utf8/uri-generic.scm

@@ -41 +41 @@
 
 (module uri-generic
-  (uri-reference iri->uri make-uri update-uri update-authority
+  (uri-reference utf8-string->uri make-uri update-uri update-authority
    uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
    uri-fragment uri-host uri-port uri-username uri-password
@@ -155 +155 @@
 (define (alpha-char? c)       (and (char? c) (char-set-contains? char-set:letter c)))
 
-(define (pct-encoded? c)      (match c ((#\% h1 h2) (and (hexdigit-char? h1) (hexdigit-char? h2)))
+(define (pct-encoded? c)      (match c ((#\% h1 h2 . rst) 
+                                        (and (hexdigit-char? h1) (hexdigit-char? h2)
+                                             (or (null? rst) (pct-encoded? rst))))
                                      (else #f)))
    
@@ -691 +693 @@
 ;; IRI to URI mapping (RFC3987, section 3.1)
 
-(define (iri->uri s)
-  (let ((s (if (string? s) (uri-string->char-list s) s)))
+(define (utf8-string->uri s)
+  (let ((s (if (string? s) (utf8-uri-string->char-list s) s)))
     (print "s = " s)
     (and s (or (uri s) (relative-ref s)))))
@@ -889 +891 @@
          (len (vector-ref utf8-start-byte-length bi1)))
     (if (<= len 1)
-        (list (list b1) (cdr lst))
+        (list b1 (cdr lst))
         (let loop ((res (list bi1)) (b (cdr lst)) (i (- len 1)))
           (if (zero? i)
               (list ;; converts UTF-8 sequences to pct-encoded char lists
-               ;; the pct-encoded list is built in reverse order
-               (fold-right
-                (lambda (x ax)
-                  (let ((h1 (hex-digit (quotient x 16)))
-                        (h2 (hex-digit (remainder x 16))))
-                       (cons  (list #\% h1 h2) ax)))
-                '() res)
+               (fold
+                (lambda (x ax)
+                  (let ((h1 (hex-digit (quotient x 16)))
+                        (h2 (hex-digit (remainder x 16))))
+                    (cons* #\% h1 h2 ax)))
+                '() res)
                b)
               (let ((bi2 (char->integer (car b))))
@@ -913 +914 @@
 
    
-;; Convert a string to a URI character list 
+;; Converts a  string to a URI character list 
 
 (define (uri-string->char-list s)
+  (let loop ((cs (list)) (lst (string->list s)))
+    (if (null? lst) (reverse cs)
+        (match lst
+               ((#\% h1 h2 . rst)  
+                (and (hexdigit-char? h1) (hexdigit-char? h2)
+                     (loop (cons (list #\% h1 h2) cs) rst)))
+
+               (((and c (? char?)) . rst)  (loop (cons c cs) rst))))))
+
+   
+;; Converts a UTF-8 string to a URI character list 
+
+(define (utf8-uri-string->char-list s)
   (let loop ((cs (list)) (lst (string->list s)))
     (if (null? lst) (reverse cs)
@@ -924 +938 @@
                (else
                 (match-let (((c rst) (utf8-char-car lst)))
-                           (loop (append c cs) rst)) )
+                           (loop (cons c cs) rst)) )
                ))
     ))