Changeset 12828 in project
- Timestamp:
- 12/15/08 23:34:35 (11 years ago)
- Location:
- release/3/uri-generic/trunk
- Files:
-
- 3 edited
-
. (modified) (1 prop)
-
tests/run.scm (modified) (4 diffs)
-
uri-generic.scm (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/3/uri-generic/trunk
- Property svn:mergeinfo changed
/release/4/uri-generic/trunk merged: 12827
- Property svn:mergeinfo changed
-
release/3/uri-generic/trunk/tests/run.scm
r12811 r12828 79 79 `((,base "" ,base) 80 80 (,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/") 82 84 (,base "/./g" "http://a/g") 83 85 (,base "/../g" "http://a/g") … … 108 110 )) 109 111 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 110 124 (test-group "uri test" 111 125 (for-each (lambda (p) … … 153 167 extra-cases)) 154 168 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 155 179 (define encode/decode-cases 156 180 '(("foo?bar" "foo%3fbar") … … 173 197 174 198 (define update-cases 175 '(("/foo" (path: ("/bar")) "/bar") 199 '(("/foo" (path: (/ "bar")) "/bar") 200 ("/foo" (path: ("bar")) "bar") 176 201 ("/foo" (host: "localhost") "//localhost/foo") 177 202 ("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 291 291 (else (list #f rst))))) 292 292 (make-URI scheme: (string->symbol (list->string us)) authority: ua 293 path: ( map uri-char-list->stringup) query: (and uq (uri-char-list->string uq))293 path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq)) 294 294 fragment: (and uf (uri-char-list->string uf))))) 295 295 (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)))) 296 301 297 302 (define (hier-part s) … … 572 577 (or (slash-segment rst) 573 578 (match (segment rst) 574 ((ss rst) (list (cons #\/ ss)rst))579 ((ss rst) (list ss rst)) 575 580 (else #f)))) 576 581 (else #f))) … … 584 589 (define segment-nzc (many1 (uchar "@"))) 585 590 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)))) 587 595 588 596 (define (path-abs s) 589 597 (match s 590 ((#\/) (list (list (list #\/)) (list)))598 ((#\/) (list (list '/ (list)) (list))) 591 599 ((#\/ . 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)) 594 601 (else #f))) 595 602 (else #f))) … … 597 604 (define (path-noscheme s) 598 605 (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)))) 602 608 (else #f))) 603 609 604 610 (define (path-rootless s) 605 611 (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)))) 609 614 (else #f))) 610 615 … … 652 657 ((uf rst) (match rst ((#\# . rst) (fragment rst)) 653 658 (else (list #f rst))))) 654 (make-URI scheme: #f authority: ua path: ( map uri-char-list->stringup)659 (make-URI scheme: #f authority: ua path: (uri-path-list->path up) 655 660 query: (and uq (uri-char-list->string uq)) 656 661 fragment: (and uf (uri-char-list->string uf)))))) … … 677 682 (else (list #f rst))))) 678 683 (make-URI scheme: (string->symbol (list->string us)) authority: ua 679 path: ( map uri-char-list->stringup) query: (and uq (uri-char-list->string uq))684 path: (uri-path-list->path up) query: (and uq (uri-char-list->string uq)) 680 685 fragment: #f))) 681 686 (error 'absolute-uri "no scheme found in URI string")))) … … 696 701 (string-append (uri-auth->string authority userinfomap)) 697 702 "") 698 ( string-concatenatepath)703 (path->string path) 699 704 (if query (string-append "?" query) "") 700 705 (if fragment (string-append "#" fragment) ""))) … … 711 716 (else #f))) 712 717 718 (define (path->string path) 719 (match path 720 (('/ . segments) (string-join segments "/" 'prefix)) 721 (else (string-join path "/" 'infix)))) 722 713 723 ; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)). 714 724 … … 830 840 (((lambda (p) (and (not (null? p)) p)) (uri-path ref)) => 831 841 (lambda (ref-path) 832 (if (and (pair? ref-path) ( string-prefix? "/"(car ref-path)))842 (if (and (pair? ref-path) (eq? '/ (car ref-path))) 833 843 (let ((x (just-segments ref))) 834 844 (URI-scheme-set! x (uri-scheme base)) … … 840 850 (URI-path-set! x (merge-paths base x)) 841 851 (just-segments x))))) 842 843 852 ((uri-query ref) (let ((x (udup ref))) 844 853 (URI-scheme-set! x (uri-scheme base)) 845 854 (URI-authority-set! x (uri-auth base)) 846 (URI-path-set! x (list " /"))855 (URI-path-set! x (list "")) 847 856 (URI-path-set! x (merge-paths base x)) 848 857 (just-segments x))) … … 862 871 (define (merge0 pb pr) 863 872 (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))) 870 875 871 876 (define (merge-paths b r) … … 873 878 (pb (uri-path b)) 874 879 (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)))) 876 881 mp))) 877 882 … … 888 893 889 894 (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)))) 892 898 893 899 (define (elim-dots ps) … … 895 901 (if (null? ps) (reverse lst) 896 902 (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))))))))) 906 921 907 922 ;; … … 925 940 (cond ((ucdiff? uri-scheme uabs base) (udup uabs)) 926 941 ((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))) 927 947 (URI-scheme-set! x #f) 928 948 x)) … … 959 979 (not (cond ((and (URIAuth? s1) (URIAuth? s2)) 960 980 (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)) 962 982 ((and (string? s1) (string? s2)) (string=? s1 s2)) 963 983 (else (eq? s1 s2)))))) … … 970 990 971 991 (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)))) 987 1003 988 1004 (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)))) 990 1008 991 1009 ;; rel-path-from1 strips off trailing names from the supplied paths, … … 996 1014 (let ((rp (rel-segs-from (reverse sa) (reverse sb)))) 997 1015 (if (null? rp) (cond ((string=? na nb) (list)) 998 ((protect? na) (list (string-append "./" na)))999 1016 (else (list na))) 1000 1017 (append rp (list na)))))) 1001 1018 1002 1019 1003 (define (protect? sa) (or (string-null? sa) (string-contains sa ":")))1004 1005 1006 1007 1020 ;; rel-segs-from discards any common leading segments from both paths, 1008 1021 ;; then invokes dif-segs-from to calculate a relative path from the end
Note: See TracChangeset
for help on using the changeset viewer.
