diff options
Diffstat (limited to 't')
-rw-r--r-- | t/abs.t | 173 | ||||
-rw-r--r-- | t/clone.t | 21 | ||||
-rw-r--r-- | t/cwd.t | 15 | ||||
-rw-r--r-- | t/data.t | 111 | ||||
-rw-r--r-- | t/distmanifest.t | 11 | ||||
-rw-r--r-- | t/escape-char.t | 29 | ||||
-rw-r--r-- | t/escape.t | 37 | ||||
-rw-r--r-- | t/file.t | 65 | ||||
-rw-r--r-- | t/ftp.t | 53 | ||||
-rw-r--r-- | t/generic.t | 219 | ||||
-rw-r--r-- | t/gopher.t | 46 | ||||
-rw-r--r-- | t/heuristic.t | 138 | ||||
-rw-r--r-- | t/http.t | 66 | ||||
-rw-r--r-- | t/idna.t | 14 | ||||
-rw-r--r-- | t/iri.t | 76 | ||||
-rw-r--r-- | t/ldap.t | 119 | ||||
-rw-r--r-- | t/mailto.t | 48 | ||||
-rw-r--r-- | t/mix.t | 80 | ||||
-rw-r--r-- | t/mms.t | 38 | ||||
-rw-r--r-- | t/news.t | 51 | ||||
-rw-r--r-- | t/num_eq.t | 16 | ||||
-rw-r--r-- | t/old-absconf.t | 38 | ||||
-rw-r--r-- | t/old-base.t | 978 | ||||
-rw-r--r-- | t/old-file.t | 81 | ||||
-rw-r--r-- | t/old-relbase.t | 37 | ||||
-rwxr-xr-x | t/path-segments.t | 33 | ||||
-rw-r--r-- | t/pop.t | 50 | ||||
-rw-r--r-- | t/punycode.t | 56 | ||||
-rw-r--r-- | t/query-param.t | 71 | ||||
-rw-r--r-- | t/query.t | 81 | ||||
-rw-r--r-- | t/rel.t | 21 | ||||
-rw-r--r-- | t/rfc2732.t | 59 | ||||
-rw-r--r-- | t/roy-test.t | 44 | ||||
-rw-r--r-- | t/roytest1.html | 194 | ||||
-rw-r--r-- | t/roytest2.html | 100 | ||||
-rw-r--r-- | t/roytest3.html | 89 | ||||
-rw-r--r-- | t/roytest4.html | 98 | ||||
-rw-r--r-- | t/roytest5.html | 92 | ||||
-rw-r--r-- | t/rsync.t | 23 | ||||
-rw-r--r-- | t/rtsp.t | 43 | ||||
-rw-r--r-- | t/sip.t | 69 | ||||
-rw-r--r-- | t/sort-hash-query-form.t | 22 | ||||
-rw-r--r-- | t/split.t | 59 | ||||
-rw-r--r-- | t/storable-test.pl | 27 | ||||
-rw-r--r-- | t/storable.t | 16 | ||||
-rw-r--r-- | t/urn-isbn.t | 62 | ||||
-rw-r--r-- | t/urn-oid.t | 24 | ||||
-rw-r--r-- | t/utf8.t | 20 |
48 files changed, 3913 insertions, 0 deletions
@@ -0,0 +1,173 @@ +use strict; +use warnings; + +print "1..45\n"; + +# This test the resolution of abs path for all examples given +# in the "Uniform Resource Identifiers (URI): Generic Syntax" document. + +use URI; +my $base = "http://a/b/c/d;p?q"; +my $testno = 1; +my @rel_fail; + +while (<DATA>) { + #next if 1 .. /^C\.\s+/; + #last if /^D\.\s+/; + next unless /\s+(\S+)\s*=\s*(.*)/; + my $uref = $1; + my $expect = $2; + $expect =~ s/\(current document\)/$base/; + #print "$uref => $expect\n"; + + my $bad; + my $u = URI->new($uref, $base); + if ($u->abs($base)->as_string ne $expect) { + $bad++; + my $abs = $u->abs($base)->as_string; + print qq(URI->new("$uref")->abs("$base") ==> "$abs"\n); + } + + # Let's test another version of the same thing + $u = URI->new($uref); + my $b = URI->new($base); + if ($u->abs($b,1) ne $expect && $uref !~ /^http:/) { + $bad++; + print qq(URI->new("$uref")->abs(URI->new("$base"), 1)\n); + } + + # Let's try the other way + $u = URI->new($expect)->rel($base)->as_string; + if ($u ne $uref) { + push(@rel_fail, qq($testno: URI->new("$expect", "$base")->rel ==> "$u" (not "$uref")\n)); + } + + print "not " if $bad; + print "ok ", $testno++, "\n"; +} + +if (@rel_fail) { + print "\n\nIn the following cases we did not get back to where we started with rel()\n"; + print @rel_fail; +} + + + +__END__ + +Network Working Group T. Berners-Lee, MIT/LCS +INTERNET-DRAFT R. Fielding, U.C. Irvine +draft-fielding-uri-syntax-02 L. Masinter, Xerox Corporation +Expires six months after publication date March 4, 1998 + + + Uniform Resource Identifiers (URI): Generic Syntax + +[...] + +C. Examples of Resolving Relative URI References + + Within an object with a well-defined base URI of + + http://a/b/c/d;p?q + + the relative URIs would be resolved as follows: + +C.1. Normal Examples + + g:h = g:h + g = http://a/b/c/g + ./g = http://a/b/c/g + g/ = http://a/b/c/g/ + /g = http://a/g + //g = http://g + ?y = http://a/b/c/d;p?y + g?y = http://a/b/c/g?y + #s = (current document)#s + g#s = http://a/b/c/g#s + g?y#s = http://a/b/c/g?y#s + ;x = http://a/b/c/;x + g;x = http://a/b/c/g;x + g;x?y#s = http://a/b/c/g;x?y#s + . = http://a/b/c/ + ./ = http://a/b/c/ + .. = http://a/b/ + ../ = http://a/b/ + ../g = http://a/b/g + ../.. = http://a/ + ../../ = http://a/ + ../../g = http://a/g + +C.2. Abnormal Examples + + Although the following abnormal examples are unlikely to occur in + normal practice, all URI parsers should be capable of resolving them + consistently. Each example uses the same base as above. + + An empty reference refers to the start of the current document. + + <> = (current document) + + Parsers must be careful in handling the case where there are more + relative path ".." segments than there are hierarchical levels in + the base URI's path. Note that the ".." syntax cannot be used to + change the authority component of a URI. + + ../../../g = http://a/../g + ../../../../g = http://a/../../g + + In practice, some implementations strip leading relative symbolic + elements (".", "..") after applying a relative URI calculation, based + on the theory that compensating for obvious author errors is better + than allowing the request to fail. Thus, the above two references + will be interpreted as "http://a/g" by some implementations. + + Similarly, parsers must avoid treating "." and ".." as special when + they are not complete components of a relative path. + + /./g = http://a/./g + /../g = http://a/../g + g. = http://a/b/c/g. + .g = http://a/b/c/.g + g.. = http://a/b/c/g.. + ..g = http://a/b/c/..g + + Less likely are cases where the relative URI uses unnecessary or + nonsensical forms of the "." and ".." complete path segments. + + ./../g = http://a/b/g + ./g/. = http://a/b/c/g/ + g/./h = http://a/b/c/g/h + g/../h = http://a/b/c/h + g;x=1/./y = http://a/b/c/g;x=1/y + g;x=1/../y = http://a/b/c/y + + All client applications remove the query component from the base URI + before resolving relative URIs. However, some applications fail to + separate the reference's query and/or fragment components from a + relative path before merging it with the base path. This error is + rarely noticed, since typical usage of a fragment never includes the + hierarchy ("/") character, and the query component is not normally + used within relative references. + + g?y/./x = http://a/b/c/g?y/./x + g?y/../x = http://a/b/c/g?y/../x + g#s/./x = http://a/b/c/g#s/./x + g#s/../x = http://a/b/c/g#s/../x + + Some parsers allow the scheme name to be present in a relative URI + if it is the same as the base URI scheme. This is considered to be + a loophole in prior specifications of partial URIs [RFC1630]. Its + use should be avoided. + + http:g = http:g + http: = http: + + +========================================================================== + +Some extra tests for good measure... + + #foo? = (current document)#foo? + ?#foo = http://a/b/c/d;p?#foo + diff --git a/t/clone.t b/t/clone.t new file mode 100644 index 0000000..57201f5 --- /dev/null +++ b/t/clone.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +print "1..2\n"; + +use URI::URL; + +my $b = URI::URL->new("http://www/"); + +my $u1 = URI::URL->new("foo", $b); +my $u2 = $u1->clone; + +$u1->base("http://yyy/"); + +#use Data::Dump; Data::Dump::dump($b, $u1, $u2); + +print "not " unless $u1->abs->as_string eq "http://yyy/foo"; +print "ok 1\n"; + +print "not " unless $u2->abs->as_string eq "http://www/foo"; +print "ok 2\n"; @@ -0,0 +1,15 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +plan tests => 1; + +use URI::file; +$ENV{PATH} = "/bin:/usr/bin"; + +my $cwd = eval { URI::file->cwd }; +is($@, '', 'no exceptions'); + diff --git a/t/data.t b/t/data.t new file mode 100644 index 0000000..64920d9 --- /dev/null +++ b/t/data.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +eval { + require MIME::Base64; +}; +if ($@) { + print "1..0\n"; + print $@; + exit; +} + +print "1..22\n"; + +use URI; + +my $u = URI->new("data:,A%20brief%20note"); +print "not " unless $u->scheme eq "data" && $u->opaque eq ",A%20brief%20note"; +print "ok 1\n"; + +print "not " unless $u->media_type eq "text/plain;charset=US-ASCII" && + $u->data eq "A brief note"; +print "ok 2\n"; + +my $old = $u->data("Får-i-kål er tingen!"); +print "not " unless $old eq "A brief note" && $u eq "data:,F%E5r-i-k%E5l%20er%20tingen!"; +print "ok 3\n"; + +$old = $u->media_type("text/plain;charset=iso-8859-1"); +print "not " unless $old eq "text/plain;charset=US-ASCII" && + $u eq "data:text/plain;charset=iso-8859-1,F%E5r-i-k%E5l%20er%20tingen!"; +print "ok 4\n"; + + +$u = URI->new("data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAwAAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFzByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSpa/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJlZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uisF81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PHhhx4dbgYKAAA7"); + +print "not " unless $u->media_type eq "image/gif"; +print "ok 5\n"; + +if ($ENV{DISPLAY} && $ENV{XV}) { + open(XV, "| $ENV{XV} -") || die; + print XV $u->data; + close(XV); +} +print "not " unless length($u->data) == 273; +print "ok 6\n"; + +$u = URI->new("data:text/plain;charset=iso-8859-7,%be%fg%be"); # %fg +print "not " unless $u->data eq "\xBE%fg\xBE"; +print "ok 7\n"; + +$u = URI->new("data:application/vnd-xxx-query,select_vcount,fcol_from_fieldtable/local"); +print "not " unless $u->data eq "select_vcount,fcol_from_fieldtable/local"; +print "ok 8\n"; +$u->data(""); +print "not " unless $u eq "data:application/vnd-xxx-query,"; +print "ok 9\n"; + +$u->data("a,b"); $u->media_type(undef); +print "not " unless $u eq "data:,a,b"; +print "ok 10\n"; + +# Test automatic selection of URI/BASE64 encoding +$u = URI->new("data:"); +$u->data(""); +print "not " unless $u eq "data:,"; +print "ok 11\n"; + +$u->data(">"); +print "not " unless $u eq "data:,%3E" && $u->data eq ">"; +print "ok 12\n"; + +$u->data(">>>>>"); +print "not " unless $u eq "data:,%3E%3E%3E%3E%3E"; +print "ok 13\n"; + +$u->data(">>>>>>"); +print "not " unless $u eq "data:;base64,Pj4+Pj4+"; +print "ok 14\n"; + +$u->media_type("text/plain;foo=bar"); +print "not " unless $u eq "data:text/plain;foo=bar;base64,Pj4+Pj4+"; +print "ok 15\n"; + +$u->media_type("foo"); +print "not " unless $u eq "data:foo;base64,Pj4+Pj4+"; +print "ok 16\n"; + +$u->data(">" x 3000); +print "not " unless $u eq ("data:foo;base64," . ("Pj4+" x 1000)) && + $u->data eq (">" x 3000); +print "ok 17\n"; + +$u->media_type(undef); +$u->data(undef); +print "not " unless $u eq "data:,"; +print "ok 18\n"; + +$u = URI->new("data:foo"); +print "not " unless $u->media_type("bar,båz") eq "foo"; +print "ok 19\n"; + +print "not " unless $u->media_type eq "bar,båz"; +print "ok 20\n"; + +$old = $u->data("new"); +print "not " unless $old eq "" && $u eq "data:bar%2Cb%E5z,new"; +print "ok 21\n"; + +print "not " unless URI->new('data:;base64,%51%6D%70%76%5A%58%4A%75')->data eq "Bjoern"; +print "ok 22\n"; diff --git a/t/distmanifest.t b/t/distmanifest.t new file mode 100644 index 0000000..c2812f7 --- /dev/null +++ b/t/distmanifest.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use Test::More; +BEGIN { + plan skip_all => 'these tests are for authors only!' + unless -d '.git' || $ENV{AUTHOR_TESTING}; +} + +use Test::DistManifest; +manifest_ok(); diff --git a/t/escape-char.t b/t/escape-char.t new file mode 100644 index 0000000..b03e43d --- /dev/null +++ b/t/escape-char.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +# see https://rt.cpan.org/Ticket/Display.html?id=96941 + +use Test::More; +use URI; + +TODO: { + my $str = "http://foo/\xE9"; + utf8::upgrade($str); + my $uri = URI->new($str); + + local $TODO = 'URI::Escape::escape_char misunderstands utf8'; + + # http://foo/%C3%A9 + is("$uri", 'http://foo/%E9', 'correctly created a URI from a utf8-upgraded string'); +} + +{ + my $str = "http://foo/\xE9"; + utf8::downgrade($str); + my $uri = URI->new($str); + + # http://foo/%E9 + is("$uri", 'http://foo/%E9', 'correctly created a URI from a utf8-downgrade string'); +} + +done_testing; diff --git a/t/escape.t b/t/escape.t new file mode 100644 index 0000000..05b8022 --- /dev/null +++ b/t/escape.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Test::More tests => 12; + +use URI::Escape; + +is uri_escape("|abcå"), "%7Cabc%E5"; + +is uri_escape("abc", "b-d"), "a%62%63"; + +# New escapes in RFC 3986 +is uri_escape("~*'()"), "~%2A%27%28%29"; +is uri_escape("<\">"), "%3C%22%3E"; + +is uri_escape(undef), undef; + +is uri_unescape("%7Cabc%e5"), "|abcå"; + +is_deeply [uri_unescape("%40A%42", "CDE", "F%47H")], [qw(@AB CDE FGH)]; + + +use URI::Escape qw(%escapes); + +is $escapes{"%"}, "%25"; + + +use URI::Escape qw(uri_escape_utf8); + +is uri_escape_utf8("|abcå"), "%7Cabc%C3%A5"; + +skip "Perl 5.8.0 or higher required", 3 if $] < 5.008; + +ok !eval { print uri_escape("abc" . chr(300)); 1 }; +like $@, qr/^Can\'t escape \\x\{012C\}, try uri_escape_utf8\(\) instead/; + +is uri_escape_utf8(chr(0xFFF)), "%E0%BF%BF"; diff --git a/t/file.t b/t/file.t new file mode 100644 index 0000000..26e0119 --- /dev/null +++ b/t/file.t @@ -0,0 +1,65 @@ +#!perl -T + +use strict; +use warnings; + +use URI::file; + +my @tests = ( +[ "file", "unix", "win32", "mac" ], +#---------------- ------------ --------------- -------------- +[ "file://localhost/foo/bar", + "!/foo/bar", "!\\foo\\bar", "!foo:bar", ], +[ "file:///foo/bar", + "/foo/bar", "\\foo\\bar", "!foo:bar", ], +[ "file:/foo/bar", "!/foo/bar", "!\\foo\\bar", "foo:bar", ], +[ "foo/bar", "foo/bar", "foo\\bar", ":foo:bar",], +[ "file://foo3445x/bar","!//foo3445x/bar", "!\\\\foo3445x\\bar", "!foo3445x:bar"], +[ "file://a:/", "!//a:/", "!A:\\", undef], +[ "file:///A:/", "/A:/", "A:\\", undef], +[ "file:///", "/", "\\", undef], +[ ".", ".", ".", ":"], +[ "..", "..", "..", "::"], +[ "%2E", "!.", "!.", ":."], +[ "../%2E%2E", "!../..", "!..\\..", "::.."], +); + +my @os = @{shift @tests}; +shift @os; # file + +my $num = @tests; +print "1..$num\n"; + +my $testno = 1; + +for my $t (@tests) { + my @t = @$t; + my $file = shift @t; + my $err; + + my $u = URI->new($file, "file"); + my $i = 0; + for my $os (@os) { + my $f = $u->file($os); + my $expect = $t[$i]; + $f = "<undef>" unless defined $f; + $expect = "<undef>" unless defined $expect; + my $loose; + $loose++ if $expect =~ s/^!//; + if ($expect ne $f) { + print "URI->new('$file', 'file')->file('$os') ne $expect, but $f\n"; + $err++; + } + if (defined($t[$i]) && !$loose) { + my $u2 = URI::file->new($t[$i], $os); + unless ($u2->as_string eq $file) { + print "URI::file->new('$t[$i]', '$os') ne $file, but $u2\n"; + $err++; + } + } + $i++; + } + print "not " if $err; + print "ok $testno\n"; + $testno++; +} @@ -0,0 +1,53 @@ +use strict; +use warnings; + +print "1..13\n"; + +use URI; +my $uri; + +$uri = URI->new("ftp://ftp.example.com/path"); + +print "not " unless $uri->scheme eq "ftp"; +print "ok 1\n"; + +print "not " unless $uri->host eq "ftp.example.com"; +print "ok 2\n"; + +print "not " unless $uri->port eq 21; +print "ok 3\n"; + +print "not " unless $uri->user eq "anonymous"; +print "ok 4\n"; + +print "not " unless $uri->password eq 'anonymous@'; +print "ok 5\n"; + +$uri->userinfo("gisle\@aas.no"); + +print "not " unless $uri eq "ftp://gisle%40aas.no\@ftp.example.com/path"; +print "ok 6\n"; + +print "not " unless $uri->user eq "gisle\@aas.no"; +print "ok 7\n"; + +print "not " if defined($uri->password); +print "ok 8\n"; + +$uri->password("secret"); + +print "not " unless $uri eq "ftp://gisle%40aas.no:secret\@ftp.example.com/path"; +print "ok 9\n"; + +$uri = URI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path"); +print "not " unless $uri eq "ftp://gisle\@aas.no:secret\@ftp.example.com/path"; +print "ok 10\n"; + +print "not " unless $uri->userinfo eq "gisle\@aas.no:secret"; +print "ok 11\n"; + +print "not " unless $uri->user eq "gisle\@aas.no"; +print "ok 12\n"; + +print "not " unless $uri->password eq "secret"; +print "ok 13\n"; diff --git a/t/generic.t b/t/generic.t new file mode 100644 index 0000000..e2f7b97 --- /dev/null +++ b/t/generic.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +print "1..48\n"; + +use URI; + +my $foo = URI->new("Foo:opaque#frag"); + +print "not " unless ref($foo) eq "URI::_foreign"; +print "ok 1\n"; + +print "not " unless $foo->as_string eq "Foo:opaque#frag"; +print "ok 2\n"; + +print "not " unless "$foo" eq "Foo:opaque#frag"; +print "ok 3\n"; + +# Try accessors +print "not " unless $foo->_scheme eq "Foo" && $foo->scheme eq "foo" && !$foo->has_recognized_scheme; +print "ok 4\n"; + +print "not " unless $foo->opaque eq "opaque"; +print "ok 5\n"; + +print "not " unless $foo->fragment eq "frag"; +print "ok 6\n"; + +print "not " unless $foo->canonical eq "foo:opaque#frag"; +print "ok 7\n"; + +# Try modificators +my $old = $foo->scheme("bar"); + +print "not " unless $old eq "foo" && $foo eq "bar:opaque#frag"; +print "ok 8\n"; + +$old = $foo->scheme(""); +print "not " unless $old eq "bar" && $foo eq "opaque#frag"; +print "ok 9\n"; + +$old = $foo->scheme("foo"); +$old = $foo->scheme(undef); + +print "not " unless $old eq "foo" && $foo eq "opaque#frag"; +print "ok 10\n"; + +$foo->scheme("foo"); + + +$old = $foo->opaque("xxx"); +print "not " unless $old eq "opaque" && $foo eq "foo:xxx#frag"; +print "ok 11\n"; + +$old = $foo->opaque(""); +print "not " unless $old eq "xxx" && $foo eq "foo:#frag"; +print "ok 12\n"; + +$old = $foo->opaque(" #?/"); +$old = $foo->opaque(undef); +print "not " unless $old eq "%20%23?/" && $foo eq "foo:#frag"; +print "ok 13\n"; + +$foo->opaque("opaque"); + + +$old = $foo->fragment("x"); +print "not " unless $old eq "frag" && $foo eq "foo:opaque#x"; +print "ok 14\n"; + +$old = $foo->fragment(""); +print "not " unless $old eq "x" && $foo eq "foo:opaque#"; +print "ok 15\n"; + +$old = $foo->fragment(undef); +print "not " unless $old eq "" && $foo eq "foo:opaque"; +print "ok 16\n"; + + +# Compare +print "not " unless $foo->eq("Foo:opaque") && + $foo->eq(URI->new("FOO:opaque")) && + $foo->eq("foo:opaque"); +print "ok 17\n"; + +print "not " if $foo->eq("Bar:opaque") || + $foo->eq("foo:opaque#"); +print "ok 18\n"; + + +# Try hierarchal unknown URLs + +$foo = URI->new("foo://host:80/path?query#frag"); + +print "not " unless "$foo" eq "foo://host:80/path?query#frag"; +print "ok 19\n"; + +# Accessors +print "not " unless $foo->scheme eq "foo"; +print "ok 20\n"; + +print "not " unless $foo->authority eq "host:80"; +print "ok 21\n"; + +print "not " unless $foo->path eq "/path"; +print "ok 22\n"; + +print "not " unless $foo->query eq "query"; +print "ok 23\n"; + +print "not " unless $foo->fragment eq "frag"; +print "ok 24\n"; + +# Modificators +$old = $foo->authority("xxx"); +print "not " unless $old eq "host:80" && $foo eq "foo://xxx/path?query#frag"; +print "ok 25\n"; + +$old = $foo->authority(""); +print "not " unless $old eq "xxx" && $foo eq "foo:///path?query#frag"; +print "ok 26\n"; + +$old = $foo->authority(undef); +print "not " unless $old eq "" && $foo eq "foo:/path?query#frag"; +print "ok 27\n"; + +$old = $foo->authority("/? #;@&"); +print "not " unless !defined($old) && $foo eq "foo://%2F%3F%20%23;@&/path?query#frag"; +print "ok 28\n"; + +$old = $foo->authority("host:80"); +print "not " unless $old eq "%2F%3F%20%23;@&" && $foo eq "foo://host:80/path?query#frag"; +print "ok 29\n"; + + +$old = $foo->path("/foo"); +print "not " unless $old eq "/path" && $foo eq "foo://host:80/foo?query#frag"; +print "ok 30\n"; + +$old = $foo->path("bar"); +print "not " unless $old eq "/foo" && $foo eq "foo://host:80/bar?query#frag"; +print "ok 31\n"; + +$old = $foo->path(""); +print "not " unless $old eq "/bar" && $foo eq "foo://host:80?query#frag"; +print "ok 32\n"; + +$old = $foo->path(undef); +print "not " unless $old eq "" && $foo eq "foo://host:80?query#frag"; +print "ok 33\n"; + +$old = $foo->path("@;/?#"); +print "not " unless $old eq "" && $foo eq "foo://host:80/@;/%3F%23?query#frag"; +print "ok 34\n"; + +$old = $foo->path("path"); +print "not " unless $old eq "/@;/%3F%23" && $foo eq "foo://host:80/path?query#frag"; +print "ok 35\n"; + + +$old = $foo->query("foo"); +print "not " unless $old eq "query" && $foo eq "foo://host:80/path?foo#frag"; +print "ok 36\n"; + +$old = $foo->query(""); +print "not " unless $old eq "foo" && $foo eq "foo://host:80/path?#frag"; +print "ok 37\n"; + +$old = $foo->query(undef); +print "not " unless $old eq "" && $foo eq "foo://host:80/path#frag"; +print "ok 38\n"; + +$old = $foo->query("/?&=# "); +print "not " unless !defined($old) && $foo eq "foo://host:80/path?/?&=%23%20#frag"; +print "ok 39\n"; + +$old = $foo->query("query"); +print "not " unless $old eq "/?&=%23%20" && $foo eq "foo://host:80/path?query#frag"; +print "ok 40\n"; + +# Some buildup trics +$foo = URI->new(""); +$foo->path("path"); +$foo->authority("auth"); + +print "not " unless $foo eq "//auth/path"; +print "ok 41\n"; + +$foo = URI->new("", "http:"); +$foo->query("query"); +$foo->authority("auth"); +print "not " unless $foo eq "//auth?query" && $foo->has_recognized_scheme; +print "ok 42\n"; + +$foo->path("path"); +print "not " unless $foo eq "//auth/path?query"; +print "ok 43\n"; + +$foo = URI->new(""); +$old = $foo->path("foo"); +print "not " unless $old eq "" && $foo eq "foo" && !$foo->has_recognized_scheme; +print "ok 44\n"; + +$old = $foo->path("bar"); +print "not " unless $old eq "foo" && $foo eq "bar"; +print "ok 45\n"; + +$old = $foo->opaque("foo"); +print "not " unless $old eq "bar" && $foo eq "foo"; +print "ok 46\n"; + +$old = $foo->path(""); +print "not " unless $old eq "foo" && $foo eq ""; +print "ok 47\n"; + +$old = $foo->query("q"); +print "not " unless !defined($old) && $foo eq "?q"; +print "ok 48\n"; + diff --git a/t/gopher.t b/t/gopher.t new file mode 100644 index 0000000..427a5fc --- /dev/null +++ b/t/gopher.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +print "1..48\n"; + +use URI; + +my $t = 1; +sub is { + my ($exp, $got) = @_; + if (!defined $exp) { + print "not " if defined $got; + } + else { + print "not " unless $got eq $exp; + } + print "ok " . ($t++) . "\n"; +} + +sub check_gopher_uri { + my ($u, $exphost, $expport, $exptype, $expselector, $expsearch) = @_; + is("gopher", $u->scheme); + is($exphost, $u->host); + is($expport, $u->port); + is($exptype, $u->gopher_type); + is($expselector, $u->selector); + is($expsearch, $u->search); +} + +my $u; +$u = URI->new("gopher://host"); +check_gopher_uri($u, "host", 70, 1); +$u = URI->new("gopher://host:70"); +check_gopher_uri($u, "host", 70, 1); +$u = URI->new("gopher://host:70/"); +check_gopher_uri($u, "host", 70, 1); +$u = URI->new("gopher://host:70/1"); +check_gopher_uri($u, "host", 70, 1); +$u = URI->new("gopher://host:70/1"); +check_gopher_uri($u, "host", 70, 1); +$u = URI->new("gopher://host:123/7foo"); +check_gopher_uri($u, "host", 123, 7, "foo"); +$u = URI->new("gopher://host/7foo\tbar%20baz"); +check_gopher_uri($u, "host", 70, 7, "foo", "bar baz"); +$u = URI->new("gopher://host/7foo%09bar%20baz"); +check_gopher_uri($u, "host", 70, 7, "foo", "bar baz"); diff --git a/t/heuristic.t b/t/heuristic.t new file mode 100644 index 0000000..63c2ad8 --- /dev/null +++ b/t/heuristic.t @@ -0,0 +1,138 @@ +use strict; +use warnings; + +BEGIN { + # mock up a gethostbyname that always works :-) + *CORE::GLOBAL::gethostbyname = sub { + my $name = shift; + #print "# gethostbyname [$name]\n"; + die if wantarray; + return 1 if $name =~ /^www\.perl\.(com|org|ca|su)\.$/; + return 1 if $name eq "www.perl.co.uk\."; + return 0; + }; +} + +print "1..26\n"; + +use URI::Heuristic qw(uf_urlstr uf_url); +if (shift) { + $URI::Heuristic::DEBUG++; + open(STDERR, ">&STDOUT"); # redirect STDERR +} + +print "not " unless uf_urlstr("http://www.sn.no/") eq "http://www.sn.no/"; +print "ok 1\n"; + +if ($^O eq "MacOS") { + print "not " unless uf_urlstr("etc:passwd") eq "file:/etc/passwd"; +} else { +print "not " unless uf_urlstr("/etc/passwd") eq "file:/etc/passwd"; +} +print "ok 2\n"; + +if ($^O eq "MacOS") { + print "not " unless uf_urlstr(":foo.txt") eq "file:./foo.txt"; +} else { +print "not " unless uf_urlstr("./foo.txt") eq "file:./foo.txt"; +} +print "ok 3\n"; + +print "not " unless uf_urlstr("ftp.aas.no/lwp.tar.gz") eq "ftp://ftp.aas.no/lwp.tar.gz"; +print "ok 4\n"; + +if($^O eq "MacOS") { +# its a weird, but valid, MacOS path, so it can't be left alone + print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:/C/%5CCONFIG.SYS"; +} else { +print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:C:\\CONFIG.SYS"; +} +print "ok 5\n"; + +{ + local $ENV{LC_ALL} = ""; + local $ENV{LANG} = ""; + local $ENV{HTTP_ACCEPT_LANGUAGE} = ""; + + $ENV{LC_ALL} = "en_GB.UTF-8"; + undef $URI::Heuristic::MY_COUNTRY; + print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,; + print "ok 6\n"; + + use Net::Domain; + $ENV{LC_ALL} = "C"; + { no warnings; *Net::Domain::hostfqdn = sub { return 'vasya.su' } } + undef $URI::Heuristic::MY_COUNTRY; + print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.su/camel\.gif$,; + print "ok 7\n"; + + $ENV{LC_ALL} = "C"; + { no warnings; *Net::Domain::hostfqdn = sub { return '' } } + undef $URI::Heuristic::MY_COUNTRY; + print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(com|org)/camel\.gif$,; + print "ok 8\n"; + + $ENV{HTTP_ACCEPT_LANGUAGE} = "en-ca"; + undef $URI::Heuristic::MY_COUNTRY; + print "not " unless uf_urlstr("perl/camel.gif") eq "http://www.perl.ca/camel.gif"; + print "ok 9\n"; +} + +$URI::Heuristic::MY_COUNTRY = "bv"; +print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(com|org)/camel\.gif$,; +print "ok 10\n"; + +# Backwards compatibility; uk != United Kingdom in ISO 3166 +$URI::Heuristic::MY_COUNTRY = "uk"; +print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,; +print "ok 11\n"; + +$URI::Heuristic::MY_COUNTRY = "gb"; +print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,; +print "ok 12\n"; + +$ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com"; +print "not " unless uf_urlstr("perl") eq "http://www.perl.org"; +print "ok 13\n"; + +{ + local $ENV{URL_GUESS_PATTERN} = ""; + print "not " unless uf_urlstr("perl") eq "http://perl"; + print "ok 14\n"; + + print "not " unless uf_urlstr("http:80") eq "http:80"; + print "ok 15\n"; + + print "not " unless uf_urlstr("mailto:gisle\@aas.no") eq "mailto:gisle\@aas.no"; + print "ok 16\n"; + + print "not " unless uf_urlstr("gisle\@aas.no") eq "mailto:gisle\@aas.no"; + print "ok 17\n"; + + print "not " unless uf_urlstr("Gisle.Aas\@aas.perl.org") eq "mailto:Gisle.Aas\@aas.perl.org"; + print "ok 18\n"; + + print "not " unless uf_url("gopher.sn.no")->scheme eq "gopher"; + print "ok 19\n"; + + print "not " unless uf_urlstr("123.3.3.3:8080/foo") eq "http://123.3.3.3:8080/foo"; + print "ok 20\n"; + + print "not " unless uf_urlstr("123.3.3.3:443/foo") eq "https://123.3.3.3:443/foo"; + print "ok 21\n"; + + print "not " unless uf_urlstr("123.3.3.3:21/foo") eq "ftp://123.3.3.3:21/foo"; + print "ok 22\n"; + + print "not " unless uf_url("FTP.example.com")->scheme eq "ftp"; + print "ok 23\n"; + + print "not " unless uf_url("ftp2.example.com")->scheme eq "ftp"; + print "ok 24\n"; + + print "not " unless uf_url("ftp")->scheme eq "ftp"; + print "ok 25\n"; + + print "not " unless uf_url("https.example.com")->scheme eq "https"; + print "ok 26\n"; +} diff --git a/t/http.t b/t/http.t new file mode 100644 index 0000000..fb30124 --- /dev/null +++ b/t/http.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +print "1..16\n"; + +use URI; + +my $u = URI->new("<http://www.perl.com/path?q=fôo>"); + +#print "$u\n"; +print "not " unless $u eq "http://www.perl.com/path?q=f%F4o"; +print "ok 1\n"; + +print "not " unless $u->port == 80; +print "ok 2\n"; + +# play with port +my $old = $u->port(8080); +print "not " unless $old == 80 && $u eq "http://www.perl.com:8080/path?q=f%F4o"; +print "ok 3\n"; + +$u->port(80); +print "not " unless $u eq "http://www.perl.com:80/path?q=f%F4o"; +print "ok 4\n"; + +$u->port(""); +print "not " unless $u eq "http://www.perl.com:/path?q=f%F4o" && $u->port == 80; +print "ok 5\n"; + +$u->port(undef); +print "not " unless $u eq "http://www.perl.com/path?q=f%F4o"; +print "ok 6\n"; + +my @q = $u->query_form; +print "not " unless @q == 2 && "@q" eq "q fôo"; +print "ok 7\n"; + +$u->query_form(foo => "bar", bar => "baz"); +print "not " unless $u->query eq "foo=bar&bar=baz"; +print "ok 8\n"; + +print "not " unless $u->host eq "www.perl.com"; +print "ok 9\n"; + +print "not " unless $u->path eq "/path"; +print "ok 10\n"; + +print "not " if $u->secure; +print "ok 11\n"; + +$u->scheme("https"); +print "not " unless $u->port == 443; +print "ok 12\n"; + +print "not " unless $u eq "https://www.perl.com/path?foo=bar&bar=baz"; +print "ok 13\n"; + +print "not " unless $u->secure; +print "ok 14\n"; + +$u = URI->new("http://%77%77%77%2e%70%65%72%6c%2e%63%6f%6d/%70%75%62/%61/%32%30%30%31/%30%38/%32%37/%62%6a%6f%72%6e%73%74%61%64%2e%68%74%6d%6c"); +print "not " unless $u->canonical eq "http://www.perl.com/pub/a/2001/08/27/bjornstad.html"; +print "ok 15\n"; + +print "not " unless $u->has_recognized_scheme; +print "ok 16\n"; diff --git a/t/idna.t b/t/idna.t new file mode 100644 index 0000000..da2ad98 --- /dev/null +++ b/t/idna.t @@ -0,0 +1,14 @@ +use strict; +use warnings; + +use utf8; +use Test::More tests => 7; +use URI::_idna; + +is URI::_idna::encode("www.example.com"), "www.example.com"; +is URI::_idna::decode("www.example.com"), "www.example.com"; +is URI::_idna::encode("www.example.com."), "www.example.com."; +is URI::_idna::decode("www.example.com."), "www.example.com."; +is URI::_idna::encode("Bücher.ch"), "xn--bcher-kva.ch"; +is URI::_idna::decode("xn--bcher-kva.ch"), "bücher.ch"; +is URI::_idna::decode("xn--bcher-KVA.ch"), "bücher.ch"; @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use utf8; +use Test::More; +use Config; + +if (defined $Config{useperlio}) { + plan tests=>26; +} else { + plan skip_all=>'this perl doesn\'t support PerlIO layers'; +} + +use URI; +use URI::IRI; + +my $u; + +binmode Test::More->builder->output, ':encoding(UTF-8)'; +binmode Test::More->builder->failure_output, ':encoding(UTF-8)'; + +$u = URI->new("http://Bücher.ch"); +is $u, "http://xn--bcher-kva.ch"; +is $u->host, "xn--bcher-kva.ch"; +is $u->ihost, "bücher.ch"; +is $u->as_iri, "http://bücher.ch"; + +$u = URI->new("http://example.com/Bücher"); +is $u, "http://example.com/B%C3%BCcher"; +is $u->as_iri, "http://example.com/Bücher"; + +$u = URI->new("http://example.com/B%FCcher"); # latin1 encoded stuff +is $u->as_iri, "http://example.com/B%FCcher"; # ...should not be decoded + +$u = URI->new("http://example.com/B\xFCcher"); +is $u->as_string, "http://example.com/B%FCcher"; +is $u->as_iri, "http://example.com/B%FCcher"; + +$u = URI::IRI->new("http://example.com/B\xFCcher"); +is $u->as_string, "http://example.com/Bücher"; +is $u->as_iri, "http://example.com/Bücher"; + +# draft-duerst-iri-bis.txt claims this should map to xn--rsum-bad.example.org +$u = URI->new("http://r\xE9sum\xE9.example.org"); +is $u->as_string, "http://xn--rsum-bpad.example.org"; + +$u = URI->new("http://xn--rsum-bad.example.org"); +is $u->as_iri, "http://r\x80sum\x80.example.org"; + +$u = URI->new("http://r%C3%A9sum%C3%A9.example.org"); +is $u->as_string, "http://r%C3%A9sum%C3%A9.example.org"; +is $u->as_iri, "http://r\xE9sum\xE9.example.org"; + +$u = URI->new("http://âž¡.ws/"); +is $u, "http://xn--hgi.ws/"; +is $u->host, "xn--hgi.ws"; +is $u->ihost, "âž¡.ws"; +is $u->as_iri, "http://âž¡.ws/"; + +# draft-duerst-iri-bis.txt examples (section 3.7.1): +is(URI->new("http://www.example.org/D%C3%BCrst")->as_iri, "http://www.example.org/D\xFCrst"); +is(URI->new("http://www.example.org/D%FCrst")->as_iri, "http://www.example.org/D%FCrst"); +TODO: { + local $TODO = "some chars (like U+202E, RIGHT-TO-LEFT OVERRIDE) need to stay escaped"; +is(URI->new("http://xn--99zt52a.example.org/%e2%80%ae")->as_iri, "http://\x{7D0D}\x{8C46}.example.org/%e2%80%ae"); +} + +# try some URLs that can't be IDNA encoded (fallback to encoded UTF8 bytes) +$u = URI->new("http://" . ("ü" x 128)); +is $u, "http://" . ("%C3%BC" x 128); +is $u->host, ("\xC3\xBC" x 128); +TODO: { + local $TODO = "should ihost decode UTF8 bytes?"; + is $u->ihost, ("ü" x 128); +} +is $u->as_iri, "http://" . ("ü" x 128); diff --git a/t/ldap.t b/t/ldap.t new file mode 100644 index 0000000..3cd3dd8 --- /dev/null +++ b/t/ldap.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +print "1..24\n"; + +use URI; + +my $uri; + +$uri = URI->new("ldap://host/dn=base?cn,sn?sub?objectClass=*"); + +print "not " unless $uri->host eq "host"; +print "ok 1\n"; + +print "not " unless $uri->dn eq "dn=base"; +print "ok 2\n"; + +print "not " unless join("-",$uri->attributes) eq "cn-sn"; +print "ok 3\n"; + +print "not " unless $uri->scope eq "sub"; +print "ok 4\n"; + +print "not " unless $uri->filter eq "objectClass=*"; +print "ok 5\n"; + +$uri = URI->new("ldap:"); +$uri->dn("o=University of Michigan,c=US"); + +print "not " unless "$uri" eq "ldap:o=University%20of%20Michigan,c=US" && + $uri->dn eq "o=University of Michigan,c=US"; +print "ok 6\n"; + +$uri->host("ldap.itd.umich.edu"); +print "not " unless $uri->as_string eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US"; +print "ok 7\n"; + +# check defaults +print "not " unless $uri->_scope eq "" && + $uri->scope eq "base" && + $uri->_filter eq "" && + $uri->filter eq "(objectClass=*)"; +print "ok 8\n"; + +# attribute +$uri->attributes("postalAddress"); +print "not " unless $uri eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US?postalAddress"; +print "ok 9\n"; + +# does attribute escapeing work as it should +$uri->attributes($uri->attributes, "foo", ",", "*", "?", "#", "\0"); + +print "not " unless $uri->attributes eq "postalAddress,foo,%2C,*,%3F,%23,%00" && + join("-", $uri->attributes) eq "postalAddress-foo-,-*-?-#-\0"; +print "ok 10\n"; +$uri->attributes(""); + +$uri->scope("sub?#"); +print "not " unless $uri->query eq "?sub%3F%23" && + $uri->scope eq "sub?#"; +print "ok 11\n"; +$uri->scope(""); + +$uri->filter("f=?,#"); +print "not " unless $uri->query eq "??f=%3F,%23" && + $uri->filter eq "f=?,#"; + +$uri->filter("(int=\\00\\00\\00\\04)"); +print "not " unless $uri->query eq "??(int=%5C00%5C00%5C00%5C04)"; +print "ok 12\n"; + + +print "ok 13\n"; +$uri->filter(""); + +$uri->extensions("!bindname" => "cn=Manager,co=Foo"); +my %ext = $uri->extensions; + +print "not " unless $uri->query eq "???!bindname=cn=Manager%2Cco=Foo" && + keys %ext == 1 && + $ext{"!bindname"} eq "cn=Manager,co=Foo"; +print "ok 14\n"; + +$uri = URI->new("ldap://LDAP-HOST:389/o=University%20of%20Michigan,c=US?postalAddress?base?ObjectClass=*?FOO=Bar,bindname=CN%3DManager%CO%3dFoo"); + +print "not " unless $uri->canonical eq "ldap://ldap-host/o=University%20of%20Michigan,c=US?postaladdress???foo=Bar,bindname=CN=Manager%CO=Foo"; +print "ok 15\n"; + +print "$uri\n"; +print $uri->canonical, "\n"; + +print "not " if $uri->secure; +print "ok 16\n"; + +$uri = URI->new("ldaps://host/dn=base?cn,sn?sub?objectClass=*"); + +print "not " unless $uri->host eq "host"; +print "ok 17\n"; +print "not " unless $uri->port eq 636; +print "ok 18\n"; +print "not " unless $uri->dn eq "dn=base"; +print "ok 19\n"; +print "not " unless $uri->secure; +print "ok 20\n"; + +$uri = URI->new("ldapi://%2Ftmp%2Fldap.sock/????x-mod=-w--w----"); +print "not " unless $uri->authority eq "%2Ftmp%2Fldap.sock"; +print "ok 21\n"; +print "not " unless $uri->un_path eq "/tmp/ldap.sock"; +print "ok 22\n"; + +$uri->un_path("/var/x\@foo:bar/"); +print "not " unless $uri eq "ldapi://%2Fvar%2Fx%40foo%3Abar%2F/????x-mod=-w--w----"; +print "ok 23\n"; + +%ext = $uri->extensions; +print "not " unless $ext{"x-mod"} eq "-w--w----"; +print "ok 24\n"; + diff --git a/t/mailto.t b/t/mailto.t new file mode 100644 index 0000000..f13a1f8 --- /dev/null +++ b/t/mailto.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +print "1..7\n"; + +use URI; + +my $u = URI->new('mailto:gisle@aas.no'); + +print "not " unless $u->to eq 'gisle@aas.no' && + $u eq 'mailto:gisle@aas.no'; +print "ok 1\n"; + +my $old = $u->to('larry@wall.org'); +print "not " unless $old eq 'gisle@aas.no' && + $u->to eq 'larry@wall.org' && + $u eq 'mailto:larry@wall.org'; +print "ok 2\n"; + +$u->to("?/#"); +print "not " unless $u->to eq "?/#" && + $u eq 'mailto:%3F/%23'; +print "ok 3\n"; + +my @h = $u->headers; +print "not " unless @h == 2 && "@h" eq "to ?/#"; +print "ok 4\n"; + +$u->headers(to => 'gisle@aas.no', + cc => 'gisle@ActiveState.com,larry@wall.org', + Subject => 'How do you do?', + garbage => '/;?#=&', +); + +@h = $u->headers; +print "not " unless $u->to eq 'gisle@aas.no' && + @h == 8 && + "@h" eq 'to gisle@aas.no cc gisle@ActiveState.com,larry@wall.org Subject How do you do? garbage /;?#=&'; +print "ok 5\n"; + +#print "$u\n"; +print "not " unless $u eq 'mailto:gisle@aas.no?cc=gisle%40ActiveState.com%2Clarry%40wall.org&Subject=How+do+you+do%3F&garbage=%2F%3B%3F%23%3D%26'; +print "ok 6\n"; + +$u = URI->new("mailto:"); +$u->to("gisle"); +print "not " unless $u eq 'mailto:gisle'; +print "ok 7\n"; @@ -0,0 +1,80 @@ +use strict; +use warnings; + +print "1..6\n"; + +# Test mixing of URI and URI::WithBase objects +use URI; +use URI::WithBase; +use URI::URL; + +my $str = "http://www.sn.no/"; +my $rel = "path/img.gif"; + +my $u = URI->new($str); +my $uw = URI::WithBase->new($str, "http:"); +my $uu = URI::URL->new($str); + +my $a = URI->new($rel, $u); +my $b = URI->new($rel, $uw); +my $c = URI->new($rel, $uu); +my $d = URI->new($rel, $str); + +sub Dump +{ + require Data::Dumper; + print Data::Dumper->Dump([$a, $b, $c, $d], [qw(a b c d)]); +} + +#Dump(); +print "not " unless $a->isa("URI") && + ref($b) eq ref($uw) && + ref($c) eq ref($uu) && + $d->isa("URI"); +print "ok 1\n"; + +print "not " if $b->base && $c->base; +print "ok 2\n"; + +$a = URI::URL->new($rel, $u); +$b = URI::URL->new($rel, $uw); +$c = URI::URL->new($rel, $uu); +$d = URI::URL->new($rel, $str); + +print "not " unless ref($a) eq "URI::URL" && + ref($b) eq "URI::URL" && + ref($c) eq "URI::URL" && + ref($d) eq "URI::URL"; +print "ok 3\n"; + +print "not " unless ref($b->base) eq ref($uw) && + $b->base eq $uw && + ref($c->base) eq ref($uu) && + $c->base eq $uu && + $d->base eq $str; +print "ok 4\n"; + + + +$a = URI->new($uu, $u); +$b = URI->new($uu, $uw); +$c = URI->new($uu, $uu); +$d = URI->new($uu, $str); + +#Dump(); +print "not " unless ref($a) eq ref($b) && + ref($b) eq ref($c) && + ref($c) eq ref($d) && + ref($d) eq ref($u); +print "ok 5\n"; + +$a = URI::URL->new($u, $u); +$b = URI::URL->new($u, $uw); +$c = URI::URL->new($u, $uu); +$d = URI::URL->new($u, $str); + +print "not " unless ref($a) eq "URI::URL" && + ref($b) eq "URI::URL" && + ref($c) eq "URI::URL" && + ref($d) eq "URI::URL"; +print "ok 6\n"; @@ -0,0 +1,38 @@ +use strict; +use warnings; + +print "1..8\n"; + +use URI; + +my $u = URI->new("<mms://66.250.188.13/KFOG_FM>"); + +#print "$u\n"; +print "not " unless $u eq "mms://66.250.188.13/KFOG_FM"; +print "ok 1\n"; + +print "not " unless $u->port == 1755; +print "ok 2\n"; + +# play with port +my $old = $u->port(8755); +print "not " unless $old == 1755 && $u eq "mms://66.250.188.13:8755/KFOG_FM"; +print "ok 3\n"; + +$u->port(1755); +print "not " unless $u eq "mms://66.250.188.13:1755/KFOG_FM"; +print "ok 4\n"; + +$u->port(""); +print "not " unless $u eq "mms://66.250.188.13:/KFOG_FM" && $u->port == 1755; +print "ok 5\n"; + +$u->port(undef); +print "not " unless $u eq "mms://66.250.188.13/KFOG_FM"; +print "ok 6\n"; + +print "not " unless $u->host eq "66.250.188.13"; +print "ok 7\n"; + +print "not " unless $u->path eq "/KFOG_FM"; +print "ok 8\n"; diff --git a/t/news.t b/t/news.t new file mode 100644 index 0000000..a009a9e --- /dev/null +++ b/t/news.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +print "1..7\n"; + +use URI; + +my $u = URI->new("news:comp.lang.perl.misc"); + +print "not " unless $u->group eq "comp.lang.perl.misc" && + !defined($u->message) && + $u->port == 119 && + $u eq "news:comp.lang.perl.misc"; +print "ok 1\n"; + + +$u->host("news.online.no"); +print "not " unless $u->group eq "comp.lang.perl.misc" && + $u->port == 119 && + $u eq "news://news.online.no/comp.lang.perl.misc"; +print "ok 2\n"; + +$u->group("no.perl", 1 => 10); +print "not " unless $u eq "news://news.online.no/no.perl/1-10"; +print "ok 3\n"; + +my @g = $u->group; +#print "G: @g\n"; +print "not " unless @g == 3 && "@g" eq "no.perl 1 10"; +print "ok 4\n"; + +$u->message('42@g.aas.no'); +#print "$u\n"; +print "not " unless $u->message eq '42@g.aas.no' && + !defined($u->group) && + $u eq 'news://news.online.no/42@g.aas.no'; +print "ok 5\n"; + + +$u = URI->new("nntp:no.perl"); +print "not " unless $u->group eq "no.perl" && + $u->port == 119; +print "ok 6\n"; + +$u = URI->new("snews://snews.online.no/no.perl"); + +print "not " unless $u->group eq "no.perl" && + $u->host eq "snews.online.no" && + $u->port == 563; +print "ok 7\n"; + diff --git a/t/num_eq.t b/t/num_eq.t new file mode 100644 index 0000000..066d84c --- /dev/null +++ b/t/num_eq.t @@ -0,0 +1,16 @@ +# Test URI's overloading of numeric comparison for checking object +# equality + +use strict; +use warnings; +use Test::More 'no_plan'; + +use URI; + +my $uri1 = URI->new("http://foo.com"); +my $uri2 = URI->new("http://foo.com"); + +# cmp_ok() has a bug/misfeature where it strips overloading +# before doing the comparison. So use a regular ok(). +ok $uri1 == $uri1, "=="; +ok $uri1 != $uri2, "!="; diff --git a/t/old-absconf.t b/t/old-absconf.t new file mode 100644 index 0000000..536f4d7 --- /dev/null +++ b/t/old-absconf.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +print "1..6\n"; + +use URI::URL qw(url); + +# Test configuration via some global variables. + +$URI::URL::ABS_REMOTE_LEADING_DOTS = 1; +$URI::URL::ABS_ALLOW_RELATIVE_SCHEME = 1; + +my $u1 = url("../../../../abc", "http://web/a/b"); + +print "not " unless $u1->abs->as_string eq "http://web/abc"; +print "ok 1\n"; + +{ + local $URI::URL::ABS_REMOTE_LEADING_DOTS; + print "not " unless $u1->abs->as_string eq "http://web/../../../abc"; + print "ok 2\n"; +} + + +$u1 = url("http:../../../../abc", "http://web/a/b"); +print "not " unless $u1->abs->as_string eq "http://web/abc"; +print "ok 3\n"; + +{ + local $URI::URL::ABS_ALLOW_RELATIVE_SCHEME; + print "not " unless $u1->abs->as_string eq "http:../../../../abc"; + print "ok 4\n"; + print "not " unless $u1->abs(undef,1)->as_string eq "http://web/abc"; + print "ok 5\n"; +} + +print "not " unless $u1->abs(undef,0)->as_string eq "http:../../../../abc"; +print "ok 6\n"; diff --git a/t/old-base.t b/t/old-base.t new file mode 100644 index 0000000..77b562b --- /dev/null +++ b/t/old-base.t @@ -0,0 +1,978 @@ +use strict; +use warnings; + +use Test::More; +use URI::URL qw(url); +use URI::Escape qw(uri_escape uri_unescape); +use File::Temp 'tempdir'; + +# want compatibility +use URI::file; +$URI::file::DEFAULT_AUTHORITY = undef; + + +package main; + +# Must ensure that there is no relative paths in @INC because we will +# chdir in the newlocal tests. +unless ($^O eq "MacOS") { +chomp(my $pwd = ($^O =~ /mswin32/i ? `cd` : $^O eq 'VMS' ? `show default` : `pwd`)); +if ($^O eq 'VMS') { + $pwd =~ s#^\s+##; + $pwd = VMS::Filespec::unixpath($pwd); + $pwd =~ s#/$##; +} +for (@INC) { + my $x = $_; + $x = VMS::Filespec::unixpath($x) if $^O eq 'VMS'; + next if $x =~ m|^/| or $^O =~ /os2|mswin32/i + and $x =~ m#^(\w:[\\/]|[\\/]{2})#; + note "Turn lib path $x into $pwd/$x\n"; + $_ = "$pwd/$x"; + +} +} + +$| = 1; + +# Do basic tests first. + +note "Self tests for URI::URL version $URI::URL::VERSION...\n"; + +subtest 'scheme tests' => \&scheme_parse_test; + +subtest 'parts test' => \&parts_test; + +subtest 'escape test' => \&escape_test; + +subtest 'newlocal test' => \&newlocal_test; + +subtest 'Test relative/absolute URI::URL parsing' => \&absolute_test; + +subtest 'eq test' => \&eq_test; + +# Let's test making our own things +URI::URL::strict(0); +# This should work after URI::URL::strict(0) +my $url = new URI::URL "x-myscheme:something"; +# Since no implementor is registered for 'x-myscheme' then it will +# be handled by the URI::URL::_generic class +is($url->as_string, 'x-myscheme:something', ref($url) . '->as_string'); +is($url->path, 'something', ref($url) . '->path'); +URI::URL::strict(1); + +=comment + +# Let's try to make our URL subclass +{ + package MyURL; + @ISA = URI::URL::implementor(); + + sub _parse { + my($self, $init) = @_; + $self->URI::URL::_generic::_parse($init, qw(netloc path)); + } + + sub foo { + my $self = shift; + print ref($self)."->foo called for $self\n"; + } +} +# Let's say that it implements the 'x-a+b.c' scheme (alias 'x-foo') +URI::URL::implementor('x-a+b.c', 'MyURL'); +URI::URL::implementor('x-foo', 'MyURL'); + +# Now we are ready to try our new URL scheme +$url = new URI::URL 'x-a+b.c://foo/bar;a?b'; +is($url->as_string, 'x-a+b.c://foo/bar;a?b', ref($url) . '->as_string'); +is($url->path, '/bar;a?b', ref($url) . '->path'); +$url->foo; +$newurl = new URI::URL 'xxx', $url; +$newurl->foo; +$url = new URI::URL 'yyy', 'x-foo:'; +$url->foo; + +=cut + +# Test the new wash&go constructor +is(url("../foo.html", "http://www.sn.no/a/b")->abs->as_string, + 'http://www.sn.no/foo.html', 'wash&go'); + +note "URI::URL version $URI::URL::VERSION ok\n"; + +done_testing; +exit 0; + + + + +##################################################################### +# +# scheme_parse_test() +# +# test parsing and retrieval methods + +sub scheme_parse_test { + + my $tests = { + 'hTTp://web1.net/a/b/c/welcome#intro' + => { 'scheme'=>'http', 'host'=>'web1.net', 'port'=>80, + 'path'=>'/a/b/c/welcome', 'frag'=>'intro','query'=>undef, + 'epath'=>'/a/b/c/welcome', 'equery'=>undef, + 'params'=>undef, 'eparams'=>undef, + 'as_string'=>'http://web1.net/a/b/c/welcome#intro', + 'full_path' => '/a/b/c/welcome' }, + + 'http://web:1/a?query+text' + => { 'scheme'=>'http', 'host'=>'web', 'port'=>1, + 'path'=>'/a', 'frag'=>undef, 'query'=>'query+text' }, + + 'http://web.net/' + => { 'scheme'=>'http', 'host'=>'web.net', 'port'=>80, + 'path'=>'/', 'frag'=>undef, 'query'=>undef, + 'full_path' => '/', + 'as_string' => 'http://web.net/' }, + + 'http://web.net' + => { 'scheme'=>'http', 'host'=>'web.net', 'port'=>80, + 'path'=>'/', 'frag'=>undef, 'query'=>undef, + 'full_path' => '/', + 'as_string' => 'http://web.net/' }, + + 'http:0' + => { 'scheme'=>'http', 'path'=>'0', 'query'=>undef, + 'as_string'=>'http:0', 'full_path'=>'0', }, + + 'http:/0?0' + => { 'scheme'=>'http', 'path'=>'/0', 'query'=>'0', + 'as_string'=>'http:/0?0', 'full_path'=>'/0?0', }, + + 'http://0:0/0/0;0?0#0' + => { 'scheme'=>'http', 'host'=>'0', 'port'=>'0', + 'path' => '/0/0', 'query'=>'0', 'params'=>'0', + 'netloc'=>'0:0', + 'frag'=>0, 'as_string'=>'http://0:0/0/0;0?0#0' }, + + 'ftp://0%3A:%40@h:0/0?0' + => { 'scheme'=>'ftp', 'user'=>'0:', 'password'=>'@', + 'host'=>'h', 'port'=>'0', 'path'=>'/0?0', + 'query'=>'0', params=>undef, + 'netloc'=>'0%3A:%40@h:0', + 'as_string'=>'ftp://0%3A:%40@h:0/0?0' }, + + 'ftp://usr:pswd@web:1234/a/b;type=i' + => { 'host'=>'web', 'port'=>1234, 'path'=>'/a/b', + 'user'=>'usr', 'password'=>'pswd', + 'params'=>'type=i', + 'as_string'=>'ftp://usr:pswd@web:1234/a/b;type=i' }, + + 'ftp://host/a/b' + => { 'host'=>'host', 'port'=>21, 'path'=>'/a/b', + 'user'=>'anonymous', + 'as_string'=>'ftp://host/a/b' }, + + 'file://host/fseg/fs?g/fseg' + # don't escape ? for file: scheme + => { 'host'=>'host', 'path'=>'/fseg/fs', + 'as_string'=>'file://host/fseg/fs?g/fseg' }, + + 'gopher://host' + => { 'gtype'=>'1', 'as_string' => 'gopher://host', }, + + 'gopher://host/' + => { 'gtype'=>'1', 'as_string' => 'gopher://host/', }, + + 'gopher://gopher/2a_selector' + => { 'gtype'=>'2', 'selector'=>'a_selector', + 'as_string' => 'gopher://gopher/2a_selector', }, + + 'mailto:libwww-perl@ics.uci.edu' + => { 'address' => 'libwww-perl@ics.uci.edu', + 'encoded822addr'=> 'libwww-perl@ics.uci.edu', +# 'user' => 'libwww-perl', +# 'host' => 'ics.uci.edu', + 'as_string' => 'mailto:libwww-perl@ics.uci.edu', }, + + 'news:*' + => { 'groupart'=>'*', 'group'=>'*', as_string=>'news:*' }, + 'news:comp.lang.perl' + => { 'group'=>'comp.lang.perl' }, + 'news:perl-faq/module-list-1-794455075@ig.co.uk' + => { 'article'=> + 'perl-faq/module-list-1-794455075@ig.co.uk' }, + + 'nntp://news.com/comp.lang.perl/42' + => { 'group'=>'comp.lang.perl', }, #'digits'=>42 }, + + 'telnet://usr:pswd@web:12345/' + => { 'user'=>'usr', 'password'=>'pswd', 'host'=>'web' }, + 'rlogin://aas@a.sn.no' + => { 'user'=>'aas', 'host'=>'a.sn.no' }, +# 'tn3270://aas@ibm' +# => { 'user'=>'aas', 'host'=>'ibm', +# 'as_string'=>'tn3270://aas@ibm/'}, + +# 'wais://web.net/db' +# => { 'database'=>'db' }, +# 'wais://web.net/db?query' +# => { 'database'=>'db', 'query'=>'query' }, +# 'wais://usr:pswd@web.net/db/wt/wp' +# => { 'database'=>'db', 'wtype'=>'wt', 'wpath'=>'wp', +# 'password'=>'pswd' }, + }; + + foreach my $url_str (sort keys %$tests ){ + note "Testing '$url_str'\n"; + my $url = new URI::URL $url_str; + my $tests = $tests->{$url_str}; + while( my ($method, $exp) = each %$tests ){ + is($url->$method, $exp, ref($url) . "->$method"); + } + } +} + + +##################################################################### +# +# parts_test() (calls netloc_test test) +# +# Test individual component part access functions +# +sub parts_test { + + # test storage part access/edit methods (netloc, user, password, + # host and port are tested by &netloc_test) + + $url = new URI::URL 'file://web/orig/path'; + $url->scheme('http'); + $url->path('1info'); + $url->query('key words'); + $url->frag('this'); + is($url->as_string, 'http://web/1info?key%20words#this', ref($url) . '->as_string'); + + $url->epath('%2f/%2f'); + $url->equery('a=%26'); + is($url->full_path, '/%2f/%2f?a=%26', ref($url) . '->full_path'); + + # At this point it should be impossible to access the members path() + # and query() without complaints. + eval { my $p = $url->path; note "Path is $p\n"; }; + fail "Path exception failed" unless $@; + eval { my $p = $url->query; note "Query is $p\n"; }; + fail "Query exception failed" unless $@; + + # but we should still be able to set it + $url->path("howdy"); + is($url->as_string, 'http://web/howdy?a=%26#this', ref($url) . '->as_string'); + + # Test the path_components function + $url = new URI::URL 'file:%2f/%2f'; + my $p; + $p = join('-', $url->path_components); + fail "\$url->path_components returns '$p', expected '/-/'" + unless $p eq "/-/"; + $url->host("localhost"); + $p = join('-', $url->path_components); + fail "\$url->path_components returns '$p', expected '-/-/'" + unless $p eq "-/-/"; + $url->epath("/foo/bar/"); + $p = join('-', $url->path_components); + fail "\$url->path_components returns '$p', expected '-foo-bar-'" + unless $p eq "-foo-bar-"; + $url->path_components("", "/etc", "\0", "..", "øse", ""); + is($url->full_path, '/%2Fetc/%00/../%F8se/', ref($url) . '->full_path'); + + # Setting undef + $url = new URI::URL 'http://web/p;p?q#f'; + $url->epath(undef); + $url->equery(undef); + $url->eparams(undef); + $url->frag(undef); + is($url->as_string, 'http://web', ref($url) . '->as_string'); + + # Test http query access methods + $url->keywords('dog'); + is($url->as_string, 'http://web?dog', ref($url) . '->as_string'); + $url->keywords(qw(dog bones)); + is($url->as_string, 'http://web?dog+bones', ref($url) . '->as_string'); + $url->keywords(0,0); + is($url->as_string, 'http://web?0+0', ref($url) . '->as_string'); + $url->keywords('dog', 'bones', '#+='); + is($url->as_string, 'http://web?dog+bones+%23%2B%3D', ref($url) . '->as_string'); + $a = join(":", $url->keywords); + is($a, 'dog:bones:#+=', "\$url->keywords"); + # calling query_form is an error +# eval { my $foo = $url->query_form; }; +# fail "\$url->query_form should croak since query contains keywords not a form." +# unless $@; + + $url->query_form(a => 'foo', b => 'bar'); + is($url->as_string, 'http://web?a=foo&b=bar', ref($url) . '->as_string'); + my %a = $url->query_form; + is_deeply( + \%a, + { a => 'foo', b => 'bar' }, + "\$url->query_form", + ); + + $url->query_form(a => undef, a => 'foo', '&=' => '&=+'); + is($url->as_string, 'http://web?a=&a=foo&%26%3D=%26%3D%2B', ref($url) . '->as_string'); + + my @a = $url->query_form; + is(scalar(@a), 6, 'length'); + is_deeply( + \@a, + [ + 'a', '', + 'a', 'foo', + '&=', '&=+', + ], + 'query_form', + ); + + # calling keywords is an error +# eval { my $foo = $url->keywords; }; +# die "\$url->keywords should croak when query is a form" +# unless $@; + # Try this odd one + $url->equery('&=&=b&a=&a&a=b=c&&a=b'); + @a = $url->query_form; + #note join(":", @a), "\n"; + is(scalar(@a), 16, 'length'); + ok( + $a[4] eq "" && $a[5] eq "b" && $a[10] eq "a" && $a[11] eq "b=c", + 'sequence', + ); + + # Try array ref values in the key value pairs + $url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']); + is($url->as_string, 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo', ref($url) . '->as_string'); + + subtest 'netloc_test' => \&netloc_test; + subtest 'port_test' => \&port_test; + + $url->query(undef); + is($url->query, undef, ref($url) . '->as_string'); + + $url = new URI::URL 'gopher://gopher/'; + $url->port(33); + $url->gtype("3"); + $url->selector("S"); + $url->search("query"); + is($url->as_string, 'gopher://gopher:33/3S%09query', ref($url) . '->as_string'); + + $url->epath("45%09a"); + is($url->gtype, '4', ref($url) . '->as_string'); + is($url->selector, '5', ref($url) . '->as_string'); + is($url->search, 'a', ref($url) . '->as_string'); + is($url->string, undef, ref($url) . '->as_string'); + is($url->path, "/45\ta", ref($url) . '->as_string'); +# $url->path("00\t%09gisle"); +# is($url->search '%09gisle', ref($url) . '->search'); + + # Let's test som other URL schemes + $url = new URI::URL 'news:'; + $url->group("comp.lang.perl.misc"); + is($url->as_string, 'news:comp.lang.perl.misc', ref($url) . '->as_string'); + $url->article('<1234@a.sn.no>'); + is($url->as_string, 'news:1234@a.sn.no', ref($url) . '->as_string: "<" and ">" are gone'); + + # This one should be illegal + eval { $url->article("no.perl"); }; + die "This one should really complain" unless $@; + +# $url = new URI::URL 'mailto:'; +# $url->user("aas"); +# $url->host("a.sn.no"); +# is($url->as_string, 'mailto:aas@a.sn.no', ref($url) . '->as_string'); +# $url->address('foo@bar'); +# is($url->host, 'bar', ref($url) . '->as_string'); +# is($url->user, 'foo', ref($url) . '->as_string'); + +# $url = new URI::URL 'wais://host/database/wt/wpath'; +# $url->database('foo'); +# is($url->as_string, 'wais://host/foo/wt/wpath', ref($url) . '->as_string'); +# $url->wtype('bar'); +# is($url->as_string, 'wais://host/foo/bar/wpath', ref($url) . '->as_string'); + + # Test crack method for various URLs + my(@crack, $crack); + @crack = URI::URL->new("http://host/path;param?query#frag")->crack; + is(scalar(@crack), 9, '9 elements'); + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; + is($crack, "http*UNDEF*UNDEF*host*80*/path*param*query*frag", 'crack result'); + + @crack = URI::URL->new("foo/bar", "ftp://aas\@ftp.sn.no/")->crack; + is(scalar(@crack), 9, '9 elements'); + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; +# die "Bad crack result" unless +# $crack eq "ftp*UNDEF*UNDEF*UNDEF*21*foo/bar*UNDEF*UNDEF*UNDEF"; + + @crack = URI::URL->new('ftp://u:p@host/q?path')->crack; + is(scalar(@crack), 9, '9 elements'); + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; + is($crack, "ftp*u*p*host*21*/q?path*UNDEF*path*UNDEF", 'crack result'); + + @crack = URI::URL->new("ftp://ftp.sn.no/pub")->crack; # Test anon ftp + is(scalar(@crack), 9, '9 elements'); + ok($crack[2], "passwd in anonymous crack"); + $crack[2] = 'passwd'; # easier to test when we know what it is + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; + is($crack, "ftp*anonymous*passwd*ftp.sn.no*21*/pub*UNDEF*UNDEF*UNDEF", 'crack result'); + + @crack = URI::URL->new('mailto:aas@sn.no')->crack; + is(scalar(@crack), 9, '9 elements'); + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; +# die "Bad crack result" unless +# $crack eq "mailto*aas*UNDEF*sn.no*UNDEF*aas\@sn.no*UNDEF*UNDEF*UNDEF"; + + @crack = URI::URL->new('news:comp.lang.perl.misc')->crack; + is(scalar(@crack), 9, '9 elements'); + $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack); + note "Cracked result: $crack"; + is($crack, "news*UNDEF*UNDEF*UNDEF*119*comp.lang.perl.misc*UNDEF*UNDEF*UNDEF", 'crack result'); +} + +# +# netloc_test() +# +# Test automatic netloc synchronisation +# +sub netloc_test { + + my $url = new URI::URL 'ftp://anonymous:p%61ss@håst:12345'; + is($url->user, 'anonymous', ref($url) . '->as_string'); + is($url->password, 'pass', ref($url) . '->as_string'); + is($url->host, 'xn--hst-ula', ref($url) . '->as_string'); + is($url->port, 12345, ref($url) . '->as_string'); + # Can't really know how netloc is represented since it is partially escaped + #is($url->netloc, 'anonymous:pass@hst:12345', ref($url) . '->as_string'); + is($url->as_string, 'ftp://anonymous:pass@xn--hst-ula:12345', ref($url) . '->as_string'); + + # The '0' is sometimes tricky to get right + $url->user(0); + $url->password(0); + $url->host(0); + $url->port(0); + is($url->netloc, '0:0@0:0', ref($url) . '->as_string'); + $url->host(undef); + is($url->netloc, '0:0@:0', ref($url) . '->as_string'); + $url->host('h'); + $url->user(undef); + is($url->netloc, ':0@h:0', ref($url) . '->as_string'); + $url->user(''); + is($url->netloc, ':0@h:0', ref($url) . '->as_string'); + $url->password(''); + is($url->netloc, ':@h:0', ref($url) . '->as_string'); + $url->user('foo'); + is($url->netloc, 'foo:@h:0', ref($url) . '->as_string'); + + # Let's try a simple one + $url->user('nemo'); + $url->password('p2'); + $url->host('hst2'); + $url->port(2); + is($url->netloc, 'nemo:p2@hst2:2', ref($url) . '->as_string'); + + $url->user(undef); + $url->password(undef); + $url->port(undef); + is($url->netloc, 'hst2', ref($url) . '->as_string'); + is($url->port, '21', ref($url) . '->as_string'); # the default ftp port + + $url->port(21); + is($url->netloc, 'hst2:21', ref($url) . '->as_string'); + + # Let's try some reserved chars + $url->user("@"); + $url->password(":-#-;-/-?"); + is($url->as_string, 'ftp://%40::-%23-;-%2F-%3F@hst2:21', ref($url) . '->as_string'); + +} + +# +# port_test() +# +# Test port behaviour +# +sub port_test { + $url = URI::URL->new('http://foo/root/dir/'); + my $port = $url->port; + is($port, 80, 'port'); + is($url->as_string, 'http://foo/root/dir/', 'string'); + + $url->port(8001); + $port = $url->port; + is($port, 8001, 'port'); + is($url->as_string, 'http://foo:8001/root/dir/', 'string'); + + $url->port(80); + $port = $url->port; + is($port, 80, 'port'); + is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); + + $url->port(8001); + $url->port(undef); + $port = $url->port; + is($port, 80, 'port'); + is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); +} + + +##################################################################### +# +# escape_test() +# +# escaping functions + +sub escape_test { + # supply escaped URL + $url = new URI::URL 'http://web/this%20has%20spaces'; + # check component is unescaped + is($url->path, '/this has spaces', ref($url) . '->as_string'); + + # modify the unescaped form + $url->path('this ALSO has spaces'); + # check whole url is escaped + is($url->as_string, + 'http://web/this%20ALSO%20has%20spaces', ref($url) . '->as_string'); + + $url = new URI::URL uri_escape('http://web/try %?#" those'); + is($url->as_string, + 'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those', ref($url) . '->as_string'); + + my $all = pack('C*',0..255); + my $esc = uri_escape($all); + my $new = uri_unescape($esc); + is($all, $new, "uri_escape->uri_unescape"), + + $url->path($all); + is($url->full_path, q(%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20!%22%23$%&'()*+,-./0123456789:;%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ[%5C]%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF), ref($url) . '->as_string'); + + # test escaping uses uppercase (preferred by rfc1837) + $url = new URI::URL 'file://h/'; + $url->path(chr(0x7F)); + is($url->as_string, 'file://h/%7F', ref($url) . '->as_string'); + + return; + # reserved characters differ per scheme + + ## XXX is this '?' allowed to be unescaped + $url = new URI::URL 'file://h/test?ing'; + is($url->path, '/test?ing', ref($url) . '->as_string'); + + $url = new URI::URL 'file://h/'; + $url->epath('question?mark'); + is($url->as_string, 'file://h/question?mark', ref($url) . '->as_string'); + # XXX Why should this be any different??? + # Perhaps we should not expect too much :-) + $url->path('question?mark'); + is($url->as_string, 'file://h/question%3Fmark', ref($url) . '->as_string'); + + # See what happens when set different elements to this ugly sting + my $reserved = ';/?:@&=#%'; + $url->path($reserved . "foo"); + is($url->as_string, 'file://h/%3B/%3F%3A%40%26%3D%23%25foo', ref($url) . '->as_string'); + + $url->scheme('http'); + $url->path(''); + is($url->as_string, 'http://h/', ref($url) . '->as_string'); + $url->query($reserved); + $url->params($reserved); + $url->frag($reserved); + is($url->as_string, 'http://h/;%3B%2F%3F%3A%40&=%23%25?%3B%2F%3F%3A%40&=%23%25#;/?:@&=#%', ref($url) . '->as_string'); + + my $str = $url->as_string; + $url = new URI::URL $str; + die "URL changed" if $str ne $url->as_string; + + $url = new URI::URL 'ftp:foo'; + $url->user($reserved); + $url->host($reserved); + is($url->as_string, 'ftp://%3B%2F%3F%3A%40%26%3D%23%25@%3B%2F%3F%3A%40%26%3D%23%25/foo', ref($url) . '->as_string'); + +} + + +##################################################################### +# +# newlocal_test() +# + +sub newlocal_test { + return 1 if $^O eq "MacOS"; + + my $isMSWin32 = ($^O =~ /MSWin32/i); + my $pwd = ($isMSWin32 ? 'cd' : + ($^O eq 'qnx' ? '/usr/bin/fullpath -t' : + ($^O eq 'VMS' ? 'show default' : + (-e '/bin/pwd' ? '/bin/pwd' : 'pwd')))); + my $tmpdir = tempdir(); + if ( $^O eq 'qnx' ) { + $tmpdir = `/usr/bin/fullpath -t $tmpdir`; + chomp $tmpdir; + } + $tmpdir = '/sys$scratch' if $^O eq 'VMS'; + $tmpdir =~ tr|\\|/|; + + my $savedir = `$pwd`; # we don't use Cwd.pm because we want to check + # that it get require'd correctly by URL.pm + chomp $savedir; + if ($^O eq 'VMS') { + $savedir =~ s#^\s+##; + $savedir = VMS::Filespec::unixpath($savedir); + $savedir =~ s#/$##; + } + + # cwd + chdir($tmpdir) or die $!; + my $dir = `$pwd`; $dir =~ tr|\\|/|; + chomp $dir; + if ($^O eq 'VMS') { + $dir =~ s#^\s+##; + $dir = VMS::Filespec::unixpath($dir); + $dir =~ s#/$##; + } + $dir = uri_escape($dir, ':'); + $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; + $url = newlocal URI::URL; + my $ss = $isMSWin32 ? '//' : (($dir =~ m,^/,) ? '' : '///' ); + is($url->as_string, URI::URL->new("file:$ss$dir/")->as_string, ref($url) . '->as_string'); + + note "Local directory is ". $url->local_path . "\n"; + + if ($^O ne 'VMS') { + # absolute dir + chdir('/') or die $!; + $url = newlocal URI::URL '/usr/'; + is($url->as_string, 'file:/usr/', ref($url) . '->as_string'); + + # absolute file + $url = newlocal URI::URL '/vmunix'; + is($url->as_string, 'file:/vmunix', ref($url) . '->as_string'); + } + + # relative file + chdir($tmpdir) or fail $!; + $dir = `$pwd`; $dir =~ tr|\\|/|; + chomp $dir; + if ($^O eq 'VMS') { + $dir =~ s#^\s+##; + $dir = VMS::Filespec::unixpath($dir); + $dir =~ s#/$##; + } + $dir = uri_escape($dir, ':'); + $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; + $url = newlocal URI::URL 'foo'; + is($url->as_string, "file:$ss$dir/foo", ref($url) . '->as_string'); + + # relative dir + chdir($tmpdir) or fail $!; + $dir = `$pwd`; $dir =~ tr|\\|/|; + chomp $dir; + if ($^O eq 'VMS') { + $dir =~ s#^\s+##; + $dir = VMS::Filespec::unixpath($dir); + $dir =~ s#/$##; + } + $dir = uri_escape($dir, ':'); + $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; + $url = newlocal URI::URL 'bar/'; + is($url->as_string, "file:$ss$dir/bar/", ref($url) . '->as_string'); + + # 0 + if ($^O ne 'VMS') { + chdir('/') or fail $!; + $dir = `$pwd`; $dir =~ tr|\\|/|; + chomp $dir; + $dir = uri_escape($dir, ':'); + $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; + $url = newlocal URI::URL '0'; + is($url->as_string, "file:$ss${dir}0", ref($url) . '->as_string'); + } + + # Test access methods for file URLs + $url = new URI::URL 'file:/c:/dos'; + is($url->dos_path, 'C:\\DOS', ref($url) . '->as_string'); + is($url->unix_path, '/c:/dos', ref($url) . '->as_string'); + #is($url->vms_path, '[C:]DOS', ref($url) . '->as_string'); + is($url->mac_path, undef, ref($url) . '->as_string'); + + $url = new URI::URL 'file:/foo/bar'; + is($url->unix_path, '/foo/bar', ref($url) . '->as_string'); + is($url->mac_path, 'foo:bar', ref($url) . '->as_string'); + + # Some edge cases +# $url = new URI::URL 'file:'; +# is($url->unix_path, '/', ref($url) . '->as_string'); + $url = new URI::URL 'file:/'; + is($url->unix_path, '/', ref($url) . '->as_string'); + $url = new URI::URL 'file:.'; + is($url->unix_path, '.', ref($url) . '->as_string'); + $url = new URI::URL 'file:./foo'; + is($url->unix_path, './foo', ref($url) . '->as_string'); + $url = new URI::URL 'file:0'; + is($url->unix_path, '0', ref($url) . '->as_string'); + $url = new URI::URL 'file:../../foo'; + is($url->unix_path, '../../foo', ref($url) . '->as_string'); + $url = new URI::URL 'file:foo/../bar'; + is($url->unix_path, 'foo/../bar', ref($url) . '->as_string'); + + # Relative files + $url = new URI::URL 'file:foo/b%61r/Note.txt'; + is($url->unix_path, 'foo/bar/Note.txt', ref($url) . '->as_string'); + is($url->mac_path, ':foo:bar:Note.txt', ref($url) . '->as_string'); + is($url->dos_path, 'FOO\\BAR\\NOTE.TXT', ref($url) . '->as_string'); + #is($url->vms_path', '[.FOO.BAR]NOTE.TXT', ref($url) . '->as_string'); + + # The VMS path found in RFC 1738 (section 3.10) + $url = new URI::URL 'file://vms.host.edu/disk$user/my/notes/note12345.txt'; +# is($url->vms_path, 'DISK$USER:[MY.NOTES]NOTE12345.TXT', ref($url) . '->as_string'); +# is($url->mac_path, 'disk$user:my:notes:note12345.txt', ref($url) . '->as_string'); + + chdir($savedir) or fail $!; +} + + +##################################################################### +# +# absolute_test() +# +sub absolute_test { + # Tests from draft-ietf-uri-relative-url-06.txt + # Copied verbatim from the draft, parsed below + + @URI::URL::g::ISA = qw(URI::URL::_generic); # for these tests + + my $base = 'http://a/b/c/d;p?q#f'; + + my $absolute_tests = <<EOM; +5.1. Normal Examples + + g:h = <URL:g:h> + g = <URL:http://a/b/c/g> + ./g = <URL:http://a/b/c/g> + g/ = <URL:http://a/b/c/g/> + /g = <URL:http://a/g> + //g = <URL:http://g> +# ?y = <URL:http://a/b/c/d;p?y> + g?y = <URL:http://a/b/c/g?y> + g?y/./x = <URL:http://a/b/c/g?y/./x> + #s = <URL:http://a/b/c/d;p?q#s> + g#s = <URL:http://a/b/c/g#s> + g#s/./x = <URL:http://a/b/c/g#s/./x> + g?y#s = <URL:http://a/b/c/g?y#s> + # ;x = <URL:http://a/b/c/d;x> + g;x = <URL:http://a/b/c/g;x> + g;x?y#s = <URL:http://a/b/c/g;x?y#s> + . = <URL:http://a/b/c/> + ./ = <URL:http://a/b/c/> + .. = <URL:http://a/b/> + ../ = <URL:http://a/b/> + ../g = <URL:http://a/b/g> + ../.. = <URL:http://a/> + ../../ = <URL:http://a/> + ../../g = <URL:http://a/g> + +5.2. Abnormal Examples + + Although the following abnormal examples are unlikely to occur + in normal practice, all URL parsers should be capable of resolving + them consistently. Each example uses the same base as above. + + An empty reference resolves to the complete base URL: + + <> = <URL:http://a/b/c/d;p?q#f> + + Parsers must be careful in handling the case where there are more + relative path ".." segments than there are hierarchical levels in + the base URL's path. Note that the ".." syntax cannot be used to + change the <net_loc> of a URL. + + ../../../g = <URL:http://a/../g> + ../../../../g = <URL:http://a/../../g> + + Similarly, parsers must avoid treating "." and ".." as special + when they are not complete components of a relative path. + + /./g = <URL:http://a/./g> + /../g = <URL:http://a/../g> + g. = <URL:http://a/b/c/g.> + .g = <URL:http://a/b/c/.g> + g.. = <URL:http://a/b/c/g..> + ..g = <URL:http://a/b/c/..g> + + Less likely are cases where the relative URL uses unnecessary or + nonsensical forms of the "." and ".." complete path segments. + + ./../g = <URL:http://a/b/g> + ./g/. = <URL:http://a/b/c/g/> + g/./h = <URL:http://a/b/c/g/h> + g/../h = <URL:http://a/b/c/h> + + Finally, some older parsers allow the scheme name to be present in + a relative URL if it is the same as the base URL scheme. This is + considered to be a loophole in prior specifications of partial + URLs [1] and should be avoided by future parsers. + + http:g = <URL:http:g> + http: = <URL:http:> +EOM + # convert text to list like + # @absolute_tests = ( ['g:h' => 'g:h'], ...) + + my @absolute_tests; + for my $line (split("\n", $absolute_tests)) { + next unless $line =~ /^\s{6}/; + if ($line =~ /^\s+(\S+)\s*=\s*<URL:([^>]*)>/) { + my($rel, $abs) = ($1, $2); + $rel = '' if $rel eq '<>'; + push(@absolute_tests, [$rel, $abs]); + } + else { + warn "illegal line '$line'"; + } + } + + # add some extra ones for good measure + + push(@absolute_tests, ['x/y//../z' => 'http://a/b/c/x/y/z'], + ['1' => 'http://a/b/c/1' ], + ['0' => 'http://a/b/c/0' ], + ['/0' => 'http://a/0' ], +# ['%2e/a' => 'http://a/b/c/%2e/a'], # %2e is '.' +# ['%2e%2e/a' => 'http://a/b/c/%2e%2e/a'], + ); + + note " Relative + Base => Expected Absolute URL"; + note "================================================\n"; + for my $test (@absolute_tests) { + my($rel, $abs) = @$test; + my $abs_url = new URI::URL $abs; + my $abs_str = $abs_url->as_string; + + note sprintf(" %-10s + $base => %s", $rel, $abs); + my $u = new URI::URL $rel, $base; + my $got = $u->abs; + is($got->as_string, $abs_str, ref($url) . '->as_string'); + } + + # bug found and fixed in 1.9 by "J.E. Fritz" <FRITZ@gems.vcu.edu> + $base = new URI::URL 'http://host/directory/file'; + my $relative = new URI::URL 'file', $base; + my $result = $relative->abs; + + my ($a, $b) = ($base->path, $result->path); + is($a, $b, 'identity'); + + # Counter the expectation of least surprise, + # section 6 of the draft says the URL should + # be canonicalised, rather than making a simple + # substitution of the last component. + # Better doublecheck someone hasn't "fixed this bug" :-) + $base = new URI::URL 'http://host/dir1/../dir2/file'; + $relative = new URI::URL 'file', $base; + $result = $relative->abs; + is($result, 'http://host/dir2/file', 'URL canonicalised'); + + note "--------"; + # Test various other kinds of URLs and how they like to be absolutized + for (["http://abc/", "news:45664545", "http://abc/"], + ["news:abc", "http://abc/", "news:abc"], + ["abc", "file:/test?aas", "file:/abc"], +# ["gopher:", "", "gopher:"], +# ["?foo", "http://abc/a", "http://abc/a?foo"], + ["?foo", "file:/abc", "file:/abc?foo"], + ["#foo", "http://abc/a", "http://abc/a#foo"], + ["#foo", "file:a", "file:a#foo"], + ["#foo", "file:/a", "file:/a#foo"], + ["#foo", "file:/a", "file:/a#foo"], + ["#foo", "file://localhost/a", "file://localhost/a#foo"], + ['123@sn.no', "news:comp.lang.perl.misc", 'news:/123@sn.no'], + ['no.perl', 'news:123@sn.no', 'news:/no.perl'], + ['mailto:aas@a.sn.no', "http://www.sn.no/", 'mailto:aas@a.sn.no'], + + # Test absolutizing with old behaviour. + ['http:foo', 'http://h/a/b', 'http://h/a/foo'], + ['http:/foo', 'http://h/a/b', 'http://h/foo'], + ['http:?foo', 'http://h/a/b', 'http://h/a/b?foo'], + ['http:#foo', 'http://h/a/b', 'http://h/a/b#foo'], + ['http:?foo#bar','http://h/a/b', 'http://h/a/b?foo#bar'], + ['file:/foo', 'http://h/a/b', 'file:/foo'], + + ) + { + my($url, $base, $expected_abs) = @$_; + my $rel = new URI::URL $url, $base; + my $abs = $rel->abs($base, 1); + note sprintf(" %-12s+ $base => %s", $rel, $abs); + is($abs->as_string, $expected_abs, ref($url) . '->as_string'); + } + note "absolute test ok\n"; + + # Test relative function + for ( + ["http://abc/a", "http://abc", "a"], + ["http://abc/a", "http://abc/b", "a"], + ["http://abc/a?q", "http://abc/b", "a?q"], + ["http://abc/a;p", "http://abc/b", "a;p"], + ["http://abc/a", "http://abc/a/b/c/", "../../../a"], + ["http://abc/a/", "http://abc/a/", "./"], + ["http://abc/a#f", "http://abc/a", "#f"], + + ["file:/etc/motd", "file:/", "etc/motd"], + ["file:/etc/motd", "file:/etc/passwd", "motd"], + ["file:/etc/motd", "file:/etc/rc2.d/", "../motd"], + ["file:/etc/motd", "file:/usr/lib/doc", "../../etc/motd"], + ["file:", "file:/etc/", "../"], + ["file:foo", "file:/etc/", "../foo"], + + ["mailto:aas", "http://abc", "mailto:aas"], + + # Nicolai Langfeldt's original example + ["http://www.math.uio.no/doc/mail/top.html", + "http://www.math.uio.no/doc/linux/", "../mail/top.html"], + ) + { + my($abs, $base, $expect) = @$_; + my $rel = URI::URL->new($abs, $base)->rel; + is($rel->as_string, $expect, "url('$abs', '$base')->rel = '$expect'"); + } + note "relative test ok\n"; +} + + +sub eq_test +{ + my $u1 = new URI::URL 'http://abc.com:80/~smith/home.html'; + my $u2 = new URI::URL 'http://ABC.com/%7Esmith/home.html'; + my $u3 = new URI::URL 'http://ABC.com:/%7esmith/home.html'; + + # Test all permutations of these tree + ok($u1->eq($u2), "1: $u1 ne $u2"); + ok($u1->eq($u3), "2: $u1 ne $u3"); + ok($u2->eq($u1), "3: $u2 ne $u1"); + ok($u2->eq($u3), "4: $u2 ne $u3"); + ok($u3->eq($u1), "5: $u3 ne $u1"); + ok($u3->eq($u2), "6: $u3 ne $u2"); + + # Test empty path + my $u4 = new URI::URL 'http://www.sn.no'; + ok($u4->eq("HTTP://WWW.SN.NO:80/"), "7: $u4"); + ok(!$u4->eq("http://www.sn.no:81"),"8: $u4"); + + # Test mailto +# my $u5 = new URI::URL 'mailto:AAS@SN.no'; +# ok($u5->eq('mailto:aas@sn.no'), "9: $u5"); + + + # Test reserved char + my $u6 = new URI::URL 'ftp://ftp/%2Fetc'; + ok($u6->eq("ftp://ftp/%2fetc"), "10: $u6"); + ok(!$u6->eq("ftp://ftp://etc"), "11: $u6"); +} diff --git a/t/old-file.t b/t/old-file.t new file mode 100644 index 0000000..e1ab8f5 --- /dev/null +++ b/t/old-file.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use URI::file; +$URI::file::DEFAULT_AUTHORITY = undef; + +my @tests = ( +[ "file", "unix", "win32", "mac" ], +#---------------- ------------ --------------- -------------- +[ "file://localhost/foo/bar", + "!/foo/bar", "!\\foo\\bar", "!foo:bar", ], +[ "file:///foo/bar", + "!/foo/bar", "!\\foo\\bar", "!foo:bar", ], +[ "file:/foo/bar", "/foo/bar", "\\foo\\bar", "foo:bar", ], +[ "foo/bar", "foo/bar", "foo\\bar", ":foo:bar",], +[ "file://foo3445x/bar","!//foo3445x/bar", "\\\\foo3445x\\bar", "!foo3445x:bar"], +[ "file://a:/", "!//a:/", "!A:\\", undef], +[ "file:/", "/", "\\", undef], +[ "file://A:relative/", "!//A:relative/", "A:", undef], +[ ".", ".", ".", ":"], +[ "..", "..", "..", "::"], +[ "%2E", "!.", "!.", ":."], +[ "../%2E%2E", "!../..", "!..\\..", "::.."], +); +if ($^O eq "MacOS") { +my @extratests = ( +[ "../..", "../..", "..\\..", ":::"], +[ "../../", "../../", "..\\..\\", "!:::"], +[ "file:./foo.bar", "!./foo.bar", "!.\\foo.bar", "!:foo.bar"], +[ "file:/%2Ffoo/bar", undef, undef, "/foo:bar"], +[ "file:/.%2Ffoo/bar", undef, undef, "./foo:bar"], +[ "file:/fee/.%2Ffoo%2Fbar", undef, undef, "fee:./foo/bar"], +[ "file:/.%2Ffoo%2Fbar/", undef, undef, "./foo/bar:"], +[ "file:/.%2Ffoo%2Fbar", undef, undef, "!./foo/bar:"], +[ "file:/%2E%2E/foo", "!/../foo", "!\\..\\foo" , "..:foo"], +[ "file:/bar/%2E/foo", "!/bar/./foo", "!\\bar\\.\\foo", "bar:.:foo"], +[ "file:/foo/../bar", "/foo/../bar", "\\foo\\..\\bar", "foo::bar"], +[ "file:/a/b/../../c/d", "/a/b/../../c/d", "\\a\\b\\..\\..\\c\\d", "a:b:::c:d"], +); + push(@tests,@extratests); +} + +my @os = @{shift @tests}; +shift @os; # file + +my $num = @tests; +print "1..$num\n"; + +my $testno = 1; + +for my $t (@tests) { + my @t = @$t; + my $file = shift @t; + my $err; + + my $u = URI->new($file, "file"); + my $i = 0; + for my $os (@os) { + my $f = $u->file($os); + my $expect = $t[$i]; + $f = "<undef>" unless defined $f; + $expect = "<undef>" unless defined $expect; + my $loose; + $loose++ if $expect =~ s/^!//; + if ($expect ne $f) { + print "URI->new('$file', 'file')->file('$os') ne $expect, but $f\n"; + $err++; + } + if (defined($t[$i]) && !$loose) { + my $u2 = URI::file->new($t[$i], $os); + unless ($u2->as_string eq $file) { + print "URI::file->new('$t[$i]', '$os') ne $file, but $u2\n"; + $err++; + } + } + $i++; + } + print "not " if $err; + print "ok $testno\n"; + $testno++; +} diff --git a/t/old-relbase.t b/t/old-relbase.t new file mode 100644 index 0000000..3bd0ae8 --- /dev/null +++ b/t/old-relbase.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +print "1..5\n"; + +use URI::URL; + +# We used to have problems with URLs that used a base that was +# not absolute itself. + +my $u1 = url("/foo/bar", "http://www.acme.com/"); +my $u2 = url("../foo/", $u1); +my $u3 = url("zoo/foo", $u2); + +my $a1 = $u1->abs->as_string; +my $a2 = $u2->abs->as_string; +my $a3 = $u3->abs->as_string; + +print "$a1\n$a2\n$a3\n"; + +print "not " unless $a1 eq "http://www.acme.com/foo/bar"; +print "ok 1\n"; +print "not " unless $a2 eq "http://www.acme.com/foo/"; +print "ok 2\n"; +print "not " unless $a3 eq "http://www.acme.com/foo/zoo/foo"; +print "ok 3\n"; + +# We used to have problems with URI::URL as the base class :-( +my $u4 = url("foo", "URI::URL"); +my $a4 = $u4->abs; +print "$a4\n"; +print "not " unless $u4 eq "foo" && $a4 eq "uri:/foo"; +print "ok 4\n"; + +# Test new_abs for URI::URL objects +print "not " unless URI::URL->new_abs("foo", "http://foo/bar") eq "http://foo/foo"; +print "ok 5\n"; diff --git a/t/path-segments.t b/t/path-segments.t new file mode 100755 index 0000000..ea9b4fa --- /dev/null +++ b/t/path-segments.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 'no_plan'; + +use URI (); + +{ + my $u = URI->new("http://www.example.org/a/b/c"); + + is_deeply [$u->path_segments], ['', qw(a b c)], 'path_segments in list context'; + is $u->path_segments, '/a/b/c', 'path_segments in scalar context'; + + is_deeply [$u->path_segments('', qw(z y x))], ['', qw(a b c)], 'set path_segments in list context'; + is $u->path_segments('/i/j/k'), '/z/y/x', 'set path_segments in scalar context'; + + $u->path_segments('', qw(q r s)); + is $u->path_segments, '/q/r/s', 'set path_segments in void context'; +} + +{ + my $u = URI->new("http://www.example.org/abc"); + $u->path_segments('', '%', ';', '/'); + is $u->path_segments, '/%25/%3B/%2F', 'escaping special characters'; +} + +{ + my $u = URI->new("http://www.example.org/abc;param1;param2"); + my @ps = $u->path_segments; + isa_ok $ps[1], 'URI::_segment'; + $u->path_segments(@ps); + is $u->path_segments, '/abc;param1;param2', 'dealing with URI segments'; +} @@ -0,0 +1,50 @@ +use strict; +use warnings; + +print "1..8\n"; + +use URI; + +my $u = URI->new('pop://aas@pop.sn.no'); + +print "not " unless $u->user eq "aas" && + !defined($u->auth) && + $u->host eq "pop.sn.no" && + $u->port == 110 && + $u eq 'pop://aas@pop.sn.no'; +print "ok 1\n"; + +$u->auth("+APOP"); +print "not " unless $u->auth eq "+APOP" && + $u eq 'pop://aas;AUTH=+APOP@pop.sn.no'; +print "ok 2\n"; + +$u->user("gisle"); +print "not " unless $u->user eq "gisle" && + $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no'; +print "ok 3\n"; + +$u->port(4000); +print "not " unless $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no:4000'; +print "ok 4\n"; + +$u = URI->new("pop:"); +$u->host("pop.sn.no"); +$u->user("aas"); +$u->auth("*"); +print "not " unless $u eq 'pop://aas;AUTH=*@pop.sn.no'; +print "ok 5\n"; + +$u->auth(undef); +print "not " unless $u eq 'pop://aas@pop.sn.no'; +print "ok 6\n"; + +$u->user(undef); +print "not " unless $u eq 'pop://pop.sn.no'; +print "ok 7\n"; + +# Try some funny characters too +$u->user('får;k@l'); +print "not " unless $u->user eq 'får;k@l' && + $u eq 'pop://f%E5r%3Bk%40l@pop.sn.no'; +print "ok 8\n"; diff --git a/t/punycode.t b/t/punycode.t new file mode 100644 index 0000000..d1e3084 --- /dev/null +++ b/t/punycode.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use utf8; +use Test::More tests => 15; +use URI::_punycode qw(encode_punycode decode_punycode); + +my %RFC_3492 = ( + A => { + unicode => udecode("u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F"), + ascii => "egbpdaj6bu4bxfgehfvwxn", + }, + B => { + unicode => udecode("u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587"), + ascii => "ihqwcrb4cv8a8dqg056pqjye", + }, + E => { + unicode => udecode("u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 u+05D1 u+05E8 u+05D9 u+05EA"), + ascii => "4dbcagdahymbxekheh6e0a7fei0b", + }, + J => { + unicode => udecode("U+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 u+0062 u+006C u+0061 u+0072 u+0065 u+006E U+0045 u+0073 u+0070 u+0061 u+00F1 u+006F u+006C"), + ascii => "PorqunopuedensimplementehablarenEspaol-fmd56a", + }, + K => { + unicode => udecode("U+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 U+0056 u+0069 u+1EC7 u+0074"), + ascii => "TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g", + }, + O => { + unicode => udecode("u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032"), + ascii => "2-u9tlzr9756bt3uc0v", + }, + S => { + unicode => "\$1.00", + ascii => "\$1.00", + }, +); + +is encode_punycode("bücher"), "bcher-kva", "http://en.wikipedia.org/wiki/Punycode example encode"; +is decode_punycode("bcher-kva"), "bücher", "http://en.wikipedia.org/wiki/Punycode example decode"; + +for my $test_key (sort keys %RFC_3492) { + my $test = $RFC_3492{$test_key}; + is encode_punycode($test->{unicode}), $test->{ascii}, "$test_key encode"; + is decode_punycode($test->{ascii}), $test->{unicode}, "$test_key decode" unless $test_key eq "S"; +} + +sub udecode { + my $str = shift; + my @u; + for (split(" ", $str)) { + /^[uU]\+[\dA-F]{2,4}$/ || die "Unexpected ucode: $_"; + push(@u, chr(hex(substr($_, 2)))); + } + return join("", @u); +} diff --git a/t/query-param.t b/t/query-param.t new file mode 100644 index 0000000..fc852c0 --- /dev/null +++ b/t/query-param.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More tests => 19; + +use URI; +use URI::QueryParam; + +my $u = URI->new("http://www.sol.no?foo=4&bar=5&foo=5"); + +is_deeply( + $u->query_form_hash, + { foo => [ 4, 5 ], bar => 5 }, + 'query_form_hash get' +); + +$u->query_form_hash({ a => 1, b => 2}); +ok $u->query eq "a=1&b=2" || $u->query eq "b=2&a=1", 'query_form_hash set'; + +$u->query("a=1&b=2&a=3&b=4&a=5"); +is join(':', $u->query_param), "a:b", 'query_param list keys'; + +is $u->query_param("a"), "1", "query_param scalar return"; +is join(":", $u->query_param("a")), "1:3:5", "query_param list return"; + +is $u->query_param(a => 11 .. 15), 1, "query_param set return"; + +is $u->query, "a=11&b=2&a=12&b=4&a=13&a=14&a=15", "param order"; + +is join(":", $u->query_param(a => 11)), "11:12:13:14:15", "old values returned"; + +is $u->query, "a=11&b=2&b=4"; + +is $u->query_param_delete("a"), "11", 'query_param_delete'; + +is $u->query, "b=2&b=4"; + +$u->query_param_append(a => 1, 3, 5); +$u->query_param_append(b => 6); + +is $u->query, "b=2&b=4&a=1&a=3&a=5&b=6"; + +$u->query_param(a => []); # same as $u->query_param_delete("a"); + +is $u->query, "b=2&b=4&b=6", 'delete by assigning empty list'; + +$u->query(undef); +$u->query_param(a => 1, 2, 3); +$u->query_param(b => 1); + +is $u->query, 'a=1&a=2&a=3&b=1', 'query_param from scratch'; + +$u->query_param_delete('a'); +$u->query_param_delete('b'); + +ok ! $u->query; + +is $u->as_string, 'http://www.sol.no'; + +$u->query(undef); +$u->query_param(a => 1, 2, 3); +$u->query_param(b => 1); + +is $u->query, 'a=1&a=2&a=3&b=1'; + +$u->query_param('a' => []); +$u->query_param('b' => []); + +ok ! $u->query; + +is $u->as_string, 'http://www.sol.no'; diff --git a/t/query.t b/t/query.t new file mode 100644 index 0000000..2970814 --- /dev/null +++ b/t/query.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use Test::More tests => 23; + +use URI (); +my $u = URI->new("", "http"); +my @q; + +$u->query_form(a => 3, b => 4); +is $u, "?a=3&b=4"; + +$u->query_form(a => undef); +is $u, "?a="; + +$u->query_form("a[=&+#] " => " [=&+#]"); +is $u, "?a%5B%3D%26%2B%23%5D+=+%5B%3D%26%2B%23%5D"; + +@q = $u->query_form; +is join(":", @q), "a[=&+#] : [=&+#]"; + +@q = $u->query_keywords; +ok !@q; + +$u->query_keywords("a", "b"); +is $u, "?a+b"; + +$u->query_keywords(" ", "+", "=", "[", "]"); +is $u, "?%20+%2B+%3D+%5B+%5D"; + +@q = $u->query_keywords; +is join(":", @q), " :+:=:[:]"; + +@q = $u->query_form; +ok !@q; + +$u->query(" +?=#"); +is $u, "?%20+?=%23"; + +$u->query_keywords([qw(a b)]); +is $u, "?a+b"; + +$u->query_keywords([]); +is $u, ""; + +$u->query_form({ a => 1, b => 2 }); +ok $u eq "?a=1&b=2" || $u eq "?b=2&a=1"; + +$u->query_form([ a => 1, b => 2 ]); +is $u, "?a=1&b=2"; + +$u->query_form({}); +is $u, ""; + +$u->query_form([a => [1..4]]); +is $u, "?a=1&a=2&a=3&a=4"; + +$u->query_form([]); +is $u, ""; + +$u->query_form(a => { foo => 1 }); +ok "$u" =~ /^\?a=HASH\(/; + +$u->query_form(a => 1, b => 2, ';'); +is $u, "?a=1;b=2"; + +$u->query_form(a => 1, c => 2); +is $u, "?a=1;c=2"; + +$u->query_form(a => 1, c => 2, '&'); +is $u, "?a=1&c=2"; + +$u->query_form([a => 1, b => 2], ';'); +is $u, "?a=1;b=2"; + +$u->query_form([]); +{ + local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';'; + $u->query_form(a => 1, b => 2); +} +is $u, "?a=1;b=2"; @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More; + +plan tests => 6; + +use URI; + +my $uri; + +$uri = URI->new("http://www.example.com/foo/bar/"); +is($uri->rel("http://www.example.com/foo/bar/"), "./"); +is($uri->rel("HTTP://WWW.EXAMPLE.COM/foo/bar/"), "./"); +is($uri->rel("HTTP://WWW.EXAMPLE.COM/FOO/BAR/"), "../../foo/bar/"); +is($uri->rel("HTTP://WWW.EXAMPLE.COM:80/foo/bar/"), "./"); + +$uri = URI->new("http://www.example.com/foo/bar"); +is($uri->rel("http://www.example.com/foo/bar"), "bar"); +is($uri->rel("http://www.example.com/foo"), "foo/bar"); + diff --git a/t/rfc2732.t b/t/rfc2732.t new file mode 100644 index 0000000..d69960a --- /dev/null +++ b/t/rfc2732.t @@ -0,0 +1,59 @@ +# Test URIs containing IPv6 addresses + +use strict; +use warnings; + +use Test::More tests => 19; + +use URI; +my $uri = URI->new("http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"); + +is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"; +is $uri->host, "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210"; +is $uri->host_port, "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80"; +is $uri->port, "80"; + +$uri->port(undef); +is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]/index.html"; +is $uri->host_port, "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80"; +$uri->port(80); + +$uri->host("host"); +is $uri->as_string, "http://host:80/index.html"; + +$uri->host("FEDC:BA98:7654:3210:FEDC:BA98:7654:3210"); +is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"; +$uri->host_port("[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:88"); +is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:88/index.html"; +$uri->host_port("[::1]:80"); +is $uri->as_string, "http://[::1]:80/index.html"; +$uri->host("::1:80"); +is $uri->as_string, "http://[::1:80]:80/index.html"; +$uri->host("[::1:80]"); +is $uri->as_string, "http://[::1:80]:80/index.html"; +$uri->host("[::1]:88"); +is $uri->as_string, "http://[::1]:88/index.html"; + + +$uri = URI->new("ftp://ftp:@[3ffe:2a00:100:7031::1]"); +is $uri->as_string, "ftp://ftp:@[3ffe:2a00:100:7031::1]"; + +is $uri->port, "21"; +ok !$uri->_port; + +is $uri->host("ftp"), "3ffe:2a00:100:7031::1"; + +is $uri, "ftp://ftp:\@ftp"; + +$uri = URI->new("http://[::1]"); +is $uri->host, "::1"; + +__END__ + + http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html + http://[1080:0:0:0:8:800:200C:417A]/index.html + http://[3ffe:2a00:100:7031::1] + http://[1080::8:800:200C:417A]/foo + http://[::192.9.5.5]/ipng + http://[::FFFF:129.144.52.38]:80/index.html + http://[2010:836B:4179::836B:4179] diff --git a/t/roy-test.t b/t/roy-test.t new file mode 100644 index 0000000..a7a9fdc --- /dev/null +++ b/t/roy-test.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test qw(plan ok); +plan tests => 102; + +use URI; +use File::Spec::Functions qw(catfile); + +my $no = 1; + +my @prefix; +push(@prefix, "t") if -d "t"; + +for my $i (1..5) { + my $file = catfile(@prefix, "roytest$i.html"); + + open(FILE, $file) || die "Can't open $file: $!"; + print "# $file\n"; + my $base = undef; + while (<FILE>) { + if (/^<BASE href="([^"]+)">/) { + $base = URI->new($1); + } elsif (/^<a href="([^"]*)">.*<\/a>\s*=\s*(\S+)/) { + die "Missing base at line $." unless $base; + my $link = $1; + my $exp = $2; + $exp = $base if $exp =~ /current/; # special case test 22 + + # rfc2396bis restores the rfc1808 behaviour + if ($no == 7) { + $exp = "http://a/b/c/d;p?y"; + } + elsif ($no == 48) { + $exp = "http://a/b/c/d;p?y"; + } + + ok(URI->new($link)->abs($base), $exp); + + $no++; + } + } + close(FILE); +} diff --git a/t/roytest1.html b/t/roytest1.html new file mode 100644 index 0000000..95fedbe --- /dev/null +++ b/t/roytest1.html @@ -0,0 +1,194 @@ +<HTML><HEAD> +<TITLE>Examples of Resolving Relative URLs</TITLE> +<BASE href="http://a/b/c/d;p?q"> +</HEAD><BODY> +<H1>Examples of Resolving Relative URLs</H1> + +This document has an embedded base URL of +<PRE> + Content-Base: http://a/b/c/d;p?q +</PRE> +the relative URLs should be resolved as shown below. +<P> +I will need your help testing the examples on multiple browsers. +What you need to do is point to the example anchor and compare it to the +resolved URL in your browser (most browsers have a feature by which you +can see the resolved URL at the bottom of the window/screen when the anchor +is active). + +<H2>Tested Clients and Client Libraries</H2> + +<DL COMPACT> +<DT>[R] +<DD>RFC 2396 (the right way to parse) +<DT>[X] +<DD>RFC 1808 +<DT>[1] +<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) +<DT>[2] +<DD>Lynx/2.7.1 libwww-FM/2.14 +<DT>[3] +<DD>MSIE 3.01; Windows 95 +<DT>[4] +<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 +<DT>[5] +<DD>libwww-perl/5.14 [Martijn Koster] +</DL> + +<H2>Normal Examples</H2> +<PRE> + RESULTS from + +<a href="g:h">g:h</a> = g:h [R,X,2,3,4,5] + http://a/b/c/g:h [1] + +<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4,5] + +<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4,5] + +<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4,5] + +<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4,5] + +<a href="//g">//g</a> = http://g [R,X,1,2,3,4,5] + +<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4] + http://a/b/c/d;p?y [X,5] + +<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4,5] + +<a name="s" href="#s">#s</a> = (current document)#s [R,2,4] + http://a/b/c/d;p?q#s [X,1,3,5] + +<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4,5] + +<a href="g?y#s">g?y#s</a> = http://a/b/c/g?y#s [R,X,1,2,3,4,5] + +<a href=";x">;x</a> = http://a/b/c/;x [R,1,2,3,4] + http://a/b/c/d;x [X,5] + +<a href="g;x">g;x</a> = http://a/b/c/g;x [R,X,1,2,3,4,5] + +<a href="g;x?y#s">g;x?y#s</a> = http://a/b/c/g;x?y#s [R,X,1,2,3,4,5] + +<a href=".">.</a> = http://a/b/c/ [R,X,2,5] + http://a/b/c/. [1] + http://a/b/c [3,4] + +<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4,5] + +<a href="..">..</a> = http://a/b/ [R,X,2,5] + http://a/b [1,3,4] + +<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4,5] + +<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4,5] + +<a href="../..">../..</a> = http://a/ [R,X,2,5] + http://a [1,3,4] + +<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4,5] + +<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4,5] +</PRE> + +<H2>Abnormal Examples</H2> + +Although the following abnormal examples are unlikely to occur in +normal practice, all URL parsers should be capable of resolving them +consistently. Each example uses the same base as above.<P> + +An empty reference refers to the start of the current document. +<PRE> +<a href=""><></a> = (current document) [R,2,4] + http://a/b/c/d;p?q [X,3,5] + http://a/b/c/ [1] +</PRE> +Parsers must be careful in handling the case where there are more +relative path ".." segments than there are hierarchical levels in the +base URL's path. Note that the ".." syntax cannot be used to change +the site component of a URL. +<PRE> +<a href="../../../g">../../../g</a> = http://a/../g [R,X,2,4,5] + http://a/g [R,1,3] + +<a href="../../../../g">../../../../g</a> = http://a/../../g [R,X,2,4,5] + http://a/g [R,1,3] +</PRE> +In practice, some implementations strip leading relative symbolic +elements (".", "..") after applying a relative URL calculation, based +on the theory that compensating for obvious author errors is better +than allowing the request to fail. Thus, the above two references +will be interpreted as "http://a/g" by some implementations. +<P> +Similarly, parsers must avoid treating "." and ".." as special when +they are not complete components of a relative path. +<PRE> +<a href="/./g">/./g</a> = http://a/./g [R,X,2,3,4,5] + http://a/g [1] + +<a href="/../g">/../g</a> = http://a/../g [R,X,2,3,4,5] + http://a/g [1] + +<a href="g.">g.</a> = http://a/b/c/g. [R,X,1,2,3,4,5] + +<a href=".g">.g</a> = http://a/b/c/.g [R,X,1,2,3,4,5] + +<a href="g..">g..</a> = http://a/b/c/g.. [R,X,1,2,3,4,5] + +<a href="..g">..g</a> = http://a/b/c/..g [R,X,1,2,3,4,5] +</PRE> +Less likely are cases where the relative URL uses unnecessary or +nonsensical forms of the "." and ".." complete path segments. +<PRE> +<a href="./../g">./../g</a> = http://a/b/g [R,X,1,2,5] + http://a/b/c/../g [3,4] + +<a href="./g/.">./g/.</a> = http://a/b/c/g/ [R,X,2,5] + http://a/b/c/g/. [1] + http://a/b/c/g [3,4] + +<a href="g/./h">g/./h</a> = http://a/b/c/g/h [R,X,1,2,3,4,5] + +<a href="g/../h">g/../h</a> = http://a/b/c/h [R,X,1,2,3,4,5] + +<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/g;x=1/y [R,1,2,3,4] + http://a/b/c/g;x=1/./y [X,5] + +<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/y [R,1,2,3,4] + http://a/b/c/g;x=1/../y [X,5] + +</PRE> +All client applications remove the query component from the base URL +before resolving relative URLs. However, some applications fail to +separate the reference's query and/or fragment components from a +relative path before merging it with the base path. This error is +rarely noticed, since typical usage of a fragment never includes the +hierarchy ("/") character, and the query component is not normally +used within relative references. +<PRE> +<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X,5] + http://a/b/c/g?y/x [1,2,3,4] + +<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X,5] + http://a/b/c/x [1,2,3,4] + +<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4,5] + http://a/b/c/g#s/x [1] + +<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4,5] + http://a/b/c/x [1] +</PRE> + Some parsers allow the scheme name to be present in a relative URI if + it is the same as the base URI scheme. This is considered to be a + loophole in prior specifications of partial URI [RFC1630]. Its use + should be avoided. +<PRE> +<a href="http:g">http:g</a> = http:g [R,X,5] + | http://a/b/c/g [1,2,3,4] (ok for compat.) + +<a href="http:">http:</a> = http: [R,X,5] + http://a/b/c/ [1] + http://a/b/c/d;p?q [2,3,4] +</PRE> +</BODY></HTML> diff --git a/t/roytest2.html b/t/roytest2.html new file mode 100644 index 0000000..3906f4e --- /dev/null +++ b/t/roytest2.html @@ -0,0 +1,100 @@ +<HTML><HEAD> +<TITLE>Examples of Resolving Relative URLs, Part 2</TITLE> +<BASE href="http://a/b/c/d;p?q=1/2"> +</HEAD><BODY> +<H1>Examples of Resolving Relative URLs, Part 2</H1> + +This document has an embedded base URL of +<PRE> + Content-Base: http://a/b/c/d;p?q=1/2 +</PRE> +the relative URLs should be resolved as shown below. In this test page, +I am particularly interested in testing whether "/" in query information +is or is not treated as part of the path hierarchy. +<P> +I will need your help testing the examples on multiple browsers. +What you need to do is point to the example anchor and compare it to the +resolved URL in your browser (most browsers have a feature by which you +can see the resolved URL at the bottom of the window/screen when the anchor +is active). + +<H2>Tested Clients and Client Libraries</H2> + +<DL COMPACT> +<DT>[R] +<DD>RFC 2396 (the right way to parse) +<DT>[X] +<DD>RFC 1808 +<DT>[1] +<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) +<DT>[2] +<DD>Lynx/2.7.1 libwww-FM/2.14 +<DT>[3] +<DD>MSIE 3.01; Windows 95 +<DT>[4] +<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 +</DL> + +<H3>Synopsis</H3> + +RFC 1808 specified that the "/" character within query information +does not affect the hierarchy within URL parsing. It would appear that +it does in current practice, but only within the relative path after +it is attached to the base path. In other words, the base URL's query +information is being stripped off before any relative resolution, but +some parsers fail to separate the query information from the relative +path.<P> + +We have decided that this behavior is due to an oversight in the original +libwww implementation, and it is better to correct the oversight in future +parsers than it is to make a nonsensical standard. A note has been added +to the URI draft to account for the differences in implementations. This should +have no impact on current practice since unescaped "/" is rarely (if ever) +used within the query part of a URL, and query parts themselves are rarely +used with relative URLs. + +<H2>Examples</H2> +<PRE> + RESULTS from + +<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4] + +<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4] + +<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4] + +<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4] + +<a href="//g">//g</a> = http://g [R,X,1,2,3,4] + +<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4] + http://a/b/c/d;p?y [X] + +<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4] + +<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X] + http://a/b/c/g?y/x [1,2,3,4] + +<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X] + http://a/b/c/x [1,2,3,4] + +<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4] + +<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4] + http://a/b/c/g#s/x [1] + +<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4] + http://a/b/c/x [1] + +<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4] + +<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4] + +<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4] + +<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4] + +<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4] + +</PRE> +</BODY></HTML> diff --git a/t/roytest3.html b/t/roytest3.html new file mode 100644 index 0000000..699558f --- /dev/null +++ b/t/roytest3.html @@ -0,0 +1,89 @@ +<HTML><HEAD> +<TITLE>Examples of Resolving Relative URLs, Part 3</TITLE> +<BASE href="http://a/b/c/d;p=1/2?q"> +</HEAD><BODY> +<H1>Examples of Resolving Relative URLs, Part 3</H1> + +This document has an embedded base URL of +<PRE> + Content-Base: http://a/b/c/d;p=1/2?q +</PRE> +the relative URLs should be resolved as shown below. For this test page, +I am particularly interested in testing whether "/" in parameters is or is not +treated as part of the path hierarchy. +<P> +I will need your help testing the examples on multiple browsers. +What you need to do is point to the example anchor and compare it to the +resolved URL in your browser (most browsers have a feature by which you +can see the resolved URL at the bottom of the window/screen when the anchor +is active). + +<H2>Tested Clients and Client Libraries</H2> + +<DL COMPACT> +<DT>[R] +<DD>RFC 2396 (the right way to parse) +<DT>[X] +<DD>RFC 1808 +<DT>[1] +<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) +<DT>[2] +<DD>Lynx/2.7.1 libwww-FM/2.14 +<DT>[3] +<DD>MSIE 3.01; Windows 95 +<DT>[4] +<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 +</DL> + +<H3>Synopsis</H3> + +RFC 1808 specified that the "/" character within parameter information +does not affect the hierarchy within URL parsing. It would appear that +it does in current practice. This implies that the parameters should +be part of each path segment and not outside the path. The URI draft has +been written accordingly. + +<H2>Examples</H2> +<PRE> + RESULTS from + +<a href="g">g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4] + http://a/b/c/g [X] + +<a href="./g">./g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4] + http://a/b/c/g [X] + +<a href="g/">g/</a> = http://a/b/c/d;p=1/g/ [R,1,2,3,4] + http://a/b/c/g/ [X] + +<a href="g?y">g?y</a> = http://a/b/c/d;p=1/g?y [R,1,2,3,4] + http://a/b/c/g?y [X] + +<a href=";x">;x</a> = http://a/b/c/d;p=1/;x [R,1,2,3,4] + http://a/b/c/d;x [X] + +<a href="g;x">g;x</a> = http://a/b/c/d;p=1/g;x [R,1,2,3,4] + http://a/b/c/g;x [X] + +<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/d;p=1/g;x=1/y [R,1,2,3,4] + http://a/b/c/g;x=1/./y [X] + +<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/d;p=1/y [R,1,2,3,4] + http://a/b/c/g;x=1/../y [X] + +<a href="./">./</a> = http://a/b/c/d;p=1/ [R,1,2,3,4] + http://a/b/c/ [X] + +<a href="../">../</a> = http://a/b/c/ [R,1,2,3,4] + http://a/b/ [X] + +<a href="../g">../g</a> = http://a/b/c/g [R,1,2,3,4] + http://a/b/g [X] + +<a href="../../">../../</a> = http://a/b/ [R,1,2,3,4] + http://a/ [X] + +<a href="../../g">../../g</a> = http://a/b/g [R,1,2,3,4] + http://a/g [X] +</PRE> +</BODY></HTML> diff --git a/t/roytest4.html b/t/roytest4.html new file mode 100644 index 0000000..160554c --- /dev/null +++ b/t/roytest4.html @@ -0,0 +1,98 @@ +<HTML><HEAD> +<TITLE>Examples of Resolving Relative URLs, Part 4</TITLE> +<BASE href="fred:///s//a/b/c"> +</HEAD><BODY> +<H1>Examples of Resolving Relative URLs, Part 4</H1> + +This document has an embedded base URL of +<PRE> + Content-Base: fred:///s//a/b/c +</PRE> +in order to test a notion that Tim Berners-Lee mentioned regarding +the ability of URIs to have a triple-slash (or even more slashes) +to indicate higher levels of hierarchy than those already used by URLs. + +<H2>Tested Clients and Client Libraries</H2> + +<DL COMPACT> +<DT>[R] +<DD>RFC 2396 (the right way to parse) +<DT>Tim +<DD>Tim Berners-Lee's proposed interpretation +<DT>[1] +<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) +<DT>[2] +<DD>Lynx/2.7.1 libwww-FM/2.14 +<DT>[3] +<DD>MSIE 3.01; Windows 95 +<DT>[4] +<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) +</DL> + +<H3>Synopsis</H3> + +RFC 1808 specified that the highest level for relative URLs is indicated +by a double-slash "//", and therefore that any triple-slash would be +considered a null site component, rather than a higher-level component +than the site component (as proposed by Tim).<P> + +The URI draft assumes that a triple-slash means an empty site component. +Netscape Navigator behaves irrationally, apparently because their parser +is scheme-dependent and therefore doesn't do the hierarchical parsing that +would be expected. Oddly, Lynx seems to straddle both sides. + +<H2>Examples</H2> +<PRE> + RESULTS from + +<a href="g:h">g:h</a> = g:h [R,Tim,2,3] + fred:///s//a/b/g:h [1] + +<a href="g">g</a> = fred:///s//a/b/g [R,Tim,1,2,3] + +<a href="./g">./g</a> = fred:///s//a/b/g [R,Tim,2,3] + fred:///s//a/b/./g [1] + +<a href="g/">g/</a> = fred:///s//a/b/g/ [R,Tim,1,2,3] + +<a href="/g">/g</a> = fred:///g [R,1,2,3] + fred:///s//a/g [Tim] + +<a href="//g">//g</a> = fred://g [R,1,2,3] + fred:///s//g [Tim] + +<a href="//g/x">//g/x</a> = fred://g/x [R,1,2,3] + fred:///s//g/x [Tim] + +<a href="///g">///g</a> = fred:///g [R,Tim,1,2,3] + +<a href="./">./</a> = fred:///s//a/b/ [R,Tim,2,3] + fred:///s//a/b/./ [1] + +<a href="../">../</a> = fred:///s//a/ [R,Tim,2,3] + fred:///s//a/b/../ [1] + +<a href="../g">../g</a> = fred:///s//a/g [R,Tim,2,3] + fred:///s//a/b/../g [1] + +<a href="../../">../../</a> = fred:///s// [R] + fred:///s//a/../ [Tim,2] + fred:///s//a/b/../../ [1] + fred:///s//a/ [3] + +<a href="../../g">../../g</a> = fred:///s//g [R] + fred:///s//a/../g [Tim,2] + fred:///s//a/b/../../g [1] + fred:///s//a/g [3] + +<a href="../../../g">../../../g</a> = fred:///s/g [R] + fred:///s//a/../../g [Tim,2] + fred:///s//a/b/../../../g [1] + fred:///s//a/g [3] + +<a href="../../../../g">../../../../g</a> = fred:///g [R] + fred:///s//a/../../../g [Tim,2] + fred:///s//a/b/../../../../g [1] + fred:///s//a/g [3] +</PRE> +</BODY></HTML> diff --git a/t/roytest5.html b/t/roytest5.html new file mode 100644 index 0000000..1b24361 --- /dev/null +++ b/t/roytest5.html @@ -0,0 +1,92 @@ +<HTML><HEAD> +<TITLE>Examples of Resolving Relative URLs, Part 5</TITLE> +<BASE href="http:///s//a/b/c"> +</HEAD><BODY> +<H1>Examples of Resolving Relative URLs, Part 5</H1> + +This document has an embedded base URL of +<PRE> + Content-Base: http:///s//a/b/c +</PRE> +in order to test a notion that Tim Berners-Lee mentioned regarding +the ability of URIs to have a triple-slash (or even more slashes) +to indicate higher levels of hierarchy than those already used by URLs. +This is the same as Part 4, except that the scheme "fred" is replaced +with "http" for clients that stupidly change their parsing behavior +based on the scheme name. + +<H2>Tested Clients and Client Libraries</H2> + +<DL COMPACT> +<DT>[R] +<DD>RFC 2396 (the right way to parse) +<DT>Tim +<DD>Tim Berners-Lee's proposed interpretation +<DT>[1] +<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) +<DT>[2] +<DD>Lynx/2.7.1 libwww-FM/2.14 +<DT>[3] +<DD>MSIE 3.01; Windows 95 +<DT>[4] +<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) +</DL> + +<H3>Synopsis</H3> + +RFC 1808 specified that the highest level for relative URLs is indicated +by a double-slash "//", and therefore that any triple-slash would be +considered a null site component, rather than a higher-level component +than the site component (as proposed by Tim).<P> + +Draft 09 assumes that a triple-slash means an empty site component, +as does Netscape Navigator if the scheme is known. +Oddly, Lynx seems to straddle both sides. + +<H2>Examples</H2> +<PRE> + RESULTS from + +<a href="g:h">g:h</a> = g:h [R,Tim,2,3] + http:///s//a/b/g:h [1] + +<a href="g">g</a> = http:///s//a/b/g [R,Tim,1,2,3] + +<a href="./g">./g</a> = http:///s//a/b/g [R,Tim,1,2,3] + +<a href="g/">g/</a> = http:///s//a/b/g/ [R,Tim,1,2,3] + +<a href="/g">/g</a> = http:///g [R,1,2,3] + http:///s//a/g [Tim] + +<a href="//g">//g</a> = http://g [R,1,2,3] + http:///s//g [Tim] + +<a href="//g/x">//g/x</a> = http://g/x [R,1,2,3] + http:///s//g/x [Tim] + +<a href="///g">///g</a> = http:///g [R,Tim,1,2,3] + +<a href="./">./</a> = http:///s//a/b/ [R,Tim,1,2,3] + +<a href="../">../</a> = http:///s//a/ [R,Tim,1,2,3] + +<a href="../g">../g</a> = http:///s//a/g [R,Tim,1,2,3] + +<a href="../../">../../</a> = http:///s// [R,1] + http:///s//a/../ [Tim,2] + http:///s//a/ [3] + +<a href="../../g">../../g</a> = http:///s//g [R,1] + http:///s//a/../g [Tim,2] + http:///s//a/g [3] + +<a href="../../../g">../../../g</a> = http:///s/g [R,1] + http:///s//a/../../g [Tim,2] + http:///s//a/g [3] + +<a href="../../../../g">../../../../g</a> = http:///g [R,1] + http:///s//a/../../../g [Tim,2] + http:///s//a/g [3] +</PRE> +</BODY></HTML> diff --git a/t/rsync.t b/t/rsync.t new file mode 100644 index 0000000..01e91d7 --- /dev/null +++ b/t/rsync.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +print "1..4\n"; + +use URI; + +my $u = URI->new('rsync://gisle@perl.com/foo/bar'); + +print "not " unless $u->user eq "gisle"; +print "ok 1\n"; + +print "not " unless $u->port eq 873; +print "ok 2\n"; + +print "not " unless $u->path eq "/foo/bar"; +print "ok 3\n"; + +$u->port(8730); + +print "not " unless $u eq 'rsync://gisle@perl.com:8730/foo/bar'; +print "ok 4\n"; + diff --git a/t/rtsp.t b/t/rtsp.t new file mode 100644 index 0000000..208b63b --- /dev/null +++ b/t/rtsp.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +print "1..9\n"; + +use URI; + +my $u = URI->new("<rtsp://media.perl.com/fôo.smi/>"); + +#print "$u\n"; +print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/"; +print "ok 1\n"; + +print "not " unless $u->port == 554; +print "ok 2\n"; + +# play with port +my $old = $u->port(8554); +print "not " unless $old == 554 && $u eq "rtsp://media.perl.com:8554/f%F4o.smi/"; +print "ok 3\n"; + +$u->port(554); +print "not " unless $u eq "rtsp://media.perl.com:554/f%F4o.smi/"; +print "ok 4\n"; + +$u->port(""); +print "not " unless $u eq "rtsp://media.perl.com:/f%F4o.smi/" && $u->port == 554; +print "ok 5\n"; + +$u->port(undef); +print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/"; +print "ok 6\n"; + +print "not " unless $u->host eq "media.perl.com"; +print "ok 7\n"; + +print "not " unless $u->path eq "/f%F4o.smi/"; +print "ok 8\n"; + +$u->scheme("rtspu"); +print "not " unless $u->scheme eq "rtspu"; +print "ok 9\n"; + @@ -0,0 +1,69 @@ +use strict; +use warnings; + +print "1..11\n"; + +use URI; + +my $u = URI->new('sip:phone@domain.ext'); +print "not " unless $u->user eq 'phone' && + $u->host eq 'domain.ext' && + $u->port eq '5060' && + $u eq 'sip:phone@domain.ext'; +print "ok 1\n"; + +$u->host_port('otherdomain.int:9999'); +print "not " unless $u->host eq 'otherdomain.int' && + $u->port eq '9999' && + $u eq 'sip:phone@otherdomain.int:9999'; +print "ok 2\n"; + +$u->port('5060'); +$u = $u->canonical; +print "not " unless $u->host eq 'otherdomain.int' && + $u->port eq '5060' && + $u eq 'sip:phone@otherdomain.int'; +print "ok 3\n"; + +$u->user('voicemail'); +print "not " unless $u->user eq 'voicemail' && + $u eq 'sip:voicemail@otherdomain.int'; +print "ok 4\n"; + +$u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent'); +print "not " unless $u->host eq 'domain.ext' && + $u->query eq 'Subject=Meeting&Priority=Urgent'; +print "ok 5\n"; + +$u->query_form(Subject => 'Lunch', Priority => 'Low'); +my @q = $u->query_form; +print "not " unless $u->host eq 'domain.ext' && + $u->query eq 'Subject=Lunch&Priority=Low' && + @q == 4 && "@q" eq "Subject Lunch Priority Low"; +print "ok 6\n"; + +$u = URI->new('sip:phone@domain.ext;maddr=127.0.0.1;ttl=16'); +print "not " unless $u->host eq 'domain.ext' && + $u->params eq 'maddr=127.0.0.1;ttl=16'; +print "ok 7\n"; + +$u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent'); +$u->params_form(maddr => '127.0.0.1', ttl => '16'); +my @p = $u->params_form; +print "not " unless $u->host eq 'domain.ext' && + $u->query eq 'Subject=Meeting&Priority=Urgent' && + $u->params eq 'maddr=127.0.0.1;ttl=16' && + @p == 4 && "@p" eq "maddr 127.0.0.1 ttl 16"; + +print "ok 8\n"; + +$u = URI->new_abs('sip:phone@domain.ext', 'sip:foo@domain2.ext'); +print "not " unless $u eq 'sip:phone@domain.ext'; +print "ok 9\n"; + +$u = URI->new('sip:phone@domain.ext'); +print "not " unless $u eq $u->abs('http://www.cpan.org/'); +print "ok 10\n"; + +print "not " unless $u eq $u->rel('http://www.cpan.org/'); +print "ok 11\n"; diff --git a/t/sort-hash-query-form.t b/t/sort-hash-query-form.t new file mode 100644 index 0000000..7c6f896 --- /dev/null +++ b/t/sort-hash-query-form.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; + +# ABSTRACT: Make sure query_form(\%hash) is sorted + +use URI; + +my $base = URI->new('http://example.org/'); + +my $i = 1; + +my $hash = { map { $_ => $i++ } qw( a b c d e f ) }; + +$base->query_form($hash); + +is("$base","http://example.org/?a=1&b=2&c=3&d=4&e=5&f=6", "Query parameters are sorted"); + +done_testing; + + diff --git a/t/split.t b/t/split.t new file mode 100644 index 0000000..34104b8 --- /dev/null +++ b/t/split.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +print "1..17\n"; + +use URI::Split qw(uri_split uri_join); + +sub j { join("-", map { defined($_) ? $_ : "<undef>" } @_) } + +print "not " unless j(uri_split("p")) eq "<undef>-<undef>-p-<undef>-<undef>"; +print "ok 1\n"; + +print "not " unless j(uri_split("p?q")) eq "<undef>-<undef>-p-q-<undef>"; +print "ok 2\n"; + +print "not " unless j(uri_split("p#f")) eq "<undef>-<undef>-p-<undef>-f"; +print "ok 3\n"; + +print "not " unless j(uri_split("p?q/#f/?")) eq "<undef>-<undef>-p-q/-f/?"; +print "ok 4\n"; + +print "not " unless j(uri_split("s://a/p?q#f")) eq "s-a-/p-q-f"; +print "ok 5\n"; + +print "not " unless uri_join("s", "a", "/p", "q", "f") eq "s://a/p?q#f"; +print "ok 6\n"; + +print "not " unless uri_join("s", "a", "p", "q", "f") eq "s://a/p?q#f"; +print "ok 7\n"; + +print "not " unless uri_join(undef, undef, "", undef, undef) eq ""; +print "ok 8\n"; + +print "not " unless uri_join(undef, undef, "p", undef, undef) eq "p"; +print "ok 9\n"; + +print "not " unless uri_join("s", undef, "p") eq "s:p"; +print "ok 10\n"; + +print "not " unless uri_join("s") eq "s:"; +print "ok 11\n"; + +print "not " unless uri_join() eq ""; +print "ok 12\n"; + +print "not " unless uri_join("s", "a") eq "s://a"; +print "ok 13\n"; + +print "not " unless uri_join("s", "a/b") eq "s://a%2Fb"; +print "ok 14\n"; + +print "not " unless uri_join("s", ":/?#", ":/?#", ":/?#", ":/?#") eq "s://:%2F%3F%23/:/%3F%23?:/?%23#:/?#"; +print "ok 15\n"; + +print "not " unless uri_join(undef, undef, "a:b") eq "a%3Ab"; +print "ok 16\n"; + +print "not " unless uri_join("s", undef, "//foo//bar") eq "s:////foo//bar"; +print "ok 17\n"; diff --git a/t/storable-test.pl b/t/storable-test.pl new file mode 100644 index 0000000..33deb6f --- /dev/null +++ b/t/storable-test.pl @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Storable; + +if (@ARGV && $ARGV[0] eq "store") { + require URI; + require URI::URL; + my $a = { + u => new URI('http://search.cpan.org/'), + }; + print "# store\n"; + store [URI->new("http://search.cpan.org")], 'urls.sto'; +} else { + print "# retrieve\n"; + my $a = retrieve 'urls.sto'; + my $u = $a->[0]; + #use Data::Dumper; print Dumper($a); + + print "not " unless $u eq "http://search.cpan.org"; + print "ok 1\n"; + + print "not " unless $u->scheme eq "http"; + print "ok 2\n"; + + print "not " unless ref($u) eq "URI::http"; + print "ok 3\n"; +} diff --git a/t/storable.t b/t/storable.t new file mode 100644 index 0000000..cf6e65a --- /dev/null +++ b/t/storable.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +eval { + require Storable; + print "1..3\n"; +}; +if ($@) { + print "1..0 # skipped: Needs the Storable module installed\n"; + exit; +} + +system($^X, "-Iblib/lib", "t/storable-test.pl", "store"); +system($^X, "-Iblib/lib", "t/storable-test.pl", "retrieve"); + +unlink('urls.sto'); diff --git a/t/urn-isbn.t b/t/urn-isbn.t new file mode 100644 index 0000000..d8985f7 --- /dev/null +++ b/t/urn-isbn.t @@ -0,0 +1,62 @@ +use strict; +use warnings; + +eval { + require Business::ISBN; +}; +if ($@) { + print "1..0 # Skipped: Needs the Business::ISBN module installed\n\n"; + print $@; + exit; +} + +print "1..13\n"; + +use URI; +my $u = URI->new("URN:ISBN:0395363411"); + +print "not " unless $u eq "URN:ISBN:0395363411" && + $u->scheme eq "urn" && + $u->nid eq "isbn"; +print "ok 1\n"; + +print "not " unless $u->canonical eq "urn:isbn:0-395-36341-1"; +print "ok 2\n"; + +print "not " unless $u->isbn eq "0-395-36341-1"; +print "ok 3\n"; + +print "not " unless $u->isbn_group_code == 0; +print "ok 4\n"; + +print "not " unless $u->isbn_publisher_code == 395; +print "ok 5\n"; + +print "not " unless $u->isbn13 eq "9780395363416"; +print "ok 6\n"; + +print "not " unless $u->nss eq "0395363411"; +print "ok 7\n"; + +print "not " unless $u->isbn("0-88730-866-x") eq "0-395-36341-1"; +print "ok 8\n"; + +print "not " unless $u->nss eq "0-88730-866-x"; +print "ok 9\n"; + +print "not " unless $u->isbn eq "0-88730-866-X"; +print "ok 10\n"; + +print "not " unless URI::eq("urn:isbn:088730866x", "URN:ISBN:0-88-73-08-66-X"); +print "ok 11\n"; + +# try to illegal ones +$u = URI->new("urn:ISBN:abc"); +print "not " unless $u eq "urn:ISBN:abc"; +print "ok 12\n"; + +print "not " if $u->nss ne "abc" || defined $u->isbn; +print "ok 13\n"; + + + diff --git a/t/urn-oid.t b/t/urn-oid.t new file mode 100644 index 0000000..d35e524 --- /dev/null +++ b/t/urn-oid.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +print "1..4\n"; + +use URI; + +my $u = URI->new("urn:oid"); + +$u->oid(1..10); + +#print "$u\n"; + +print "not " unless $u eq "urn:oid:1.2.3.4.5.6.7.8.9.10"; +print "ok 1\n"; + +print "not " unless $u->oid eq "1.2.3.4.5.6.7.8.9.10"; +print "ok 2\n"; + +print "not " unless $u->scheme eq "urn" && $u->nid eq "oid"; +print "ok 3\n"; + +print "not " unless $u->oid eq $u->nss; +print "ok 4\n"; diff --git a/t/utf8.t b/t/utf8.t new file mode 100644 index 0000000..1453cfc --- /dev/null +++ b/t/utf8.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use utf8; + +use Test::More 'no_plan'; +use URI; + +is(URI->new('http://foobar/mooi€e')->as_string, 'http://foobar/mooi%E2%82%ACe'); + +my $uri = URI->new('http:'); +$uri->query_form("mooi€e" => "mooi€e"); +is( $uri->query, "mooi%E2%82%ACe=mooi%E2%82%ACe" ); +is( ($uri->query_form)[1], "mooi\xE2\x82\xACe" ); + +# RT#70161 +use Encode; +$uri = URI->new(decode_utf8 '?Query=%C3%A4%C3%B6%C3%BC'); +is( ($uri->query_form)[1], "\xC3\xA4\xC3\xB6\xC3\xBC"); +is( decode_utf8(($uri->query_form)[1]), 'äöü'); |