Changeset 12827 in project


Ignore:
Timestamp:
12/15/08 22:39:27 (13 years ago)
Author:
sjamaan
Message:

Change representation of paths to be just the segment contents, not the segments including slashes

Location:
release/4/uri-generic/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-generic/trunk/tests/run.scm

    r12810 r12827  
    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/4/uri-generic/trunk/uri-generic.scm

    r12810 r12827  
    279279                                               (else (list #f rst)))))
    280280                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    281                                   path: (map uri-char-list->string up) query: (and uq (uri-char-list->string uq))
     281                                  path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
    282282                                  fragment: (and uf (uri-char-list->string uf)))))
    283283         (else #f))))
     284
     285(define (uri-path-list->path pcl)
     286  (match pcl
     287         (('/ . rst) (cons '/ (map uri-char-list->string rst)))
     288         (else (map uri-char-list->string pcl))))
    284289
    285290(define (hier-part s)
     
    560565          (or (slash-segment rst)
    561566              (match (segment rst)
    562                      ((ss rst)  (list (cons #\/ ss) rst))
     567                     ((ss rst)  (list ss rst))
    563568                     (else #f))))
    564569         (else  #f)))
     
    572577(define segment-nzc (many1 (uchar "@")))
    573578
    574 (define path-abempty (consume slash-segment))
     579(define (path-abempty s)
     580  (match ((consume slash-segment) s)
     581         ((() rst) (list (list) rst))
     582         ((path rst) (list (cons '/ path) rst))))
    575583
    576584(define (path-abs s)
    577585  (match s
    578          ((#\/)          (list (list (list #\/))  (list)))
     586         ((#\/)          (list (list '/ (list))  (list)))
    579587         ((#\/ . rst)    (match (path-rootless rst)
    580                                 ((() rst)  (list  (list (list #\/))  rst))
    581                                 ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
     588                                ((lst rst) (list (cons '/ lst) rst))
    582589                                (else #f)))
    583590         (else #f)))
     
    585592(define (path-noscheme s)
    586593  (match (segment-nzc s)
    587          ((s1 rst)  (match (path-abempty rst)
    588                            ((ss rst) (list (cons s1 ss) rst))
    589                            (else (list (list s1) rst))))
     594         ((s1 rst)  (match ((consume slash-segment) rst)
     595                           ((ss rst) (list (cons s1 ss) rst))))
    590596         (else #f)))
    591597
    592598(define (path-rootless s)
    593599  (match (segment-nz s)
    594          ((s1 rst)  (match (path-abempty rst)
    595                            ((ss rst) (list (cons s1 ss) rst))
    596                            (else #f)))
     600         ((s1 rst)  (match ((consume slash-segment) rst)
     601                           ((ss rst) (list (cons s1 ss) rst))))
    597602         (else #f)))
    598603
     
    640645                    ((uf rst)     (match rst ((#\# . rst) (fragment rst))
    641646                                         (else (list #f rst)))))
    642                    (make-URI scheme: #f authority: ua path: (map uri-char-list->string up)
     647                   (make-URI scheme: #f authority: ua path: (uri-path-list->path up)
    643648                             query: (and uq (uri-char-list->string uq))
    644649                             fragment: (and uf (uri-char-list->string uf))))))
     
    665670                                              (else (list #f rst)))))
    666671                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    667                                   path: (map uri-char-list->string up) query: (and uq (uri-char-list->string uq))
     672                                  path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq))
    668673                                  fragment: #f)))
    669674           (error 'absolute-uri "no scheme found in URI string"))))
     
    684689                 (string-append (uri-auth->string authority userinfomap))
    685690                 "")
    686              (string-concatenate path)
     691             (path->string path)
    687692             (if query (string-append "?" query) "")
    688693             (if fragment (string-append  "#" fragment) "")))
     
    699704         (else #f)))
    700705                         
     706(define (path->string path)
     707  (match path
     708         (('/ . segments) (string-join segments "/" 'prefix))
     709         (else (string-join path "/" 'infix))))
     710
    701711; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
    702712
     
    818828             (((lambda (p) (and (not (null? p)) p))  (uri-path ref)) =>
    819829              (lambda (ref-path)
    820                 (if (and (pair? ref-path) (string-prefix? "/" (car ref-path)))
     830                (if (and (pair? ref-path) (eq? '/ (car ref-path)))
    821831                    (update-URI ref
    822832                                scheme: (uri-scheme base)
     
    830840                                          scheme: (uri-scheme base)
    831841                                          authority: (uri-auth base)
    832                                           path: (merge-paths base (list "/"))))
     842                                          path: (merge-paths base (list ""))))
    833843             (else (update-URI ref
    834844                               path: (URI-path base)
     
    842852(define (merge0 pb pr)
    843853  (let* ((rpb  (reverse pb))
    844          (pb1  (reverse (if (pair? rpb) (cdr rpb) rpb)))
    845          (pr1  (or (and (pair? pr) (not (string=? ".." (car pr))) (not (string=? "." (car pr)))
    846                         (not (string-prefix? "/" (car pr)))
    847                         (cons (string-append "/" (car pr)) (cdr pr)))
    848                    pr)))
    849     (append pb1 pr1)))
     854         (pb1  (reverse (if (pair? rpb) (cdr rpb) rpb))))
     855    (append pb1 pr)))
    850856
    851857(define (merge-paths b pr)  ; pr is a path, *not* a URI object
    852858  (let ((ba (uri-authority b))
    853859        (pb (uri-path b)))
    854     (let ((mp  (if (and ba (null? pb)) (cons "/" pr) (merge0 pb pr))))
     860    (let ((mp  (if (and ba (null? pb)) pr (merge0 pb pr))))
    855861      (remove-dot-segments mp))))
    856862
     
    865871
    866872(define (remove-dot-segments ps)
    867   (match ps (("/" . rst)   (cons "/" (elim-dots rst)))
    868          (else             (elim-dots ps))))
     873  (match ps
     874         (('/ . rst)   (cons '/ (elim-dots rst)))
     875         (else         (elim-dots ps))))
    869876
    870877(define (elim-dots ps)
     
    872879    (if (null? ps) (reverse lst)
    873880        (match ps
    874                (((or "." "/."))
    875                 (loop (list) (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) (cons "/" lst))))
    876                (((or "." "/.") . rst)
    877                 (loop rst (if (and (pair? lst) (string=? "/" (car lst))) (cdr lst) lst)))
    878                (((or ".." "/.."))         
    879                 (loop (list) (if (pair? lst) (cons "/" (cdr lst)) lst)))
    880                (((or ".." "/..") . rst)
    881                 (loop rst (if (pair? lst) (cdr lst) lst)))
    882                ((x . rst)       (loop rst (cons x lst)))))))
     881               (("." . rst)
     882                (loop rst (match lst
     883                                 (("" dir . rest) lst)
     884                                 ((file . rest) (cons "" lst))
     885                                 (else (list "")))))
     886               ((".." . rst)
     887                (loop rst (match lst
     888                                 (("" dir . rest) (cons "" rest))
     889                                 ((file . rest) (cons "" rest))
     890                                 (else (list "")))))
     891               (("")
     892                (loop (list) (match lst
     893                                    (("" . rst2) lst)
     894                                    (else (cons "" lst)))))
     895               ((x . rst)
     896                (loop rst (match lst
     897                                 (("" . rst2) (cons x rst2))
     898                                 (else (cons x lst)))))))))
    883899
    884900;;
     
    902918  (cond ((ucdiff? uri-scheme uabs base)      (update-URI uabs))
    903919        ((ucdiff? uri-authority uabs base)   (update-URI uabs scheme: #f))
     920        ;; Special case: no relative representation for http://a/ -> http://a
     921        ;; ....unless that should be a path of ("..")
     922        ((null? (uri-path uabs))             (update-URI uabs scheme: #f))
    904923        ((ucdiff? uri-path uabs base)
    905924         (update-URI uabs
     
    926945    (not (cond ((and (URIAuth? s1) (URIAuth? s2))
    927946                (not (or (ucdiff? uri-username u1 u2) (ucdiff? uri-host u1 u2) (ucdiff? uri-port u1 u2))))
    928                ((and (list? s1) (list? s2))       (every string=? s1 s2))
     947               ((and (list? s1) (list? s2))       (every equal? s1 s2))
    929948               ((and (string? s1) (string? s2))   (string=? s1 s2))
    930949               (else                              (eq? s1 s2))))))
     
    937956
    938957(define (rel-path-from pabs base)
    939   (cond  ((null? pabs)  (list "/"))
    940          ((null? base)  pabs)
    941          ;; Construct a relative path segment if the paths share a
    942          ;; leading segment other than a leading '/'
    943          (else  (match (list pabs base)
    944                        (((sa1 . (and ra1 (sa2 . ra2))) (sb1 . (and rb1 (sb2 . rb2))))
    945                         (if (string=? sa1 sb1)
    946                             (make-rel-path
    947                              (if (string=? "/" sa1)
    948                                  (if (string=? sa2 sb2) (rel-path-from1 ra2 rb2) pabs)
    949                                  (rel-path-from1 ra1 rb1)))
    950                             pabs))
    951                        (((sa1) (sb1 . rb1))
    952                         (if (string=? sa1 sb1)  (rel-segs-from (list) rb1)
    953                             pabs))))))
     958  (match (list pabs base)
     959         ((pabs ()) pabs)
     960         ((() base) (list))
     961         ;; Construct a relative path segment if the paths share a
     962         ;; leading segment other than a leading '/'
     963         ((('/ . (and sa1 (ra1 . ra2))) ('/ . (and sb1 (rb1 . rb2))))
     964          (make-rel-path
     965           (if (string=? ra1 rb1)
     966               (rel-path-from1 sa1 sb1)
     967               pabs)))
     968         (else (error 'rel-path-from "Both URI paths must be absolute" pabs base))))
    954969
    955970(define (make-rel-path x)
    956   (if (pair? x) (if (string-prefix? "/" (car x)) (cons "." x) x) x))
     971  (match x
     972         ((or ('/ . rst) ("." . rst) (".." rst)) x)
     973         (else (cons "." x))))
    957974
    958975;;  rel-path-from1 strips off trailing names from the supplied paths,
     
    963980     (let ((rp (rel-segs-from (reverse sa) (reverse sb))))
    964981       (if (null? rp)  (cond ((string=? na nb)  (list))
    965                              ((protect? na)     (list (string-append "./" na)))
    966982                             (else              (list na)))
    967983           (append rp (list na))))))
    968984
    969985                         
    970 (define (protect? sa) (or (string-null? sa) (string-contains sa ":")))
    971              
    972 
    973 
    974986;;  rel-segs-from discards any common leading segments from both paths,
    975987;;  then invokes dif-segs-from to calculate a relative path from the end
Note: See TracChangeset for help on using the changeset viewer.