Changeset 12828 in project


Ignore:
Timestamp:
12/15/08 23:34:35 (11 years ago)
Author:
sjamaan
Message:

Merge path representation changes from release/4 trunk version of uri-generic

Location:
release/3/uri-generic/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/uri-generic/trunk

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

    r12811 r12828  
    7979  `((,base "" ,base)
    8080    (,base "../../../g" "http://a/g")
    81     (,base "../../../../g" "http://a/g")
     81    (,base "../../../../g" "http://a/g")
     82    (,base "../../../.." "http://a/") ; Is this correct? Or http://a ?
     83    (,base "../../../../" "http://a/")
    8284    (,base "/./g" "http://a/g")
    8385    (,base "/../g" "http://a/g")
     
    108110    ))
    109111
     112(define reverse-extra-cases
     113  `((,base ,base "")
     114    (,base "http://a/b/c/e" "./e")
     115    (,base "http://a/b/e" "../e")
     116    (,base "http://a/" "/") ;; or "../../"
     117    (,base "http://a" "//a") ; No relative representation possible
     118    (,base "http://b" "//b")
     119    (,base "http://b/" "//b/")
     120    (,base "http://b/c" "//b/c")
     121    (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
     122    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")))
     123
    110124(test-group "uri test"
    111125  (for-each (lambda (p)
     
    153167            extra-cases))
    154168
     169(test-group "reverse-extra-test"
     170  (for-each (lambda (p)
     171              (let ((ubase (uri-reference (first p)))
     172                    (urabs  (uri-reference (second p)))
     173                    (uex   (uri-reference (third p))))
     174                (let* ((to    (uri-relative-from urabs ubase)))
     175                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
     176                  )))
     177            reverse-extra-cases))
     178
    155179(define encode/decode-cases
    156180  '(("foo?bar" "foo%3fbar")
     
    173197
    174198(define update-cases
    175   '(("/foo" (path: ("/bar")) "/bar")
     199  '(("/foo" (path: (/ "bar")) "/bar")
     200    ("/foo" (path: ("bar")) "bar")
    176201    ("/foo" (host: "localhost") "//localhost/foo")
    177202    ("http://foo" (query: "a=b&c&d?=%2fe") "http://foo?a=b&c&d?=%2fe")
  • release/3/uri-generic/trunk/uri-generic.scm

    r12811 r12828  
    291291                                               (else (list #f rst)))))
    292292                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    293                                   path: (map uri-char-list->string up) query: (and uq (uri-char-list->string uq))
     293                                  path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
    294294                                  fragment: (and uf (uri-char-list->string uf)))))
    295295         (else #f))))
     296
     297(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))))
    296301
    297302(define (hier-part s)
     
    572577          (or (slash-segment rst)
    573578              (match (segment rst)
    574                      ((ss rst)  (list (cons #\/ ss) rst))
     579                     ((ss rst)  (list ss rst))
    575580                     (else #f))))
    576581         (else  #f)))
     
    584589(define segment-nzc (many1 (uchar "@")))
    585590
    586 (define path-abempty (consume slash-segment))
     591(define (path-abempty s)
     592  (match ((consume slash-segment) s)
     593         ((() rst) (list (list) rst))
     594         ((path rst) (list (cons '/ path) rst))))
    587595
    588596(define (path-abs s)
    589597  (match s
    590          ((#\/)          (list (list (list #\/))  (list)))
     598         ((#\/)          (list (list '/ (list))  (list)))
    591599         ((#\/ . rst)    (match (path-rootless rst)
    592                                 ((() rst)  (list  (list (list #\/))  rst))
    593                                 ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
     600                                ((lst rst) (list (cons '/ lst) rst))
    594601                                (else #f)))
    595602         (else #f)))
     
    597604(define (path-noscheme s)
    598605  (match (segment-nzc s)
    599          ((s1 rst)  (match (path-abempty rst)
    600                            ((ss rst) (list (cons s1 ss) rst))
    601                            (else (list (list s1) rst))))
     606         ((s1 rst)  (match ((consume slash-segment) rst)
     607                           ((ss rst) (list (cons s1 ss) rst))))
    602608         (else #f)))
    603609
    604610(define (path-rootless s)
    605611  (match (segment-nz s)
    606          ((s1 rst)  (match (path-abempty rst)
    607                            ((ss rst) (list (cons s1 ss) rst))
    608                            (else #f)))
     612         ((s1 rst)  (match ((consume slash-segment) rst)
     613                           ((ss rst) (list (cons s1 ss) rst))))
    609614         (else #f)))
    610615
     
    652657                    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
    653658                                         (else (list #f rst)))))
    654                    (make-URI scheme: #f authority: ua path: (map uri-char-list->string up)
     659                   (make-URI scheme: #f authority: ua path: (uri-path-list->path up)
    655660                             query: (and uq (uri-char-list->string uq))
    656661                             fragment: (and uf (uri-char-list->string uf))))))
     
    677682                                              (else (list #f rst)))))
    678683                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    679                                   path: (map uri-char-list->string up) query: (and uq (uri-char-list->string uq))
     684                                  path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
    680685                                  fragment: #f)))
    681686           (error 'absolute-uri "no scheme found in URI string"))))
     
    696701                 (string-append (uri-auth->string authority userinfomap))
    697702                 "")
    698              (string-concatenate path)
     703             (path->string path)
    699704             (if query (string-append "?" query) "")
    700705             (if fragment (string-append  "#" fragment) "")))
     
    711716         (else #f)))
    712717                         
     718(define (path->string path)
     719  (match path
     720         (('/ . segments) (string-join segments "/" 'prefix))
     721         (else (string-join path "/" 'infix))))
     722
    713723; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
    714724
     
    830840             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
    831841              (lambda (ref-path)
    832                 (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
     842                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
    833843                    (let ((x (just-segments ref)))
    834844                      (URI-scheme-set! x (uri-scheme base))
     
    840850                      (URI-path-set! x (merge-paths base x))
    841851                      (just-segments x)))))
    842 
    843852             ((uri-query ref)       (let ((x (udup ref)))
    844853                                      (URI-scheme-set! x (uri-scheme base))
    845854                                      (URI-authority-set! x (uri-auth base))
    846                                       (URI-path-set! x (list "/"))
     855                                      (URI-path-set! x (list ""))
    847856                                      (URI-path-set! x (merge-paths base x))
    848857                                      (just-segments x)))
     
    862871(define (merge0 pb pr)
    863872  (let* ((rpb  (reverse pb))
    864          (pb1  (reverse (if (pair? rpb) (cdr rpb) rpb)))
    865          (pr1  (or (and (pair? pr) (not (string=? ".." (car pr))) (not (string=? "." (car pr)))
    866                         (not (string-prefix? "/" (car pr)))
    867                         (cons (string-append "/" (car pr)) (cdr pr)))
    868                    pr)))
    869     (append pb1 pr1)))
     873         (pb1  (reverse (if (pair? rpb) (cdr rpb) rpb))))
     874    (append pb1 pr)))
    870875
    871876(define (merge-paths b r)
     
    873878        (pb (uri-path b))
    874879        (pr (uri-path r)))
    875     (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
     880    (let ((mp  (if (and ba (null? pb)) pr (merge0 pb pr))))
    876881      mp)))
    877882
     
    888893
    889894(define (remove-dot-segments ps)
    890   (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
    891          (else             (elim-dots ps))))
     895  (match ps
     896         (('/ . rst)   (cons '/ (elim-dots rst)))
     897         (else         (elim-dots ps))))
    892898
    893899(define (elim-dots ps)
     
    895901    (if (null? ps) (reverse lst)
    896902        (match ps
    897                (((or "." "/."))
    898                 (loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
    899                (((or "." "/.") . rst)
    900                 (loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
    901                (((or ".." "/.."))         
    902                 (loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
    903                (((or ".." "/..") . rst)
    904                 (loop rst (if (pair? lst) (cdr lst) lst)))
    905                ((x . rst)       (loop rst (cons x lst)))))))
     903               (("." . rst)
     904                (loop rst (match lst
     905                                 (("" dir . rest) lst)
     906                                 ((file . rest) (cons "" lst))
     907                                 (else (list "")))))
     908               ((".." . rst)
     909                (loop rst (match lst
     910                                 (("" dir . rest) (cons "" rest))
     911                                 ((file . rest) (cons "" rest))
     912                                 (else (list "")))))
     913               (("")
     914                (loop (list) (match lst
     915                                    (("" . rst2) lst)
     916                                    (else (cons "" lst)))))
     917               ((x . rst)
     918                (loop rst (match lst
     919                                 (("" . rst2) (cons x rst2))
     920                                 (else (cons x lst)))))))))
    906921
    907922;;
     
    925940  (cond ((ucdiff? uri-scheme uabs base)      (udup uabs))
    926941        ((ucdiff? uri-authority uabs base)   (let ((x (udup uabs)))
     942                                               (URI-scheme-set! x #f)
     943                                               x))
     944        ;; Special case: no relative representation for http://a/ -> http://a
     945        ;; ....unless that should be a path of ("..")
     946        ((null? (uri-path uabs))             (let ((x (udup uabs)))
    927947                                               (URI-scheme-set! x #f)
    928948                                               x))
     
    959979    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
    960980                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
    961                ((and (list? s1) (list? s2))       (every string=? s1 s2))
     981               ((and (list? s1) (list? s2))       (every equal? s1 s2))
    962982               ((and (string? s1) (string? s2))   (string=? s1 s2))
    963983               (else                              (eq? s1 s2))))))
     
    970990
    971991(define (rel-path-from pabs base)
    972   (cond  ((null? pabs)  (list "/"))
    973          ((null? base)  pabs)
    974          ;; Construct a relative path segment if the paths share a
    975          ;; leading segment other than a leading '/'
    976          (else  (match (list pabs base)
    977                        (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
    978                         (if (string=? sa1 sb1)
    979                             (make-rel-path
    980                              (if (string=? "/" sa1)
    981                                  (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
    982                                  (rel-path-from1 ra1 rb1)))
    983                             pabs))
    984                        (((sa1) (sb1 . rb1))
    985                         (if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
    986                             pabs))))))
     992  (match (list pabs base)
     993         ((pabs ()) pabs)
     994         ((() base) (list))
     995         ;; Construct a relative path segment if the paths share a
     996         ;; leading segment other than a leading '/'
     997         ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
     998          (make-rel-path
     999           (if (string=? ra1 rb1)
     1000               (rel-path-from1 sa1 sb1)
     1001               pabs)))
     1002         (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
    9871003
    9881004(define (make-rel-path x)
    989   (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
     1005  (match x
     1006         ((or ('/ . rst) ("." . rst) (".." rst)) x)
     1007         (else (cons "." x))))
    9901008
    9911009;;  rel-path-from1 strips off trailing names from the supplied paths,
     
    9961014     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
    9971015       (if (null? rp)  (cond ((string=? na nb)  (list))
    998                              ((protect? na)     (list (string-append "./" na)))
    9991016                             (else              (list na)))
    10001017           (append rp (list na))))))
    10011018
    10021019                         
    1003 (define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
    1004              
    1005 
    1006 
    10071020;;  rel-segs-from discards any common leading segments from both paths,
    10081021;;  then invokes dif-segs-from to calculate a relative path from the end
Note: See TracChangeset for help on using the changeset viewer.