1 | (require-extension srfi-1) |
---|
2 | (require-extension uri-generic) |
---|
3 | (require-extension test) |
---|
4 | |
---|
5 | ;; test cases from Python URI implementation |
---|
6 | |
---|
7 | (define path-cases |
---|
8 | '(("foo:xyz" "bar:abc" "bar:abc") |
---|
9 | ("http://example/x/y/z" "http://example/x/abc" "../abc") |
---|
10 | ("http://example2/x/y/z" "http://example/x/abc" "//example/x/abc") |
---|
11 | ("http://ex/x/y/z" "http://ex/x/r" "../r") |
---|
12 | |
---|
13 | ("http://ex/x/y" "http://ex/x/q/r" "./q/r") |
---|
14 | ("http://ex/x/y" "http://ex/x/q/r#s" "./q/r#s") |
---|
15 | ("http://ex/x/y" "http://ex/x/q/r#s/t" "./q/r#s/t") |
---|
16 | ("http://ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r") |
---|
17 | ("http://ex/x/y" "http://ex/x/y" "") |
---|
18 | ("http://ex/x/y/" "http://ex/x/y/" "") |
---|
19 | ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "") |
---|
20 | ("http://ex/x/y/" "http://ex/x/y/z/" "./z/") |
---|
21 | ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal") |
---|
22 | ("file:/e/x/y/z" "file:/e/x/abc" "../abc") |
---|
23 | ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc") |
---|
24 | ("file:/ex/x/y/z" "file:/ex/x/r" "../r") |
---|
25 | ("file:/ex/x/y/z" "file:/r" "/r") |
---|
26 | ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r") |
---|
27 | ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s") |
---|
28 | ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#") |
---|
29 | ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t") |
---|
30 | ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r") |
---|
31 | ("file:/ex/x/y" "file:/ex/x/y" "") |
---|
32 | ("file:/ex/x/y/" "file:/ex/x/y/" "") |
---|
33 | ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "") |
---|
34 | ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/") |
---|
35 | ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" |
---|
36 | "//meetings.example.com/cal#m1") |
---|
37 | ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" |
---|
38 | "//meetings.example.com/cal#m1") |
---|
39 | ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort") |
---|
40 | ("file:/some/dir/foo" "file:/some/dir/#" "./#") |
---|
41 | ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000 |
---|
42 | ("http://example/x/y%2Fz" "http://example/x/abc" "./abc") |
---|
43 | ("http://example/x/y/z" "http://example/x%2Fabc" "/x%2Fabc") |
---|
44 | ("http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc") |
---|
45 | ("http://example/x%2Fy/z" "http://example/x%2Fy/abc" "./abc") |
---|
46 | ;; Ryan Lee |
---|
47 | ("http://example/x/abc.efg" "http://example/x/" "./") |
---|
48 | )) |
---|
49 | |
---|
50 | (define base "http://a/b/c/d;p?q") |
---|
51 | |
---|
52 | (define rfc-cases |
---|
53 | `((,base "g:h" "g:h") |
---|
54 | (,base "g" "http://a/b/c/g") |
---|
55 | (,base "./g" "http://a/b/c/g") |
---|
56 | (,base "g/" "http://a/b/c/g/") |
---|
57 | (,base "/g" "http://a/g") |
---|
58 | (,base "//g" "http://g") |
---|
59 | (,base "?y" "http://a/b/c/?y") |
---|
60 | (,base "g?y" "http://a/b/c/g?y") |
---|
61 | (,base "#s" "http://a/b/c/d;p?q#s") |
---|
62 | (,base "g#s" "http://a/b/c/g#s") |
---|
63 | (,base "g?y#s" "http://a/b/c/g?y#s") |
---|
64 | (,base ";x" "http://a/b/c/;x") |
---|
65 | (,base "g;x" "http://a/b/c/g;x") |
---|
66 | (,base "g;x?y#s" "http://a/b/c/g;x?y#s") |
---|
67 | (,base "." "http://a/b/c/") |
---|
68 | (,base "./" "http://a/b/c/") |
---|
69 | (,base ".." "http://a/b/") |
---|
70 | (,base "../" "http://a/b/") |
---|
71 | (,base "../g" "http://a/b/g") |
---|
72 | (,base "../.." "http://a/") |
---|
73 | (,base "../../" "http://a/") |
---|
74 | (,base "../../g" "http://a/g") |
---|
75 | )) |
---|
76 | |
---|
77 | (define extra-cases |
---|
78 | `((,base "" ,base) |
---|
79 | (,base "../../../g" "http://a/g") |
---|
80 | (,base "../../../../g" "http://a/g") |
---|
81 | (,base "/./g" "http://a/g") |
---|
82 | (,base "/../g" "http://a/g") |
---|
83 | (,base "g.." "http://a/b/c/g..") |
---|
84 | (,base "..g" "http://a/b/c/..g") |
---|
85 | |
---|
86 | (,base "./../g" "http://a/b/g") |
---|
87 | (,base "./g/." "http://a/b/c/g/") |
---|
88 | (,base "g/./h" "http://a/b/c/g/h") |
---|
89 | (,base "g/../h" "http://a/b/c/h") |
---|
90 | (,base "g;x=1/./y" "http://a/b/c/g;x=1/y") |
---|
91 | (,base "g;x=1/../y" "http://a/b/c/y") |
---|
92 | |
---|
93 | (,base "g?y/./x" "http://a/b/c/g?y/./x") |
---|
94 | (,base "g?y/../x" "http://a/b/c/g?y/../x") |
---|
95 | (,base "g#s/./x" "http://a/b/c/g#s/./x") |
---|
96 | (,base "g#s/../x" "http://a/b/c/g#s/../x") |
---|
97 | )) |
---|
98 | |
---|
99 | (test-group "uri test" |
---|
100 | (for-each (lambda (p) |
---|
101 | (let ((ubase (uri-reference (first p))) |
---|
102 | (urabs (uri-reference (second p))) |
---|
103 | (uabs (absolute-uri (second p))) |
---|
104 | (uex (uri-reference (third p)))) |
---|
105 | (let* ((from (uri-relative-from urabs ubase)) |
---|
106 | (to (uri-relative-to from ubase))) |
---|
107 | (test (apply sprintf "~S * ~S -> ~S" p) uex from) |
---|
108 | (test (apply sprintf "~S * ~S -> ~S" p) urabs to) |
---|
109 | (if (not (uri-fragment urabs)) |
---|
110 | (test (sprintf "~S = ~S" uabs urabs) urabs uabs)) |
---|
111 | )) |
---|
112 | (for-each |
---|
113 | (lambda (s) |
---|
114 | (test (sprintf "~S = ~S" s (uri->string (uri-reference s))) |
---|
115 | s (uri->string (uri-reference s)))) |
---|
116 | p)) |
---|
117 | path-cases)) |
---|
118 | |
---|
119 | (test-group "rfc test" |
---|
120 | (for-each (lambda (p) |
---|
121 | (let ((ubase (uri-reference (first p))) |
---|
122 | (urabs (uri-reference (second p))) |
---|
123 | (uex (uri-reference (third p)))) |
---|
124 | (let* ((to (uri-relative-to urabs ubase))) |
---|
125 | (test (apply sprintf "~S * ~S -> ~S" p) uex to) |
---|
126 | ))) |
---|
127 | rfc-cases)) |
---|
128 | |
---|
129 | (test-group "extra-test" |
---|
130 | (for-each (lambda (p) |
---|
131 | (let ((ubase (uri-reference (first p))) |
---|
132 | (urabs (uri-reference (second p))) |
---|
133 | (uex (uri-reference (third p)))) |
---|
134 | (let* ((to (uri-relative-to urabs ubase))) |
---|
135 | (test (apply sprintf "~S * ~S -> ~S" p) uex to) |
---|
136 | ))) |
---|
137 | extra-cases)) |
---|