source: project/release/4/uri-generic/branches/utf8/tests/run.scm @ 28086

Last change on this file since 28086 was 28086, checked in by Ivan Raikov, 8 years ago

uri-generic: created a branch for experimentation with utf8

File size: 21.2 KB
Line 
1(require-extension srfi-1)
2(load "../uri-generic.scm")
3(import uri-generic)
4(require-extension test)
5
6(test-begin "uri-generic")
7
8(define  path-cases
9  '(;; test cases from Python URI implementation
10    ("foo:xyz" "bar:abc" "bar:abc")
11    ("http://example/x/y/z" "http://example/x/abc" "../abc")
12    ("http://example2/x/y/z" "http://example/x/abc" "//example/x/abc")
13    ("http://ex/x/y/z" "http://ex/x/r" "../r")
14
15    ("http://ex/x/y"  "http://ex/x/q/r" "./q/r")
16    ("http://ex/x/y"  "http://ex/x/q/r#s" "./q/r#s")
17    ("http://ex/x/y"  "http://ex/x/q/r#s/t" "./q/r#s/t")
18    ("http://ex/x/y"  "ftp://ex/x/q/r" "ftp://ex/x/q/r")
19    ("http://ex/x/y"  "http://ex/x/y"   "")
20    ("http://ex/x/y/" "http://ex/x/y/"  "")
21    ("http://ex/x/y/pdq" "http://ex/x/y/pdq" "")
22    ("http://ex/x/y/" "http://ex/x/y/z/" "./z/")
23    ("file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal")
24    ("file:/e/x/y/z" "file:/e/x/abc" "../abc")
25    ("file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc")   
26    ("file:/ex/x/y/z" "file:/ex/x/r" "../r")
27    ("file:/ex/x/y/z" "file:/r" "/r")       
28    ("file:/ex/x/y" "file:/ex/x/q/r" "./q/r")
29    ("file:/ex/x/y" "file:/ex/x/q/r#s" "./q/r#s")
30    ("file:/ex/x/y" "file:/ex/x/q/r#" "./q/r#")
31    ("file:/ex/x/y" "file:/ex/x/q/r#s/t" "./q/r#s/t")
32    ("file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r")
33    ("file:/ex/x/y" "file:/ex/x/y" "")
34    ("file:/ex/x/y/" "file:/ex/x/y/" "")
35    ("file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "")
36    ("file:/ex/x/y/" "file:/ex/x/y/z/" "./z/")
37    ("file:/devel/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
38     "//meetings.example.com/cal#m1")
39    ("file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" "file://meetings.example.com/cal#m1" 
40     "//meetings.example.com/cal#m1")
41    ("file:/some/dir/foo" "file:/some/dir/#blort" "./#blort")
42    ("file:/some/dir/foo" "file:/some/dir/#" "./#")
43    ;; From Graham Klyne Thu 20 Feb 2003 18:08:17 +0000
44    ("http://example/x/y%2Fz"  "http://example/x/abc"     "./abc")
45    ("http://example/x/y/z"    "http://example/x%2Fabc"   "/x%2Fabc")
46    ("http://example/x/y%2Fz"  "http://example/x%2Fabc"   "/x%2Fabc")
47    ("http://example/x%2Fy/z"  "http://example/x%2Fy/abc" "./abc")
48    ;; Ryan Lee
49    ("http://example/x/abc.efg" "http://example/x/" "./")
50    ))
51
52(define base "http://a/b/c/d;p?q")
53
54(define rfc-cases
55  `(;; Examples from section 5.2.4
56    ("/a/b/c/" "./../../g" "/a/g")
57    ("/a/b/c/xyz" "./../../g" "/a/g") ; Input could've had a trailing component
58    ("mid/content=5/" "../6" "mid/6")
59    ("mid/content=5/7" "../6" "mid/6") ; Same here
60
61    ;; "Normal examples", section 5.4.1
62    (,base "g:h" "g:h")
63    (,base "g" "http://a/b/c/g")
64    (,base "./g" "http://a/b/c/g")
65    (,base "g/" "http://a/b/c/g/")
66    (,base "/g" "http://a/g")
67    (,base "//g" "http://g")
68    (,base "?y" "http://a/b/c/?y") 
69    (,base "g?y" "http://a/b/c/g?y")
70    (,base "#s" "http://a/b/c/d;p?q#s") 
71    (,base "g#s" "http://a/b/c/g#s")
72    (,base "g?y#s" "http://a/b/c/g?y#s")
73    (,base ";x" "http://a/b/c/;x")
74    (,base "g;x" "http://a/b/c/g;x")
75    (,base "g;x?y#s" "http://a/b/c/g;x?y#s")
76    (,base "."  "http://a/b/c/")
77    (,base "./" "http://a/b/c/")
78    (,base ".." "http://a/b/")
79    (,base "../" "http://a/b/")
80    (,base "../g" "http://a/b/g")
81    (,base "../.." "http://a/")
82    (,base "../../" "http://a/")
83    (,base "../../g" "http://a/g")
84   
85    ;; "Abnormal examples", section 5.4.2
86    (,base "" ,base)
87    (,base "../../../g" "http://a/g") 
88    (,base "../../../../g" "http://a/g")
89    (,base "../../../.." "http://a/") ; Is this correct? Or http://a ?
90    (,base "../../../../" "http://a/")
91    (,base "/./g" "http://a/g")
92    (,base "/../g" "http://a/g")
93    (,base "g.." "http://a/b/c/g..")
94    (,base "..g" "http://a/b/c/..g")
95   
96    (,base "./../g" "http://a/b/g")
97    (,base "./g/." "http://a/b/c/g/") 
98    (,base "g/./h" "http://a/b/c/g/h") 
99    (,base "g/../h" "http://a/b/c/h")
100    (,base "g;x=1/./y" "http://a/b/c/g;x=1/y") 
101    (,base "g;x=1/../y" "http://a/b/c/y") 
102   
103    (,base "g?y/./x" "http://a/b/c/g?y/./x")
104    (,base "g?y/../x" "http://a/b/c/g?y/../x")
105    (,base "g#s/./x" "http://a/b/c/g#s/./x")
106    (,base "g#s/../x" "http://a/b/c/g#s/../x")
107    ))
108
109(define extra-cases
110  `(("?a=b&c=d" "" "?a=b&c=d")
111    (,base "" "http://a/b/c/d;p?q")
112    ("" ,base "http://a/b/c/d;p?q")
113    (,base "http:" "http:")
114    (,base "..%2f" "http://a/b/c/..%2f")
115    ;; Assume an empty uri-reference is identical to "."
116    ("http://a/b/c/d/" "" "http://a/b/c/d/")
117    ("http://a/b/c/d" "" "http://a/b/c/d")
118    ("http://a/b/c/d/" ".." "http://a/b/c/")
119    ("http://a/b/c/d/" "../e" "http://a/b/c/e")
120    ("http://a/b/c/d/" "../e/" "http://a/b/c/e/")
121    ("http://a/b//c///d///" "../.." "http://a/b//c///d/")
122    ("http://a/b/c/d/" "..//x" "http://a/b/c//x")
123    ("http://a" "b" "http://a/b") ; RFC3986, section 5.2.3, first bullet point
124   
125    ;; Empty segments are segments nonetheless, so should be treated as such
126    ;; [http://bugs.call-cc.org/ticket/396]
127    ("http://a//b//c" "../../../.." "http://a/")
128    ))
129
130(define reverse-extra-cases
131  `((,base ,base "")
132    (,base "http://a/b/c/e" "./e")
133    (,base "http://a/b/c/" "./")  ;; Not sure if the trailing slash belongs here
134    (,base "http://a/b/e" "../e")
135    (,base "http://a/b/c" "../c") ;; Slightly weird: dir in base, file in target
136    (,base "http://a/b/" "../")
137    (,base "http://a/" "/") ;; or "../../"
138    (,base "http://a" "//a") ; No relative representation possible
139    (,base "http://b" "//b")
140    (,base "http://b/" "//b/")
141    (,base "http://b/c" "//b/c")
142    (,base "ftp://a/b/c/d;p?q" "ftp://a/b/c/d;p?q")
143    (,base "ftp://x/y/z;a?b" "ftp://x/y/z;a?b")))
144
145(test-group "uri test"
146  (for-each (lambda (p)
147              (let ((ubase (uri-reference (first p)))
148                    (urabs  (uri-reference (second p)))
149                    (uex   (uri-reference (third p))))
150                (let* ((from (uri-relative-from urabs ubase))
151                       (to    (uri-relative-to from ubase)))
152                  (test (apply sprintf "~S * ~S -> ~S" p) uex from)
153                  (test (apply sprintf "~S * ~S -> ~S" p) urabs to)
154                  (unless (uri-fragment urabs)
155                    (let ((uabs  (absolute-uri (second p))))
156                      (test (sprintf "~S = ~S" uabs urabs) urabs uabs)))
157                  ))
158              (for-each
159               (lambda (s)
160                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
161                       s (uri->string (uri-reference s))))
162               p))
163            path-cases))
164
165(test-group "rfc test"
166  (for-each (lambda (p)
167              (let ((ubase (uri-reference (first p)))
168                    (urabs  (uri-reference (second p)))
169                    (uex   (uri-reference (third p))))
170                (let* ((to    (uri-relative-to urabs ubase)))
171                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
172                  ))
173              (for-each
174               (lambda (s)
175                 (test (sprintf "~S = ~S" s (uri->string (uri-reference s)))
176                       s (uri->string (uri-reference s))))
177               p))
178            rfc-cases))
179
180(test-group "extra-test"
181  (for-each (lambda (p)
182              (let ((ubase (uri-reference (first p)))
183                    (urabs  (uri-reference (second p)))
184                    (uex   (uri-reference (third p))))
185                (let* ((to    (uri-relative-to urabs ubase)))
186                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
187                  )))
188            extra-cases))
189
190(test-group "reverse-extra-test"
191  (for-each (lambda (p)
192              (let ((ubase (uri-reference (first p)))
193                    (urabs  (uri-reference (second p)))
194                    (uex   (uri-reference (third p))))
195                (let* ((to    (uri-relative-from urabs ubase)))
196                  (test (apply sprintf "~S * ~S -> ~S" p) uex to)
197                  )))
198            reverse-extra-cases))
199
200(define encode/decode-cases
201  '(("foo?bar" "foo%3Fbar")
202    ("foo&bar" "foo%26bar")
203    ("foo%20bar" "foo%2520bar")
204    ("foo\x00bar\n" "foo%00bar%0A")))
205
206(test-group "uri-encode-string test"
207  (for-each (lambda (p)
208              (let ((expected (second p))
209                    (encoded (uri-encode-string (first p))))
210                  (test (sprintf "~S -> ~S" (first p) expected) expected encoded)))
211            encode/decode-cases))
212
213(test-group "uri-decode-string test"
214  (for-each (lambda (p)
215              (let ((expected (first p))
216                    (decoded (uri-decode-string (second p))))
217                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
218            encode/decode-cases))
219
220(define normalize-case-cases
221  '(("http://exa%2fmple/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
222    ("http://EXA%2fMPLE/FOO%2fbar" "http://exa%2Fmple/FOO%2Fbar")
223    ("HTTP://example/" "http://example/")
224    ("http://user:PASS@example/FOO%2fbar" "http://user:PASS@example/FOO%2Fbar")
225    ("http://uS%2fer:PA%2fSS@example/FOO%2fbar" "http://uS%2Fer:PA%2FSS@example/FOO%2Fbar")
226    ("HTTP://example/?mooH=MUMBLe%2f" "http://example/?mooH=MUMBLe%2F")
227    ("http://example/#baR%2f" "http://example/#baR%2F")))
228
229(test-group "normalize-case test"
230  (for-each (lambda (p)
231              (let ((case-normalized (uri-normalize-case (uri-reference (first p))))
232                    (expected (second p)))
233                  (test (sprintf "~S -> ~S" (first p) (second p)) expected (uri->string case-normalized (lambda (user pass) (conc user ":" pass))))))
234            normalize-case-cases))
235
236(define internal-representation-cases
237  `(("scheme" ,uri-scheme
238     ;; pct-encoding not allowed in scheme
239     ("http.:" http.)
240     ("http+:" http+)
241     ("http-:" http-)
242     ("HTTP:" HTTP)
243     ("" #f)
244     ("/foo" #f))
245    ("host" ,uri-host
246     ("//:123" ""))
247    ("port" ,uri-port
248     ("//host:123" 123))
249    ("username" ,uri-username
250     ("//foo" #f)
251     ("//@" "")
252     ("//foo@" "foo")
253     ("//foo:bar@" "foo")
254     ("//foo:bar:qux@" "foo")
255     ("//foo%20bar@" "foo%20bar")
256     ("//foo%3Abar:qux@" "foo%3Abar") ;; %3A = ':'
257     ("//foo%2Ebar@" "foo.bar" "//foo.bar@"))
258    ("password ",uri-password
259     ("//foo" #f)
260     ("//@" #f)
261     ("//foo@" #f)
262     ("//foo:bar@" "bar")
263     ("//foo:bar:qux@" "bar:qux")
264     ("//foo:bar%20qux@" "bar%20qux")
265     ("//foo:bar%2Equx@" "bar.qux" "//foo:bar.qux@"))
266    ("path" ,uri-path
267     ("//foo" ())   ; Can path ever be #f?
268     ("foo%20bar" ("foo%20bar"))
269     ("foo%2Fbar" ("foo/bar"))
270     ("foo%2ebar" ("foo.bar") "foo.bar")
271     ("foo/bar%2Fqux" ("foo" "bar/qux"))
272     ("foo/" ("foo" ""))
273     
274     ;; Empty path components preserved?  [http://bugs.call-cc.org/ticket/396]
275     ("//foo//bar" (/ "" "bar"))
276     ("//foo///bar" (/ "" "" "bar"))
277     ("/foo//bar" (/ "foo" "" "bar"))
278     ("/foo///bar" (/ "foo" "" "" "bar"))
279     ("foo//bar" ("foo" "" "bar"))
280     ("foo///bar" ("foo" "" "" "bar"))
281     ("foo//" ("foo" "" ""))
282     ("foo///" ("foo" "" "" ""))
283     
284     ("foo/bar:qux" ("foo" "bar:qux"))
285     ("/foo%2Fbar" (/ "foo/bar"))
286     ("/foo/" (/ "foo" ""))
287     ("/" (/ ""))
288     ("/?foo" (/ ""))
289     ("/#foo" (/ ""))
290     ("/foo:bar" (/ "foo:bar")))
291    ("query ",uri-query
292     ("//" #f)
293     ("/?foo" "foo")
294     ("?foo" "foo")
295     ("?foo?bar" "foo?bar")
296     ("?foo/bar" "foo/bar")
297     ("?foo%3Fbar" "foo%3Fbar")
298     ("?foo%2Ebar" "foo.bar" "?foo.bar"))
299    ("fragment" ,uri-fragment
300     ("?foo" #f)
301     ("#bar" "bar")
302     ("/#bar" "bar")
303     ("?foo#bar" "bar")
304     ("/?foo#bar" "bar")
305     ("#foo?bar" "foo?bar")
306     ("#foo/bar" "foo/bar")
307     ("#foo%3Fbar" "foo%3Fbar")
308     ("#foo%2Ebar" "foo.bar" "#foo.bar"))))
309
310(test-group "internal representations"
311  (for-each (lambda (p)
312              (test-group (car p)
313               (for-each (lambda (u)
314                           (let ((in (first u))
315                                 (internal (second u))
316                                 (out (if (null? (cddr u))
317                                          (first u)
318                                          (third u)))
319                                 (uri (uri-reference (first u))))
320                             (test (sprintf "~S decoded as ~S" in internal)
321                                   internal ((cadr p) uri))
322                             (test (sprintf "~S encoded to ~S" internal out)
323                                   out (uri->string uri
324                                                    (lambda (u p)
325                                                      (if p (conc u ":" p) u))))))
326                         (cddr p))))
327            internal-representation-cases))
328
329;; I wonder if there's a term for this :)
330(define non-relative-non-absolute-uri-references
331  '("http://foo#frag"
332    "http://foo?a=b#frag"
333    "http://foo/bar#frag"
334    "http://foo/bar?a=b#frag"))
335
336(define absolute-uris
337  '("http://foo"
338    "http://foo?a=b"
339    "http://foo/bar"
340    "http://foo/bar?a=b"))
341
342(define relative-refs
343  `(""
344    "bar"
345    "bar?a=b"
346    "bar#frag"
347    "bar?a=b#frag"
348    "/"
349    "/bar"
350    "/bar?a=b"
351    "/bar#frag"
352    "/bar?a=b#frag"
353    "//foo"
354    "//foo?a=b"
355    "//foo#frag"
356    "//foo?a=b#frag"
357    "//foo/bar"
358    "//foo/bar?a=b"
359    "//foo/bar#frag"
360    "//foo/bar?a=b#frag"))
361
362(test-group "absolute/relative distinction"
363  (for-each (lambda (s)
364              (test-assert (sprintf "~S is a relative ref" s)
365                           (relative-ref? (uri-reference s)))
366              (test-assert (sprintf "~S is not an URI" s)
367                           (not (uri? (uri-reference s))))
368              (test-assert (sprintf "~S is not an absolute URI" s)
369                           (not (absolute-uri? (uri-reference s))))
370              (test-error (absolute-uri s)))
371            relative-refs)
372  (for-each (lambda (s)
373              (test-assert (sprintf "~S is not a relative ref" s)
374                           (not (relative-ref? (uri-reference s))))
375              (test-assert (sprintf "~S is an URI" s)
376                           (uri? (uri-reference s)))
377              (test-assert (sprintf "~S is an absolute URI" s)
378                           (absolute-uri? (uri-reference s)))
379              (test (uri-reference s) (absolute-uri s)))
380            absolute-uris)
381  (for-each (lambda (s)
382              (test-assert (sprintf "~S is not a relative ref" s)
383                           (not (relative-ref? (uri-reference s))))
384              (test-assert (sprintf "~S is an URI" s)
385                           (uri? (uri-reference s)))
386              (test-assert (sprintf "~S is not an absolute URI" s)
387                           (not (absolute-uri? (uri-reference s))))
388              ;; Should this give an error in the fragment case?
389              (test-error (absolute-uri s)))
390            non-relative-non-absolute-uri-references))
391
392(define absolute-paths
393  '("/"
394    "/foo"
395    "//foo/"
396    "http://foo/bar"
397    "http://foo/"
398    "http://foo/#qux"
399    "http://foo/?bar=qux"))
400
401(define relative-paths
402  '(""
403    "http://foo"
404    "//foo"
405    "http://foo#bar"
406    "http://foo?bar=qux"))
407
408(test-group "absolute/relative path distinction"
409  (for-each (lambda (s)
410              (test-assert (sprintf "~S is not a relative path" s)
411                           (not (uri-path-relative? (uri-reference s))))
412              (test-assert (sprintf "~S is an absolute path" s)
413                           (uri-path-absolute? (uri-reference s))))
414            absolute-paths)
415  (for-each (lambda (s)
416              (test-assert (sprintf "~S is a relative path" s)
417                           (uri-path-relative? (uri-reference s)))
418              (test-assert (sprintf "~S is not an absolute path" s)
419                           (not (uri-path-absolute? (uri-reference s)))))
420            relative-paths))
421
422;; Uri-references not allowed by the BNF
423(define invalid-refs
424  `(":" ;; This should be encoded to %3a, since an empty scheme is not allowed
425    "1:" ;; scheme starts with ALPHA
426    "//host:abc"  ;; port must be a number
427    " " ;; make sure that any URIs with space < > " are rejected
428    "foo " 
429    " foo " 
430    "<foo" 
431    "foo>" 
432    "<foo>" 
433    "\"foo\"" 
434    "%" ;; % must be followed by two hex digits
435    "abc%xyz" 
436    "http://foo.com/bar?a=b|c" ;; | must be encoded as %7C
437    ))
438
439(test-group "Invalid URI-references"
440  (for-each (lambda (s)
441              (test (sprintf "~S is not a valid uri-reference" s)
442                    #f
443                    (uri-reference s)))
444            invalid-refs))
445
446(test-group "miscellaneous"
447  ;; Special case, see section 4.2
448  (test "./foo:bar" (uri->string (update-uri (uri-reference "") path: '("foo:bar")))))
449
450
451;; Examples URIs from RFC 4151 The 'tag' URI scheme
452;;
453;; Tag URIs always contain a colon, so uri->string will prefix their
454;; paths by ./ as per section 4.2 in RFC 3986
455(define rfc4151-refs
456  `(
457    ("tag:timothy@hpl.hp.com,2001:web/externalHome"
458     "tag:./timothy@hpl.hp.com,2001:web/externalHome")
459    ("tag:sandro@w3.org,2004-05:Sandro"
460     "tag:./sandro@w3.org,2004-05:Sandro"
461     )
462    ("tag:my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
463     "tag:./my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19"
464     )
465    ("tag:blogger.com,1999:blog-555" 
466     "tag:./blogger.com,1999:blog-555"
467     )
468    ("tag:yaml.org,2002:int" 
469     "tag:./yaml.org,2002:int"
470     )
471    ))
472
473(test-group "Example URIs from RFC 4151"
474  (for-each (lambda (s) 
475              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
476            rfc4151-refs))
477
478;; Examples URIs from RFC 4452 The 'info' URI scheme
479;;
480(define rfc4452-refs
481  `(
482    ("info:ddc/22/eng//004.678"
483     "info:ddc/22/eng//004.678")
484    ("info:lccn/2002022641"
485     "info:lccn/2002022641"
486     )
487    ("info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V"
488     "info:sici/0363-0277(19950315)120:5%3C%3E1.0.TX;2-V")
489    ("info:bibcode/2003Icar..163..263Z"
490     "info:bibcode/2003Icar..163..263Z")
491    ))
492
493(test-group "Example URIs from RFC 4452"
494  (for-each (lambda (s) 
495              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
496            rfc4452-refs))
497
498;; Examples URIs from RFC 5724 URI scheme for global system for mobile communication
499;;
500(define rfc5724-refs
501  `(
502    ("sms:+15105550101"
503     "sms:+15105550101")
504    ("sms:+15105550101,+15105550102"
505     "sms:+15105550101,+15105550102")
506    ("sms:+15105550101?body=hello%20there"
507     "sms:+15105550101?body=hello%20there"
508     )
509    ))
510
511(test-group "Example URIs from RFC 4452"
512  (for-each (lambda (s) 
513              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
514            rfc5724-refs))
515
516
517;; Examples URIs from RFC 4501 DNS URIs
518;;
519(define rfc4501-refs
520  `(
521    ("dns:www.example.org.?clAsS=IN;tYpE=A"
522     "dns:www.example.org.?clAsS=IN;tYpE=A")
523    ("dns://192.168.1.1/ftp.example.org?type=A"
524     "dns://192.168.1.1/ftp.example.org?type=A")
525    ("dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT"
526     "dns:world%20wide%20web.example%5c.domain.org?TYPE=TXT")
527    ("dns://fw.example.org/*.%20%00.example?type=TXT"
528     "dns://fw.example.org/*.%20%00.example?type=TXT")
529    ))
530
531(test-group "Example URIs from RFC 4501"
532  (for-each (lambda (s) 
533              (test (car s) (cadr s) (uri->string (uri-reference (car s)))))
534            rfc4501-refs))
535
536;; Examples URIs from RFC 5122
537;;
538(define rfc5122-refs
539  `(("xmpp:nasty!%23$%25()*+,-.;=%3F%5B%5C%5D%5E_%60%7B%7C%7D~node@example.com"
540     ("nasty!#$%()*+,-.;=?[\\]^_`{|}~node@example.com")) ;; the decoded path component
541    ("xmpp:node@example.com/repulsive%20!%23%22$%25&'()*+,-.%2F:;%3C=%3E%3F%40%5B%5C%5D%5E_%60%7B%7C%7D~resource"
542     ("node@example.com" "repulsive !#\"$%&'()*+,-./:;<=>?@[\\]^_`{|}~resource")) ;; the decoded path component
543    ))
544   
545
546(test-group "Example URIs from RFC 5122"
547  (for-each (lambda (s) 
548              (test (car s) (cadr s) (map uri-decode-string (uri-path (uri-reference (car s))))))
549            rfc5122-refs))
550
551
552(define  utf8-cases
553  '(;; URI representation of IRIs test cases
554    ("http://example.com/삌계탕"
555     "http://example.com/test")
556    ))
557
558(test-group "URI representation of IRIs"
559  (for-each (lambda (s) 
560              (test (cadr s) (uri->string (iri/uri-map (car s)))))
561            utf8-cases))
562
563(define make-cases
564  `(("http://example.com:123/foo/bar?a=b;c=d#location"
565     scheme: http host: "example.com" port: 123 path: (/ "foo" "bar")
566     query: "a=b;c=d" fragment: "location")
567    ("//example.com:123/foo/bar?a=b;c=d#location"
568     host: "example.com" port: 123 path: (/ "foo" "bar")
569     query: "a=b;c=d" fragment: "location")
570    ("/foo/bar?a=b;c=d#location"
571     port: 123 path: (/ "foo" "bar") query: "a=b;c=d" fragment: "location")
572    ("foo/bar?a=b;c=d#location"
573     path: ("foo" "bar") query: "a=b;c=d" fragment: "location")
574    ("/?a=b;c=d#location"
575     path: (/ "") query: "a=b;c=d" fragment: "location")
576    ("?a=b;c=d#location"
577     query: "a=b;c=d" fragment: "location")
578    ("#location"
579     fragment: "location")
580    ("//example.com?a=b;c=d"
581     host: "example.com" query: "a=b;c=d")
582    ("//example.com#location"
583     host: "example.com" fragment: "location")
584    ("/"
585     path: (/ ""))
586    ("/"
587     path: (/))                         ; Not sure if this works by accident
588    (""
589     path: ())
590    ("")))
591
592(test-group "manual constructor"
593  (for-each (lambda (u)
594              (let* ((input (cdr u))
595                     (oexp (first u))
596                     (oact (apply make-uri input)))
597                (test (sprintf "~S -> ~S" input oexp)
598                      oexp (uri->string oact))))
599            make-cases))
600
601(test-end "uri-generic")
602
603(unless (zero? (test-failure-count)) (exit 1))
Note: See TracBrowser for help on using the repository browser.