URI-5.28/0000775000175000017500000000000014600675475010553 5ustar olafolafURI-5.28/t/0000775000175000017500000000000014600675475011016 5ustar olafolafURI-5.28/t/mix.t0000644000175000017500000000270014600675475011775 0ustar olafolafuse strict; use warnings; use Test::More tests => 6; # 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(); ok($a->isa("URI") && ref($b) eq ref($uw) && ref($c) eq ref($uu) && $d->isa("URI")); ok(not $b->base && $c->base); $a = URI::URL->new($rel, $u); $b = URI::URL->new($rel, $uw); $c = URI::URL->new($rel, $uu); $d = URI::URL->new($rel, $str); ok(ref($a) eq "URI::URL" && ref($b) eq "URI::URL" && ref($c) eq "URI::URL" && ref($d) eq "URI::URL"); ok(ref($b->base) eq ref($uw) && $b->base eq $uw && ref($c->base) eq ref($uu) && $c->base eq $uu && $d->base eq $str); $a = URI->new($uu, $u); $b = URI->new($uu, $uw); $c = URI->new($uu, $uu); $d = URI->new($uu, $str); #Dump(); ok(ref($a) eq ref($b) && ref($b) eq ref($c) && ref($c) eq ref($d) && ref($d) eq ref($u)); $a = URI::URL->new($u, $u); $b = URI::URL->new($u, $uw); $c = URI::URL->new($u, $uu); $d = URI::URL->new($u, $str); ok(ref($a) eq "URI::URL" && ref($b) eq "URI::URL" && ref($c) eq "URI::URL" && ref($d) eq "URI::URL"); URI-5.28/t/abs.t0000644000175000017500000001270414600675475011752 0ustar olafolafuse strict; use warnings; use Test::More tests => 45; # 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 () { #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/; my $bad; my $u = URI->new($uref, $base); if ($u->abs($base)->as_string ne $expect) { $bad++; my $abs = $u->abs($base)->as_string; diag qq(URI->new("$uref")->abs("$base") ==> "$abs"); } # 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++; diag qq(URI->new("$uref")->abs(URI->new("$base"), 1)); } # 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)); } ok !$bad, "$uref => $expect"; } if (@rel_fail) { note "\n\nIn the following cases we did not get back to where we started with rel()"; note @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 URI-5.28/t/old-file.t0000644000175000017500000000533314600675475012700 0ustar olafolafuse strict; use warnings; use Test::More; 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 plan tests => scalar @tests; 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 = "" unless defined $f; $expect = "" unless defined $expect; my $loose; $loose++ if $expect =~ s/^!//; if ($expect ne $f) { diag "URI->new('$file', 'file')->file('$os') ne $expect, but $f"; $err++; } if (defined($t[$i]) && !$loose) { my $u2 = URI::file->new($t[$i], $os); unless ($u2->as_string eq $file) { diag "URI::file->new('$t[$i]', '$os') ne $file, but $u2"; $err++; } } $i++; } ok !$err; } URI-5.28/t/ftp.t0000644000175000017500000000136714600675475012001 0ustar olafolafuse strict; use warnings; use Test::More tests => 13; use URI (); my $uri; $uri = URI->new("ftp://ftp.example.com/path"); is($uri->scheme, "ftp"); is($uri->host, "ftp.example.com"); is($uri->port, 21); is($uri->user, "anonymous"); is($uri->password, 'anonymous@'); $uri->userinfo("gisle\@aas.no"); is($uri, "ftp://gisle%40aas.no\@ftp.example.com/path"); is($uri->user, "gisle\@aas.no"); is($uri->password, undef); $uri->password("secret"); is($uri, "ftp://gisle%40aas.no:secret\@ftp.example.com/path"); $uri = URI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path"); is($uri, "ftp://gisle\@aas.no:secret\@ftp.example.com/path"); is($uri->userinfo, "gisle\@aas.no:secret"); is($uri->user, "gisle\@aas.no"); is($uri->password, "secret"); URI-5.28/t/generic.t0000644000175000017500000000732314600675475012622 0ustar olafolafuse strict; use warnings; use Test::More tests => 48; use URI (); my $foo = URI->new("Foo:opaque#frag"); is(ref($foo), "URI::_foreign"); is($foo->as_string, "Foo:opaque#frag"); is("$foo", "Foo:opaque#frag"); # Try accessors ok($foo->_scheme eq "Foo" && $foo->scheme eq "foo" && !$foo->has_recognized_scheme); is($foo->opaque, "opaque"); is($foo->fragment, "frag"); is($foo->canonical, "foo:opaque#frag"); # Try modificators my $old = $foo->scheme("bar"); ok($old eq "foo" && $foo eq "bar:opaque#frag"); $old = $foo->scheme(""); ok($old eq "bar" && $foo eq "opaque#frag"); $old = $foo->scheme("foo"); $old = $foo->scheme(undef); ok($old eq "foo" && $foo eq "opaque#frag"); $foo->scheme("foo"); $old = $foo->opaque("xxx"); ok($old eq "opaque" && $foo eq "foo:xxx#frag"); $old = $foo->opaque(""); ok($old eq "xxx" && $foo eq "foo:#frag"); $old = $foo->opaque(" #?/"); $old = $foo->opaque(undef); ok($old eq "%20%23?/" && $foo eq "foo:#frag"); $foo->opaque("opaque"); $old = $foo->fragment("x"); ok($old eq "frag" && $foo eq "foo:opaque#x"); $old = $foo->fragment(""); ok($old eq "x" && $foo eq "foo:opaque#"); $old = $foo->fragment(undef); ok($old eq "" && $foo eq "foo:opaque"); # Compare ok($foo->eq("Foo:opaque") && $foo->eq(URI->new("FOO:opaque")) && $foo->eq("foo:opaque")); ok(!$foo->eq("Bar:opaque") && !$foo->eq("foo:opaque#")); # Try hierarchal unknown URLs $foo = URI->new("foo://host:80/path?query#frag"); is("$foo", "foo://host:80/path?query#frag"); # Accessors is($foo->scheme, "foo"); is($foo->authority, "host:80"); is($foo->path, "/path"); is($foo->query, "query"); is($foo->fragment, "frag"); # Modificators $old = $foo->authority("xxx"); ok($old eq "host:80" && $foo eq "foo://xxx/path?query#frag"); $old = $foo->authority(""); ok($old eq "xxx" && $foo eq "foo:///path?query#frag"); $old = $foo->authority(undef); ok($old eq "" && $foo eq "foo:/path?query#frag"); $old = $foo->authority("/? #;@&"); ok(!defined($old) && $foo eq "foo://%2F%3F%20%23;@&/path?query#frag"); $old = $foo->authority("host:80"); ok($old eq "%2F%3F%20%23;@&" && $foo eq "foo://host:80/path?query#frag"); $old = $foo->path("/foo"); ok($old eq "/path" && $foo eq "foo://host:80/foo?query#frag"); $old = $foo->path("bar"); ok($old eq "/foo" && $foo eq "foo://host:80/bar?query#frag"); $old = $foo->path(""); ok($old eq "/bar" && $foo eq "foo://host:80?query#frag"); $old = $foo->path(undef); ok($old eq "" && $foo eq "foo://host:80?query#frag"); $old = $foo->path("@;/?#"); ok($old eq "" && $foo eq "foo://host:80/@;/%3F%23?query#frag"); $old = $foo->path("path"); ok($old eq "/@;/%3F%23" && $foo eq "foo://host:80/path?query#frag"); $old = $foo->query("foo"); ok($old eq "query" && $foo eq "foo://host:80/path?foo#frag"); $old = $foo->query(""); ok($old eq "foo" && $foo eq "foo://host:80/path?#frag"); $old = $foo->query(undef); ok($old eq "" && $foo eq "foo://host:80/path#frag"); $old = $foo->query("/?&=# "); ok(!defined($old) && $foo eq "foo://host:80/path?/?&=%23%20#frag"); $old = $foo->query("query"); ok($old eq "/?&=%23%20" && $foo eq "foo://host:80/path?query#frag"); # Some buildup trics $foo = URI->new(""); $foo->path("path"); $foo->authority("auth"); is($foo, "//auth/path"); $foo = URI->new("", "http:"); $foo->query("query"); $foo->authority("auth"); ok($foo eq "//auth?query" && $foo->has_recognized_scheme); $foo->path("path"); is($foo, "//auth/path?query"); $foo = URI->new(""); $old = $foo->path("foo"); ok($old eq "" && $foo eq "foo" && !$foo->has_recognized_scheme); $old = $foo->path("bar"); ok($old eq "foo" && $foo eq "bar"); $old = $foo->opaque("foo"); ok($old eq "bar" && $foo eq "foo"); $old = $foo->path(""); ok($old eq "foo" && $foo eq ""); $old = $foo->query("q"); ok(!defined($old) && $foo eq "?q"); URI-5.28/t/rsync.t0000644000175000017500000000040714600675475012340 0ustar olafolafuse strict; use warnings; use Test::More tests => 4; use URI (); my $u = URI->new('rsync://gisle@example.com/foo/bar'); is($u->user, "gisle"); is($u->port, 873); is($u->path, "/foo/bar"); $u->port(8730); is($u, 'rsync://gisle@example.com:8730/foo/bar'); URI-5.28/t/split.t0000644000175000017500000000174214600675475012340 0ustar olafolafuse strict; use warnings; use Test::More tests => 17; use URI::Split qw( uri_join uri_split ); sub j { join("-", map { defined($_) ? $_ : "" } @_) } is j(uri_split("p")), "--p--"; is j(uri_split("p?q")), "--p-q-"; is j(uri_split("p#f")), "--p--f"; is j(uri_split("p?q/#f/?")), "--p-q/-f/?"; is j(uri_split("s://a/p?q#f")), "s-a-/p-q-f"; is uri_join("s", "a", "/p", "q", "f"), "s://a/p?q#f"; is uri_join("s", "a", "p", "q", "f"), "s://a/p?q#f"; is uri_join(undef, undef, "", undef, undef), ""; is uri_join(undef, undef, "p", undef, undef), "p"; is uri_join("s", undef, "p"), "s:p"; is uri_join("s"), "s:"; is uri_join(), ""; is uri_join("s", "a"), "s://a"; is uri_join("s", "a/b"), "s://a%2Fb"; is uri_join("s", ":/?#", ":/?#", ":/?#", ":/?#"), "s://:%2F%3F%23/:/%3F%23?:/?%23#:/?#"; is uri_join(undef, undef, "a:b"), "a%3Ab"; is uri_join("s", undef, "//foo//bar"), "s:////foo//bar"; URI-5.28/t/num_eq.t0000644000175000017500000000060514600675475012466 0ustar olafolaf# 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, "!="; URI-5.28/t/query-param.t0000644000175000017500000000372714600675475013455 0ustar olafolafuse strict; use warnings; use Test::More tests => 20; 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; # Same, but using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) ); } } $u->query_param('a' => Foo::Bar::Array->new); $u->query_param('b' => Foo::Bar::Array->new); ok ! $u->query; is $u->as_string, 'http://www.sol.no'; URI-5.28/t/old-absconf.t0000644000175000017500000000133214600675475013367 0ustar olafolafuse strict; use warnings; use Test::More tests => 6; 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"); is($u1->abs->as_string, "http://web/abc"); { local $URI::URL::ABS_REMOTE_LEADING_DOTS; is($u1->abs->as_string, "http://web/../../../abc"); } $u1 = url("http:../../../../abc", "http://web/a/b"); is($u1->abs->as_string, "http://web/abc"); { local $URI::URL::ABS_ALLOW_RELATIVE_SCHEME; is($u1->abs->as_string, "http:../../../../abc"); is($u1->abs(undef,1)->as_string, "http://web/abc"); } is($u1->abs(undef,0)->as_string, "http:../../../../abc"); URI-5.28/t/roytest2.html0000644000175000017500000000707414600675475013505 0ustar olafolaf Examples of Resolving Relative URLs, Part 2

Examples of Resolving Relative URLs, Part 2

This document has an embedded base URL of 
   Content-Base: http://a/b/c/d;p?q=1/2
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.

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).

Tested Clients and Client Libraries

[R]
RFC 2396 (the right way to parse)
[X]
RFC 1808
[1]
Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
[2]
Lynx/2.7.1 libwww-FM/2.14
[3]
MSIE 3.01; Windows 95
[4]
NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12

Synopsis

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.

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.

Examples

              RESULTS                     from
 
g          =  http://a/b/c/g              [R,X,1,2,3,4]

./g        =  http://a/b/c/g              [R,X,1,2,3,4]

g/         =  http://a/b/c/g/             [R,X,1,2,3,4]

/g         =  http://a/g                  [R,X,1,2,3,4]

//g        =  http://g                    [R,X,1,2,3,4]

?y         =  http://a/b/c/?y             [R,1,2,3,4]
              http://a/b/c/d;p?y          [X]

g?y        =  http://a/b/c/g?y            [R,X,1,2,3,4]

g?y/./x    =  http://a/b/c/g?y/./x        [R,X]
              http://a/b/c/g?y/x          [1,2,3,4]

g?y/../x   =  http://a/b/c/g?y/../x       [R,X]
              http://a/b/c/x              [1,2,3,4]

g#s        =  http://a/b/c/g#s            [R,X,1,2,3,4]

g#s/./x    =  http://a/b/c/g#s/./x        [R,X,2,3,4]
              http://a/b/c/g#s/x          [1]

g#s/../x   =  http://a/b/c/g#s/../x       [R,X,2,3,4]
              http://a/b/c/x              [1]

./         =  http://a/b/c/               [R,X,1,2,3,4]

../        =  http://a/b/                 [R,X,1,2,3,4]

../g       =  http://a/b/g                [R,X,1,2,3,4]

../../     =  http://a/                   [R,X,1,2,3,4]

../../g    =  http://a/g                  [R,X,1,2,3,4]
URI-5.28/t/urn-scheme-exceptions.t0000644000175000017500000000101514600675475015423 0ustar olafolafuse strict; use warnings; use Test::More; use URI::urn; plan tests => 6; { require URI::_foreign; # load this before disabling @INC my $count = 0; local @INC = sub { $count++; return }; for ( 0 .. 1 ) { my $uri = URI->new('urn:asdfasdf:1.2.3.4.5.6.7.8.9.10'); is( $count, 1, 'only attempt to load the scheme package once' ); is( $@, '', 'no exception when trying to load a scheme handler class' ); ok( $uri->isa('URI'), 'but URI still instantiated as foreign' ); } } URI-5.28/t/icap.t0000644000175000017500000000212114600675475012111 0ustar olafolafuse strict; use warnings; use Test::More tests => 16; use URI (); my $u = URI->new(""); is($u, "icap://www.example.com/path?q=f%F4o"); is($u->port, 1344); # play with port my $old = $u->port(8080); ok($old == 1344 && $u eq "icap://www.example.com:8080/path?q=f%F4o"); $u->port(1344); is($u, "icap://www.example.com:1344/path?q=f%F4o"); $u->port(""); ok($u eq "icap://www.example.com:/path?q=f%F4o" && $u->port == 1344); $u->port(undef); is($u, "icap://www.example.com/path?q=f%F4o"); my @q = $u->query_form; is_deeply(\@q, ["q", "fo"]); $u->query_form(foo => "bar", bar => "baz"); is($u->query, "foo=bar&bar=baz"); is($u->host, "www.example.com"); is($u->path, "/path"); ok(!$u->secure); $u->scheme("icaps"); is($u->port, 1344); is($u, "icaps://www.example.com/path?foo=bar&bar=baz"); ok($u->secure); $u = URI->new("icaps://%65%78%61%6d%70%6c%65%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"); is($u->canonical, "icaps://example.com/pub/a/2001/08/27/bjornstad.html"); ok($u->has_recognized_scheme); URI-5.28/t/storable.t0000644000175000017500000000035214600675475013014 0ustar olafolafuse strict; use warnings; use Test::Needs 'Storable'; my $inc = -d "blib/lib" ? "blib/lib" : "lib"; system($^X, "-I$inc", "t/storable-test.pl", "store"); system($^X, "-I$inc", "t/storable-test.pl", "retrieve"); unlink('urls.sto'); URI-5.28/t/iri.t0000644000175000017500000000532214600675475011766 0ustar olafolafuse strict; use warnings; use utf8; use Test::More; use Config qw( %Config ); if (defined $Config{useperlio}) { plan tests=>30; } 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"; # example from the docs for host and ihost $u = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html"); is $u, "http://www.xn--ri-sample-fra0f/foo/bar.html"; is $u->host, "www.xn--ri-sample-fra0f"; is $u->ihost, "www.\xC3\xBCri-sample"; is $u->as_iri, "http://www.\xC3\xBCri-sample/foo/bar.html"; $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); URI-5.28/t/sq-brackets.t0000644000175000017500000002001514600675475013416 0ustar olafolafuse strict; use warnings; use Test::More; BEGIN { $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 0; } use URI (); sub show { diag explain("self: ", shift); } #-- test bugfix of https://github.com/libwww-perl/URI/issues/99 is( URI::HAS_RESERVED_SQUARE_BRACKETS, 0, "constant indicates NOT to treat square brackets as reserved characters" ); { my $u = URI->new("http://[::1]/path_with_square_[brackets]?par=value[1]"); is( $u->canonical, "http://[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D", "sqb in path and request" ) or show $u; } { my $u = URI->new("http://[::1]/path_with_square_[brackets]?par=value[1]#fragment[2]"); is( $u->canonical, "http://[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D#fragment%5B2%5D", "sqb in path and request and fragment" ) or show $u; } { my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]?par=value[1]#fragment[2]"); is( $u->canonical, "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D#fragment%5B2%5D", "sqb in userinfo, host, path, request and fragment" ) or show $u; } { my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]?par=value[1]&par[2]=value[2]#fragment[2]"); is( $u->canonical, "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "sqb in userinfo, host, path, request and fragment" ) or show $u; is( $u->scheme() , "http", "scheme"); is( $u->userinfo() , "root%5Buser%5D", "userinfo"); is( $u->host() , "::1", "host"); is( $u->ihost() , "::1", "ihost"); is( $u->port() , "80", "port"); is( $u->default_port() , "80", "default_port"); is( $u->host_port() , "[::1]:80", "host_port"); is( $u->secure() , "0", "is_secure" ); is( $u->path() , "/path_with_square_%5Bbrackets%5D", "path"); is( $u->opaque() , "//root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "opaque"); is( $u->fragment() , "fragment%5B2%5D", "fragment"); is( $u->query() , "par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "query"); is( $u->as_string() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "as_string"); is( $u->has_recognized_scheme() , "1", "has_recognized_scheme"); is( $u->as_iri() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "as_iri"); #TODO: utf8 is( $u->abs( "/BASEDIR")->as_string() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "abs (no change)"); is( $u->rel("../BASEDIR") , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "rel"); is( $u->authority() , "root%5Buser%5D@[::1]", "authority" ); is( $u->path_query() , "/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "path_query"); is( $u->query_keywords() , undef, "query_keywords"); my @segments = $u->path_segments(); is( join(" | ", @segments), " | path_with_square_[brackets]", "segments"); } { #-- form/query related tests my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]/segment[2]?par=value[1]&par[2]=value[2]#fragment[2]"); is( $u->query_form(), "4", "scalar: query_form"); is( join(" | ", $u->query_form()), "par | value[1] | par[2] | value[2]", "list: query_form"); $u->query_form( {} ); is( $u->query(), undef, "query removed"); is( join(" | ", $u->query_form()), "", "list: query_form"); is( $u->canonical(), "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D/segment%5B2%5D#fragment%5B2%5D", "query removed: canonical"); $u->query_form( key1 => 'val1', key2 => 'val[2]' ); is( $u->query(), "key1=val1&key2=val%5B2%5D", "query"); } { #-- path segments my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]/segment[2]?par=value[1]#fragment[2]"); my @segments = $u->path_segments(); is( join(" | ", @segments), " | path_with_square_[brackets] | segment[2]", "segments"); } { #-- rel my $u = URI->new("http://root[user]@[::1]/oldbase/next/path_with_square_[brackets]/segment[2]?par=value[1]#fragment[2]"); #TODO: is userinfo@ optional? is( $u->rel("http://root%5Buser%5D@[::1]/oldbase/next/")->canonical(), "path_with_square_%5Bbrackets%5D/segment%5B2%5D?par=value%5B1%5D#fragment%5B2%5D", "rel/canonical" ); } { #-- various setters my $ip6 = 'fedc:ba98:7654:3210:fedc:ba98:7654:3210'; my $u = URI->new("http://\[" . uc($ip6) . "\]/index.html"); is ($u->canonical(), "http://[$ip6]/index.html", "basic IPv6 URI"); $u->scheme("https"); is ($u->canonical(), "https://[$ip6]/index.html", "basic IPv6 URI"); $u->userinfo("user[42]"); #-- tolerate unescaped '[', ']' is ($u->canonical(), "https://user%5B42%5D@[$ip6]/index.html", "userinfo added (unescaped)"); is ($u->userinfo(), "user%5B42%5D", "userinfo is escaped"); $u->userinfo("user%5B77%5D"); #-- already escaped is ($u->canonical(), "https://user%5B77%5D@[$ip6]/index.html", "userinfo replaced (escaped)"); is ($u->userinfo(), "user%5B77%5D", "userinfo is escaped"); $u->userinfo( q(weird.al$!:secret*[1]++) ); is ($u->canonical(), "https://weird.al\$!:secret*%5B1%5D++@[$ip6]/index.html", "userinfo replaced (escaped2)"); is ($u->userinfo(), "weird.al\$!:secret*%5B1%5D++", "userinfo is escaped2"); $u->userinfo( q(j.doe@example.com:secret) ); is ($u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/index.html", "userinfo replaced (escaped3)"); is ($u->userinfo() , "j.doe%40example.com:secret", "userinfo is escaped3"); $u->host("example.com"); is ($u->canonical(), "https://j.doe%40example.com:secret\@example.com/index.html", "hostname replaced"); $u->host("127.0.0.1"); is ($u->canonical(), "https://j.doe%40example.com:secret\@127.0.0.1/index.html", "hostname replaced"); for my $host ( qw(example.com 127.0.0.1)) { $u->host( $host ); my $expect = "https://j.doe%40example.com:secret\@$host/index.html"; is ($u->canonical(), $expect, "host: $host"); is ($u->host(), $host, "same hosts ($host)"); } for my $host6 ( $ip6, qw(::1) ) { $u->host( $host6 ); my $expect = "https://j.doe%40example.com:secret\@[$host6]/index.html"; is ($u->canonical(), $expect, "IPv6 host: $host6"); is ($u->host(), $host6, "same IPv6 hosts ($host6)"); } $u->host($ip6); $u->path("/subdir/index[1].html"); is( $u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/subdir/index%5B1%5D.html", "path replaced"); $u->fragment("fragment[xyz]"); is( $u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "fragment added"); $u->authority("user[doe]@[::1]"); is( $u->canonical(), "https://user%5Bdoe%5D@[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("::1"); is( $u->canonical(), "https://[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("[::1]:19999"); is( $u->canonical(), "https://[::1]:19999/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); # $u->authority("::1:18000"); #-- theoretically, we could guess an [::1]:18000 ... but for now it will just be ill formatted. # is( $u->canonical(), "https://::1:18000/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("user[abc]\@::1"); is( $u->canonical(), "https://user%5Babc%5D@[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("user[xyz]\@example.com\@[::1]:22022"); is( $u->canonical(), "https://user%5Bxyz%5D%40example.com@[::1]:22022/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); } done_testing; URI-5.28/t/storable-test.pl0000644000175000017500000000110114600675475014132 0ustar olafolafuse strict; use warnings; use Storable qw( retrieve store ); 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 { require Test::More; Test::More->import(tests => 3); note("retrieve"); my $a = retrieve 'urls.sto'; my $u = $a->[0]; #use Data::Dumper; print Dumper($a); is($u, "http://search.cpan.org"); is($u->scheme, "http"); is(ref($u), "URI::http"); } URI-5.28/t/mms.t0000644000175000017500000000105314600675475011774 0ustar olafolafuse strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new(""); #print "$u\n"; is($u, "mms://66.250.188.13/KFOG_FM"); is($u->port, 1755); # play with port my $old = $u->port(8755); ok($old == 1755 && $u eq "mms://66.250.188.13:8755/KFOG_FM"); $u->port(1755); is($u, "mms://66.250.188.13:1755/KFOG_FM"); $u->port(""); ok($u eq "mms://66.250.188.13:/KFOG_FM" && $u->port == 1755); $u->port(undef); is($u, "mms://66.250.188.13/KFOG_FM"); is($u->host, "66.250.188.13"); is($u->path, "/KFOG_FM"); URI-5.28/t/00-report-prereqs.dd0000644000175000017500000000722314600675475014540 0ustar olafolafdo { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '0' }, 'suggests' => { 'JSON::PP' => '2.27300' } }, 'develop' => { 'recommends' => { 'Business::ISBN' => '3.005', 'Dist::Zilla::PluginBundle::Git::VersionManager' => '0.007', 'Storable' => '0' }, 'requires' => { 'File::Spec' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Test::CPAN::Meta' => '0', 'Test::DependentModules' => '0.27', 'Test::MinimumVersion' => '0', 'Test::Mojibake' => '0', 'Test::More' => '0.94', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Cwd' => '0', 'Data::Dumper' => '0', 'Encode' => '0', 'Exporter' => '5.57', 'MIME::Base64' => '2', 'Net::Domain' => '0', 'Scalar::Util' => '0', 'constant' => '0', 'integer' => '0', 'overload' => '0', 'parent' => '0', 'perl' => '5.008001', 'strict' => '0', 'utf8' => '0', 'warnings' => '0' }, 'suggests' => { 'Business::ISBN' => '3.005', 'Regexp::IPv6' => '0.03' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'File::Spec::Functions' => '0', 'File::Temp' => '0', 'Test::Fatal' => '0', 'Test::More' => '0.96', 'Test::Needs' => '0', 'Test::Warnings' => '0', 'utf8' => '0' } } }; $x; }URI-5.28/t/rtsp.t0000644000175000017500000000121314600675475012166 0ustar olafolafuse strict; use warnings; use Test::More tests => 9; use URI (); my $u = URI->new(""); #print "$u\n"; is($u, "rtsp://media.example.com/f%F4o.smi/"); is($u->port, 554); # play with port my $old = $u->port(8554); ok($old == 554 && $u eq "rtsp://media.example.com:8554/f%F4o.smi/"); $u->port(554); is($u, "rtsp://media.example.com:554/f%F4o.smi/"); $u->port(""); ok($u eq "rtsp://media.example.com:/f%F4o.smi/" && $u->port == 554); $u->port(undef); is($u, "rtsp://media.example.com/f%F4o.smi/"); is($u->host, "media.example.com"); is($u->path, "/f%F4o.smi/"); $u->scheme("rtspu"); is($u->scheme, "rtspu"); URI-5.28/t/gopher.t0000644000175000017500000000177414600675475012476 0ustar olafolafuse strict; use warnings; use Test::More tests => 48; use URI (); 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"); URI-5.28/t/sip.t0000644000175000017500000000435314600675475012001 0ustar olafolafuse strict; use warnings; use Test::More tests => 13; use URI (); my $u = URI->new('sip:phone@domain.ext'); ok($u->user eq 'phone' && $u->host eq 'domain.ext' && $u->port eq '5060' && $u->host_port eq 'domain.ext:5060' && $u->authority eq 'phone@domain.ext' && $u eq 'sip:phone@domain.ext'); $u->host_port('otherdomain.int:9999'); ok($u->host eq 'otherdomain.int' && $u->port eq '9999' && $u->host_port eq 'otherdomain.int:9999' && $u->authority eq 'phone@otherdomain.int:9999' && $u eq 'sip:phone@otherdomain.int:9999'); $u->port('5060'); $u = $u->canonical; ok($u->port eq '5060' && $u->host_port eq 'otherdomain.int:5060' && $u->authority eq 'phone@otherdomain.int' && $u eq 'sip:phone@otherdomain.int'); $u->user('voicemail'); ok($u->user eq 'voicemail' && $u->authority eq 'voicemail@otherdomain.int' && $u eq 'sip:voicemail@otherdomain.int'); $u->authority('fax@gateway.ext'); ok($u->user eq 'fax' && $u->host eq 'gateway.ext' && $u->host_port eq 'gateway.ext:5060' && $u->authority eq 'fax@gateway.ext' && $u eq 'sip:fax@gateway.ext'); $u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent'); ok($u->query eq 'Subject=Meeting&Priority=Urgent'); $u->query_form(Subject => 'Lunch', Priority => 'Low'); my @q = $u->query_form; ok($u->query eq 'Subject=Lunch&Priority=Low' && @q == 4 && "@q" eq 'Subject Lunch Priority Low' && $u eq 'sip:phone@domain.ext?Subject=Lunch&Priority=Low'); $u = URI->new('sip:phone@domain.ext;maddr=127.0.0.1;ttl=16'); ok($u->params eq 'maddr=127.0.0.1;ttl=16'); $u->params('maddr=127.0.0.1;ttl=16;x-addedparam=1'); ok($u->params eq 'maddr=127.0.0.1;ttl=16;x-addedparam=1' && $u eq 'sip:phone@domain.ext;maddr=127.0.0.1;ttl=16;x-addedparam=1'); $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; ok($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"); $u = URI->new_abs('sip:phone@domain.ext', 'sip:foo@domain2.ext'); is($u, 'sip:phone@domain.ext'); $u = URI->new('sip:phone@domain.ext'); is($u, $u->abs('http://www.cpan.org/')); is($u, $u->rel('http://www.cpan.org/')); URI-5.28/t/file.t0000644000175000017500000000716114600675475012125 0ustar olafolafuse strict; use warnings; use Test::More; use URI::file (); subtest 'OS related tests (unix, win32, mac)' => sub { 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 for my $t (@tests) { my @t = @$t; my $file = shift @t; my $u = URI->new($file, "file"); my $i = 0; for my $os (@os) { my $f = $u->file($os); my $expect = $t[$i]; $f = "" unless defined $f; $expect = "" unless defined $expect; my $loose; $loose++ if $expect =~ s/^!//; is($f, $expect) or diag "URI->new('$file', 'file')->file('$os')"; if (defined($t[$i]) && !$loose) { my $u2 = URI::file->new($t[$i], $os); is($u2->as_string, $file) or diag "URI::file->new('$t[$i]', '$os')"; } $i++; } } }; SKIP: { skip "No pre 5.11 regression tests yet.", 1 if URI::HAS_RESERVED_SQUARE_BRACKETS; subtest "Including Domains" => sub { is( URI->new('file://example.com/tmp/file.part[1]'), 'file://example.com/tmp/file.part%5B1%5D' ); is( URI->new('file://127.0.0.1/tmp/file.part[2]'), 'file://127.0.0.1/tmp/file.part%5B2%5D' ); is( URI->new('file://localhost/tmp/file.part[3]'), 'file://localhost/tmp/file.part%5B3%5D' ); is( URI->new('file://[1:2:3::beef]/tmp/file.part[4]'), 'file://[1:2:3::beef]/tmp/file.part%5B4%5D' ); is( URI->new('file:///[1:2:3::1ce]/tmp/file.part[5]'), 'file:///%5B1:2:3::1ce%5D/tmp/file.part%5B5%5D' ); }; } subtest "Regression Tests" => sub { # Regression test for https://github.com/libwww-perl/URI/issues/102 { my $with_hashes = URI::file->new_abs("/tmp/###"); is($with_hashes, 'file:///tmp/%23%23%23', "issue GH#102"); } # URI 5.11 introduced a bug where URI::file could return the current # working directory instead of the path defined. # The bug was caused by a wrong quantifier in a regular expression in # URI::_fix_uric_escape_for_host_part() which returned an empty string for # all URIs that needed escaping ('%xx') but did not have a host part. # The empty string in turn caused URI::file->new_abs() to use the current # working directory as a default. { my $file_path = URI::file->new_abs('/a/path/that/pretty likely/does/not/exist-yie1Ahgh0Ohlahqueirequ0iebu8ip')->file(); my $current_dir = URI::file->new_abs()->file(); isnt( $file_path, $current_dir, 'regression test for #102' ); } }; done_testing; URI-5.28/t/old-relbase.t0000644000175000017500000000135414600675475013375 0ustar olafolafuse strict; use warnings; use Test::More tests => 5; use URI::URL qw( 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; is($a1, "http://www.acme.com/foo/bar"); is($a2, "http://www.acme.com/foo/"); is($a3, "http://www.acme.com/foo/zoo/foo"); # We used to have problems with URI::URL as the base class :-( my $u4 = url("foo", "URI::URL"); my $a4 = $u4->abs; ok($u4 eq "foo" && $a4 eq "uri:/foo"); # Test new_abs for URI::URL objects is(URI::URL->new_abs("foo", "http://foo/bar"), "http://foo/foo"); URI-5.28/t/news.t0000644000175000017500000000201714600675475012155 0ustar olafolafuse strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new("news:comp.lang.perl.misc"); ok($u->group eq "comp.lang.perl.misc" && !defined($u->message) && $u->port == 119 && $u eq "news:comp.lang.perl.misc"); $u->host("news.online.no"); ok($u->group eq "comp.lang.perl.misc" && $u->port == 119 && $u eq "news://news.online.no/comp.lang.perl.misc"); $u->group("no.perl", 1 => 10); is($u, "news://news.online.no/no.perl/1-10"); my @g = $u->group; is_deeply(\@g, ["no.perl", 1, 10]); $u->message('42@g.aas.no'); #print "$u\n"; ok($u->message eq '42@g.aas.no' && !defined($u->group) && $u eq 'news://news.online.no/42@g.aas.no'); $u = URI->new("nntp:no.perl"); ok($u->group eq "no.perl" && $u->port == 119); $u = URI->new("snews://snews.online.no/no.perl"); ok($u->group eq "no.perl" && $u->host eq "snews.online.no" && $u->port == 563); $u = URI->new("nntps://nntps.online.no/no.perl"); ok($u->group eq "no.perl" && $u->host eq "nntps.online.no" && $u->port == 563); URI-5.28/t/mailto.t0000644000175000017500000000453414600675475012474 0ustar olafolafuse strict; use warnings; use Test::More; use URI (); my $u = URI->new('mailto:gisle@aas.no'); is $u->to, 'gisle@aas.no', 'parsing normal URI sets to()'; is $u, 'mailto:gisle@aas.no', '... and stringification works'; my $old = $u->to('larry@wall.org'); is $old, 'gisle@aas.no', 'to() returns old value'; is $u->to, 'larry@wall.org', '... and sets new value'; is $u, 'mailto:larry@wall.org', '... and stringification works'; $u->to("?/#"); is $u->to, "?/#", 'to() accepts chars that need escaping'; is $u, 'mailto:%3F/%23', '... and stringification escapes them'; my @h = $u->headers; ok @h == 2 && "@h" eq "to ?/#", '... and headers() returns the correct values'; $u->headers( to => 'gisle@aas.no', cc => 'gisle@ActiveState.com,larry@wall.org', Subject => 'How do you do?', garbage => '/;?#=&', ); @h = $u->headers; ok @h == 8 && "@h" eq 'to gisle@aas.no cc gisle@ActiveState.com,larry@wall.org Subject How do you do? garbage /;?#=&', 'setting multiple headers at once works'; is $u->to, 'gisle@aas.no', '... and to() returns the new value'; #print "$u\n"; is $u, 'mailto:gisle@aas.no?cc=gisle%40ActiveState.com%2Clarry%40wall.org&Subject=How+do+you+do%3F&garbage=%2F%3B%3F%23%3D%26', '... and stringification works'; $u = URI->new("mailto:"); $u->to("gisle"); is $u, 'mailto:gisle', 'starting with an empty URI and setting to() works'; $u = URI->new('mailto:user+detail@example.com'); is $u->to, 'user+detail@example.com', 'subaddress with `+` parsed correctly'; is $u, 'mailto:user+detail@example.com', '... and stringification works'; TODO: { local $TODO = "We can't handle quoted local parts without properly parsing the email addresses"; $u = URI->new('mailto:"foo bar+baz"@example.com'); is $u->to, '"foo bar+baz"@example.com', 'address with quoted local part containing spaces is parsed correctly'; is $u, 'mailto:%22foo%20bar+baz%22@example.com', '... and stringification works'; } # RFC 5321 (4.1.3) - Address Literals # IPv4 $u = URI->new('mailto:user@[127.0.0.1]'); is $u->to, 'user@[127.0.0.1]', 'IPv4 host name'; is $u, 'mailto:user@[127.0.0.1]', '... and stringification works'; # IPv6 $u = URI->new('mailto:user@[IPv6:fe80::e828:209d:20e:c0ae]'); is $u->to, 'user@[IPv6:fe80::e828:209d:20e:c0ae]', 'IPv4 host name'; is $u, 'mailto:user@[IPv6:fe80::e828:209d:20e:c0ae]', '... and stringification works'; done_testing; URI-5.28/t/http.t0000644000175000017500000000212314600675475012156 0ustar olafolafuse strict; use warnings; use Test::More tests => 16; use URI (); my $u = URI->new(""); #print "$u\n"; is($u, "http://www.example.com/path?q=f%F4o"); is($u->port, 80); # play with port my $old = $u->port(8080); ok($old == 80 && $u eq "http://www.example.com:8080/path?q=f%F4o"); $u->port(80); is($u, "http://www.example.com:80/path?q=f%F4o"); $u->port(""); ok($u eq "http://www.example.com:/path?q=f%F4o" && $u->port == 80); $u->port(undef); is($u, "http://www.example.com/path?q=f%F4o"); my @q = $u->query_form; is_deeply(\@q, ["q", "fo"]); $u->query_form(foo => "bar", bar => "baz"); is($u->query, "foo=bar&bar=baz"); is($u->host, "www.example.com"); is($u->path, "/path"); ok(!$u->secure); $u->scheme("https"); is($u->port, 443); is($u, "https://www.example.com/path?foo=bar&bar=baz"); ok($u->secure); $u = URI->new("http://%65%78%61%6d%70%6c%65%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"); is($u->canonical, "http://example.com/pub/a/2001/08/27/bjornstad.html"); ok($u->has_recognized_scheme); URI-5.28/t/urn-oid.t0000644000175000017500000000042614600675475012560 0ustar olafolafuse strict; use warnings; use Test::More tests => 4; use URI (); my $u = URI->new("urn:oid"); $u->oid(1..10); #print "$u\n"; is($u, "urn:oid:1.2.3.4.5.6.7.8.9.10"); is($u->oid, "1.2.3.4.5.6.7.8.9.10"); ok($u->scheme eq "urn" && $u->nid eq "oid"); is($u->oid, $u->nss); URI-5.28/t/roytest5.html0000644000175000017500000000644214600675475013506 0ustar olafolaf Examples of Resolving Relative URLs, Part 5

Examples of Resolving Relative URLs, Part 5

This document has an embedded base URL of 
   Content-Base: http:///s//a/b/c
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.

Tested Clients and Client Libraries

[R]
RFC 2396 (the right way to parse)
Tim
Tim Berners-Lee's proposed interpretation
[1]
Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
[2]
Lynx/2.7.1 libwww-FM/2.14
[3]
MSIE 3.01; Windows 95
[4]
NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)

Synopsis

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).

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.

Examples

                  RESULTS                       from

g:h            =  g:h                           [R,Tim,2,3]
                  http:///s//a/b/g:h            [1]

g              =  http:///s//a/b/g              [R,Tim,1,2,3]

./g            =  http:///s//a/b/g              [R,Tim,1,2,3]

g/             =  http:///s//a/b/g/             [R,Tim,1,2,3]

/g             =  http:///g                     [R,1,2,3]
                  http:///s//a/g                [Tim]

//g            =  http://g                      [R,1,2,3]
                  http:///s//g                  [Tim]

//g/x          =  http://g/x                    [R,1,2,3]
                  http:///s//g/x                [Tim]

///g           =  http:///g                     [R,Tim,1,2,3]

./             =  http:///s//a/b/               [R,Tim,1,2,3]

../            =  http:///s//a/                 [R,Tim,1,2,3]

../g           =  http:///s//a/g                [R,Tim,1,2,3]

../../         =  http:///s//                   [R,1]
                  http:///s//a/../              [Tim,2]
                  http:///s//a/                 [3]

../../g        =  http:///s//g                  [R,1]
                  http:///s//a/../g             [Tim,2]
                  http:///s//a/g                [3]

../../../g     =  http:///s/g                   [R,1]
                  http:///s//a/../../g          [Tim,2]
                  http:///s//a/g                [3]

../../../../g  =  http:///g                     [R,1]
                  http:///s//a/../../../g       [Tim,2]
                  http:///s//a/g                [3]
URI-5.28/t/sort-hash-query-form.t0000644000175000017500000000054214600675475015216 0ustar olafolafuse 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; URI-5.28/t/escape.t0000644000175000017500000000561214600675475012445 0ustar olafolafuse strict; use warnings; use Test::More; use Test::Warnings qw( :all ); use Test::Fatal; use URI::Escape qw( %escapes uri_escape uri_escape_utf8 uri_unescape ); 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)]; is uri_escape ('/', '/'), '%2F', 'it should accept slash in unwanted characters', ; is uri_escape ('][', ']['), '%5D%5B', 'it should accept regex char group terminator in unwanted characters', ; is uri_escape ('[]\\', '][\\'), '%5B%5D%5C', 'it should accept regex escape character at the end of unwanted characters', ; is uri_escape ('[]\\${}', '][\\${`kill -0 -1`}'), '%5B%5D\\%24%7B%7D', 'it should recognize scalar interpolation injection in unwanted characters', ; is uri_escape ('[]\\@{}', '][\\@{`kill -0 -1`}'), '%5B%5D\\%40%7B%7D', 'it should recognize array interpolation injection in unwanted characters', ; is uri_escape ('[]\\%{}', '][\\%{`kill -0 -1`}'), '%5B%5D\\%25%7B%7D', 'it should recognize hash interpolation injection in unwanted characters', ; is uri_escape ('a-b', '-bc'), 'a%2D%62', 'it should recognize leading minus', ; is uri_escape ('a-b', '^-bc'), '%61-b', 'it should recognize leading ^-' ; is uri_escape ('a-b-1', '[:alpha:][:digit:]'), '%61-%62-%31', 'it should recognize character groups' ; is uri_escape ('abcd-', '\w'), '%61%62%63%64-', 'it should allow character class escapes' ; is uri_escape ('a/b`]c^', '/-^'), 'a%2Fb`%5Dc%5E', 'regex characters like / and ^ allowed in range' ; like exception { uri_escape ('abcdef', 'd-c') }, qr/Invalid \[\] range "d-c" in regex/, 'invalid range with max less than min throws exception'; like join('', warnings { is uri_escape ('abcdeQE', '\Qabc\E'), '%61%62%63de%51%45', 'it should allow character class escapes' ; }), qr{ (?-x:Unrecognized escape \\Q in character class passed through in regex) .* (?-x:Unrecognized escape \\E in character class passed through in regex) }xs, 'bad escapes emit warnings'; is uri_escape ('abcd-[]', qr/[bc]/), 'a%62%63d-[]', 'allows regexp objects', ; is uri_escape ('a12b21c12d', qr/12/), 'a%31%32b21c%31%32d', 'allows regexp objects matching multiple characters', ; is $escapes{"%"}, "%25"; 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"; done_testing; URI-5.28/t/clone.t0000644000175000017500000000051314600675475012300 0ustar olafolafuse strict; use warnings; use Test::More tests => 2; 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); is $u1->abs->as_string, "http://yyy/foo"; is $u2->abs->as_string, "http://www/foo"; URI-5.28/t/sq-brackets-legacy.t0000644000175000017500000000212514600675475014662 0ustar olafolafuse strict; use warnings; use Test::More; BEGIN { $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 1; } use URI (); sub show { diag explain("self: ", shift); } #-- test bugfix of https://github.com/libwww-perl/URI/issues/99 no warnings; #-- don't complain about the fragment # being a potential comment my @legacy_tests = qw( ftp://[::1]/ http://example.com/path_with_square_[brackets] http://[::1]/and_[%5Bmixed%5D]_stuff_in_path https://[::1]/path_with_square_[brackets]_and_query?par=value[1]&par=value[2] http://[::1]/path_with_square_[brackets]_and_query?par=value[1]#and_fragment[2] https://root[user]@[::1]/welcome.html ); use warnings; is( URI::HAS_RESERVED_SQUARE_BRACKETS, 1, "constant indicates to treat square brackets as reserved characters (legacy)" ); foreach my $same ( @legacy_tests ) { my $u = URI->new( $same ); is( $u->canonical, $same, "legacy: reserved square brackets not escaped" ) or show $u; } done_testing; URI-5.28/t/ipv6.t0000644000175000017500000000033414600675475012065 0ustar olafolafuse strict; use warnings; use URI (); use Test::More; my $url = URI->new('http://[fe80::e828:209d:20e:c0ae]:375'); is( $url->host, 'fe80::e828:209d:20e:c0ae', 'host' ); is( $url->port, 375, 'port' ); done_testing(); URI-5.28/t/data.t0000644000175000017500000000443414600675475012117 0ustar olafolafuse strict; use warnings; use Test::More tests => 22; use URI (); my $u = URI->new("data:,A%20brief%20note"); ok($u->scheme eq "data" && $u->opaque eq ",A%20brief%20note"); ok($u->media_type eq "text/plain;charset=US-ASCII" && $u->data eq "A brief note"); my $old = $u->data("Fr-i-kl er tingen!"); ok($old eq "A brief note" && $u eq "data:,F%E5r-i-k%E5l%20er%20tingen!"); $old = $u->media_type("text/plain;charset=iso-8859-1"); ok($old eq "text/plain;charset=US-ASCII" && $u eq "data:text/plain;charset=iso-8859-1,F%E5r-i-k%E5l%20er%20tingen!"); $u = URI->new("data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAwAAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFzByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSpa/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJlZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uisF81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PHhhx4dbgYKAAA7"); is($u->media_type, "image/gif"); if ($ENV{DISPLAY} && $ENV{XV}) { open(XV, "| $ENV{XV} -") || die; print XV $u->data; close(XV); } is(length($u->data), 273); $u = URI->new("data:text/plain;charset=iso-8859-7,%be%fg%be"); # %fg is($u->data, "\xBE%fg\xBE"); $u = URI->new("data:application/vnd-xxx-query,select_vcount,fcol_from_fieldtable/local"); is($u->data, "select_vcount,fcol_from_fieldtable/local"); $u->data(""); is($u, "data:application/vnd-xxx-query,"); $u->data("a,b"); $u->media_type(undef); is($u, "data:,a,b"); # Test automatic selection of URI/BASE64 encoding $u = URI->new("data:"); $u->data(""); is($u, "data:,"); $u->data(">"); ok($u eq "data:,%3E" && $u->data eq ">"); $u->data(">>>>>"); is($u, "data:,%3E%3E%3E%3E%3E"); $u->data(">>>>>>"); is($u, "data:;base64,Pj4+Pj4+"); $u->media_type("text/plain;foo=bar"); is($u, "data:text/plain;foo=bar;base64,Pj4+Pj4+"); $u->media_type("foo"); is($u, "data:foo;base64,Pj4+Pj4+"); $u->data(">" x 3000); ok($u eq ("data:foo;base64," . ("Pj4+" x 1000)) && $u->data eq (">" x 3000)); $u->media_type(undef); $u->data(undef); is($u, "data:,"); $u = URI->new("data:foo"); is($u->media_type("bar,bz"), "foo"); is($u->media_type, "bar,bz"); $old = $u->data("new"); ok($old eq "" && $u eq "data:bar%2Cb%E5z,new"); is(URI->new('data:;base64,%51%6D%70%76%5A%58%4A%75')->data, "Bjoern"); URI-5.28/t/geo_point.t0000644000175000017500000000065514600675475013172 0ustar olafolaf#!perl use strict; use warnings; use URI::geo; use Test::More; eval { require Geo::Point }; plan skip_all => 'Needs Geo::Point' if $@; plan tests => 5; ok my $pt = Geo::Point->latlong( 48.208333, 16.372778 ), 'point'; ok my $guri = URI::geo->new( $pt ), 'uri'; is $guri->latitude, 48.208333, 'latitude'; is $guri->longitude, 16.372778, 'longitude'; is $guri->altitude, undef, 'altitude'; # vim:ts=2:sw=2:et:ft=perl URI-5.28/t/escape-char.t0000644000175000017500000000114514600675475013355 0ustar olafolafuse 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; URI-5.28/t/query.t0000644000175000017500000000645514600675475012360 0ustar olafolafuse strict; use warnings; use Test::More tests => 37; use URI (); my $u = URI->new("", "http"); my @q; # For tests using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) ); } package Foo::Bar::Stringy; push( @Foo::Bar::Stringy::ISA, 'Foo::Bar::Array' ); use overload ( '""' => '_as_string', ); sub _as_string { my $self = shift; local $" = '_hello_'; return( "@$self" ); } } $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"; # Same, but using array object $u->query_keywords(Foo::Bar::Array->new([qw(a b)])); is $u, "?a+b"; # Same, but using a stringifyable array object $u->query_keywords(Foo::Bar::Stringy->new([qw(a b)])); is $u, "?a_hello_b"; $u->query_keywords([]); is $u, ""; # Same, but using array object $u->query_keywords(Foo::Bar::Array->new([])); is $u, ""; # Same, but using a stringifyable array object $u->query_keywords(Foo::Bar::Stringy->new([])); 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"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([ 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"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([a => [1..4]])); is $u, "?a=1&a=2&a=3&a=4"; $u->query_form([]); is $u, ""; # Same, but using array object $u->query_form(Foo::Bar::Array->new([])); is $u, ""; # Same, but using a strngifyable array object $u->query_form(Foo::Bar::Stringy->new([])); 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"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([a => 1, b => 2]), ';'); is $u, "?a=1;b=2"; # Same, but using a stringifyable array object $u->query_form("c" => Foo::Bar::Stringy->new([a => 1, b => 2]), "d" => "e", ';'); is $u, "?c=a_hello_1_hello_b_hello_2;d=e"; $u->query_form([]); { local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';'; $u->query_form(a => 1, b => 2); } is $u, "?a=1;b=2"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([])); { local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';'; $u->query_form(a => 1, b => 2); } is $u, "?a=1;b=2"; $u->query('a&b=2'); @q = $u->query_form; is join(":", map { defined($_) ? $_ : '' } @q), "a::b:2"; ok !defined($q[1]); $u->query_form(@q); is $u,'?a&b=2'; URI-5.28/t/scheme-exceptions.t0000644000175000017500000000074014600675475014625 0ustar olafolafuse strict; use warnings; use Test::More; use URI (); require URI::_foreign; # load this before disabling @INC my $count = 0; local @INC = (sub { ++$count; return }); for (0 .. 1) { my $uri = URI->new('notreal://foo/bar'); is($count, 1, 'only attempt to load the scheme package once'); is($@, '', 'no exception when trying to load a scheme handler class'); ok($uri->isa('URI'), 'but URI still instantiated as foreign'); diag $count; } done_testing; URI-5.28/t/rfc2732.t0000644000175000017500000000355614600675475012302 0ustar olafolaf# 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] URI-5.28/t/roytest4.html0000644000175000017500000000721014600675475013477 0ustar olafolaf Examples of Resolving Relative URLs, Part 4

Examples of Resolving Relative URLs, Part 4

This document has an embedded base URL of 
   Content-Base: fred:///s//a/b/c
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.

Tested Clients and Client Libraries

[R]
RFC 2396 (the right way to parse)
Tim
Tim Berners-Lee's proposed interpretation
[1]
Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
[2]
Lynx/2.7.1 libwww-FM/2.14
[3]
MSIE 3.01; Windows 95
[4]
NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)

Synopsis

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).

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.

Examples

                  RESULTS                       from

g:h            =  g:h                           [R,Tim,2,3]
                  fred:///s//a/b/g:h            [1]

g              =  fred:///s//a/b/g              [R,Tim,1,2,3]

./g            =  fred:///s//a/b/g              [R,Tim,2,3]
                  fred:///s//a/b/./g            [1]

g/             =  fred:///s//a/b/g/             [R,Tim,1,2,3]

/g             =  fred:///g                     [R,1,2,3]
                  fred:///s//a/g                [Tim]

//g            =  fred://g                      [R,1,2,3]
                  fred:///s//g                  [Tim]

//g/x          =  fred://g/x                    [R,1,2,3]
                  fred:///s//g/x                [Tim]

///g           =  fred:///g                     [R,Tim,1,2,3]

./             =  fred:///s//a/b/               [R,Tim,2,3]
                  fred:///s//a/b/./             [1]

../            =  fred:///s//a/                 [R,Tim,2,3]
                  fred:///s//a/b/../            [1]

../g           =  fred:///s//a/g                [R,Tim,2,3]
                  fred:///s//a/b/../g           [1]

../../         =  fred:///s//                   [R]
                  fred:///s//a/../              [Tim,2]
                  fred:///s//a/b/../../         [1]
                  fred:///s//a/                 [3]

../../g        =  fred:///s//g                  [R]
                  fred:///s//a/../g             [Tim,2]
                  fred:///s//a/b/../../g        [1]
                  fred:///s//a/g                [3]

../../../g     =  fred:///s/g                   [R]
                  fred:///s//a/../../g          [Tim,2]
                  fred:///s//a/b/../../../g     [1]
                  fred:///s//a/g                [3]

../../../../g  =  fred:///g                     [R]
                  fred:///s//a/../../../g       [Tim,2]
                  fred:///s//a/b/../../../../g  [1]
                  fred:///s//a/g                [3]
URI-5.28/t/ldap.t0000644000175000017500000000460714600675475012130 0ustar olafolafuse strict; use warnings; use Test::More tests => 24; use URI (); my $uri; $uri = URI->new("ldap://host/dn=base?cn,sn?sub?objectClass=*"); is($uri->host, "host"); is($uri->dn, "dn=base"); is(join("-",$uri->attributes), "cn-sn"); is($uri->scope, "sub"); is($uri->filter, "objectClass=*"); $uri = URI->new("ldap:"); $uri->dn("o=University of Michigan,c=US"); ok("$uri" eq "ldap:o=University%20of%20Michigan,c=US" && $uri->dn eq "o=University of Michigan,c=US"); $uri->host("ldap.itd.umich.edu"); is($uri->as_string, "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US"); # check defaults ok($uri->_scope eq "" && $uri->scope eq "base" && $uri->_filter eq "" && $uri->filter eq "(objectClass=*)"); # attribute $uri->attributes("postalAddress"); is($uri, "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US?postalAddress"); # does attribute escapeing work as it should $uri->attributes($uri->attributes, "foo", ",", "*", "?", "#", "\0"); ok($uri->attributes eq "postalAddress,foo,%2C,*,%3F,%23,%00" && join("-", $uri->attributes) eq "postalAddress-foo-,-*-?-#-\0"); $uri->attributes(""); $uri->scope("sub?#"); ok($uri->query eq "?sub%3F%23" && $uri->scope eq "sub?#"); $uri->scope(""); $uri->filter("f=?,#"); ok($uri->query eq "??f=%3F,%23" && $uri->filter eq "f=?,#"); $uri->filter("(int=\\00\\00\\00\\04)"); is($uri->query, "??(int=%5C00%5C00%5C00%5C04)"); $uri->filter(""); $uri->extensions("!bindname" => "cn=Manager,co=Foo"); my %ext = $uri->extensions; ok($uri->query eq "???!bindname=cn=Manager%2Cco=Foo" && keys %ext == 1 && $ext{"!bindname"} eq "cn=Manager,co=Foo"); $uri = URI->new("ldap://LDAP-HOST:389/o=University%20of%20Michigan,c=US?postalAddress?base?ObjectClass=*?FOO=Bar,bindname=CN%3DManager%CO%3dFoo"); is($uri->canonical, "ldap://ldap-host/o=University%20of%20Michigan,c=US?postaladdress???foo=Bar,bindname=CN=Manager%CO=Foo"); note $uri; note $uri->canonical; ok(!$uri->secure); $uri = URI->new("ldaps://host/dn=base?cn,sn?sub?objectClass=*"); is($uri->host, "host"); is($uri->port, 636); is($uri->dn, "dn=base"); ok($uri->secure); $uri = URI->new("ldapi://%2Ftmp%2Fldap.sock/????x-mod=-w--w----"); is($uri->authority, "%2Ftmp%2Fldap.sock"); is($uri->un_path, "/tmp/ldap.sock"); $uri->un_path("/var/x\@foo:bar/"); is($uri, "ldapi://%2Fvar%2Fx%40foo%3Abar%2F/????x-mod=-w--w----"); %ext = $uri->extensions; is($ext{"x-mod"}, "-w--w----"); URI-5.28/t/userpass.t0000644000175000017500000000065514600675475013054 0ustar olafolafuse strict; use warnings; use Test::More; use URI; my $uri = URI->new('rsync://foo:bar@example.com'); like $uri->as_string, qr/foo:bar\@example\.com/, 'userinfo is included'; $uri->password(undef); like $uri->as_string, qr/foo\@example\.com/, 'set password to undef'; $uri = URI->new('rsync://0:bar@example.com'); $uri->password(undef); like $uri->as_string, qr/0\@example\.com/, '... also for username "0"'; done_testing; URI-5.28/t/geo_basic.t0000644000175000017500000000334614600675475013122 0ustar olafolaf#!perl use strict; use warnings; use URI; use Test::More tests => 24; { ok my $guri = URI->new( 'geo:54.786989,-2.344214' ), 'created'; isa_ok $guri, 'URI::geo'; is $guri->scheme, 'geo', 'scheme'; is $guri->opaque, '54.786989,-2.344214', 'opaque'; is $guri->path, '54.786989,-2.344214', 'path'; is $guri->fragment, undef, 'fragment'; is $guri->latitude, 54.786989, 'latitude'; is $guri->longitude, -2.344214, 'longitude'; is $guri->altitude, undef, 'altitude'; is $guri->as_string, 'geo:54.786989,-2.344214', 'stringify'; $guri->altitude( 120 ); is $guri->altitude, 120, 'altitude set'; is $guri->as_string, 'geo:54.786989,-2.344214,120', 'stringify w/ alt'; $guri->latitude( 55.167469 ); $guri->longitude( -1.700663 ); is $guri->as_string, 'geo:55.167469,-1.700663,120', 'stringify updated w/ alt'; } { ok my $guri = URI->new( 'geo:55.167469,-1.700663,120' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ 55.167469, -1.700663, 120 ], 'got location'; } { ok my $guri = URI->new( 'geo:-33,30' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ -33, 30, undef ], 'got location'; } { ok my $guri = URI->new( 'geo:-33,30,12.3;crs=wgs84;u=12' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ -33, 30, 12.3 ], 'got location'; is $guri->crs, 'wgs84', 'crs'; is $guri->uncertainty, 12, 'u'; } { eval { URI->new( 'geo:1' ) }; like $@, qr/Badly formed/, 'error ok'; } { ok( URI->new( 'geo:55,1' )->eq( URI->new( 'geo:55,1' ) ), 'eq 1' ); ok( URI->new( 'geo:90,1' )->eq( URI->new( 'geo:90,2' ) ), 'eq 2' ); } # vim:ts=2:sw=2:et:ft=perl URI-5.28/t/old-base.t0000644000175000017500000010404414600675475012672 0ustar olafolafuse strict; use warnings; use Test::More 0.96; use URI::URL qw( url ); use URI::Escape qw(uri_escape uri_unescape); use File::Temp qw(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', undef, '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'); # Same, but using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) ); } } $url->query_form(a => Foo::Bar::Array->new(['foo', 'bar']), b => 'foo', c => Foo::Bar::Array->new(['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@hst: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); if ( URI::HAS_RESERVED_SQUARE_BRACKETS ) { # legacy: this was legal before '[' and ']' were restricted to the host part of the URI (see: RFC 3513 & RFC 3986) 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'); } else { 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%5B%5C%5D%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 = < g = ./g = g/ = /g = //g = # ?y = g?y = g?y/./x = #s = g#s = g#s/./x = g?y#s = # ;x = g;x = g;x?y#s = . = ./ = .. = ../ = ../g = ../.. = ../../ = ../../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: <> = 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 of a URL. ../../../g = ../../../../g = Similarly, parsers must avoid treating "." and ".." as special when they are not complete components of a relative path. /./g = /../g = g. = .g = g.. = ..g = Less likely are cases where the relative URL uses unnecessary or nonsensical forms of the "." and ".." complete path segments. ./../g = ./g/. = g/./h = g/../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 = 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*]*)>/) { 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" $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"); } URI-5.28/t/roytest1.html0000644000175000017500000001650514600675475013503 0ustar olafolaf Examples of Resolving Relative URLs

Examples of Resolving Relative URLs

This document has an embedded base URL of 
   Content-Base: http://a/b/c/d;p?q
the relative URLs should be resolved as shown below.

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).

Tested Clients and Client Libraries

[R]
RFC 2396 (the right way to parse)
[X]
RFC 1808
[1]
Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
[2]
Lynx/2.7.1 libwww-FM/2.14
[3]
MSIE 3.01; Windows 95
[4]
NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
[5]
libwww-perl/5.14 [Martijn Koster]

Normal Examples

              RESULTS                     from
 
g:h        =  g:h                         [R,X,2,3,4,5]
              http://a/b/c/g:h            [1]

g          =  http://a/b/c/g              [R,X,1,2,3,4,5]

./g        =  http://a/b/c/g              [R,X,1,2,3,4,5]

g/         =  http://a/b/c/g/             [R,X,1,2,3,4,5]

/g         =  http://a/g                  [R,X,1,2,3,4,5]

//g        =  http://g                    [R,X,1,2,3,4,5]

?y         =  http://a/b/c/?y             [R,1,2,3,4]
              http://a/b/c/d;p?y          [X,5]

g?y        =  http://a/b/c/g?y            [R,X,1,2,3,4,5]

#s         =  (current document)#s        [R,2,4]
              http://a/b/c/d;p?q#s        [X,1,3,5]

g#s        =  http://a/b/c/g#s            [R,X,1,2,3,4,5]

g?y#s      =  http://a/b/c/g?y#s          [R,X,1,2,3,4,5]

;x         =  http://a/b/c/;x             [R,1,2,3,4]
              http://a/b/c/d;x            [X,5]

g;x        =  http://a/b/c/g;x            [R,X,1,2,3,4,5]

g;x?y#s    =  http://a/b/c/g;x?y#s        [R,X,1,2,3,4,5]

.          =  http://a/b/c/               [R,X,2,5]
              http://a/b/c/.              [1]
              http://a/b/c                [3,4]

./         =  http://a/b/c/               [R,X,1,2,3,4,5]

..         =  http://a/b/                 [R,X,2,5]
              http://a/b                  [1,3,4]

../        =  http://a/b/                 [R,X,1,2,3,4,5]

../g       =  http://a/b/g                [R,X,1,2,3,4,5]

../..      =  http://a/                   [R,X,2,5]
              http://a                    [1,3,4]

../../     =  http://a/                   [R,X,1,2,3,4,5]

../../g    =  http://a/g                  [R,X,1,2,3,4,5]

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 refers to the start of the current document. 

<>         =  (current document)          [R,2,4]
              http://a/b/c/d;p?q          [X,3,5]
              http://a/b/c/               [1]
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. 
../../../g    =  http://a/../g            [R,X,2,4,5]
                 http://a/g               [R,1,3]

../../../../g =  http://a/../../g         [R,X,2,4,5]
                 http://a/g               [R,1,3]
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.

Similarly, parsers must avoid treating "." and ".." as special when they are not complete components of a relative path. 

/./g      =  http://a/./g                 [R,X,2,3,4,5]
             http://a/g                   [1]

/../g     =  http://a/../g                [R,X,2,3,4,5]
             http://a/g                   [1]

g.        =  http://a/b/c/g.              [R,X,1,2,3,4,5]

.g        =  http://a/b/c/.g              [R,X,1,2,3,4,5]

g..       =  http://a/b/c/g..             [R,X,1,2,3,4,5]

..g       =  http://a/b/c/..g             [R,X,1,2,3,4,5]
Less likely are cases where the relative URL uses unnecessary or nonsensical forms of the "." and ".." complete path segments. 
./../g     =  http://a/b/g                [R,X,1,2,5]
              http://a/b/c/../g           [3,4]

./g/.      =  http://a/b/c/g/             [R,X,2,5]
              http://a/b/c/g/.            [1]
              http://a/b/c/g              [3,4]

g/./h      =  http://a/b/c/g/h            [R,X,1,2,3,4,5]

g/../h     =  http://a/b/c/h              [R,X,1,2,3,4,5]

g;x=1/./y  =  http://a/b/c/g;x=1/y        [R,1,2,3,4]
              http://a/b/c/g;x=1/./y      [X,5]

g;x=1/../y =  http://a/b/c/y              [R,1,2,3,4]
              http://a/b/c/g;x=1/../y     [X,5]
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. 
g?y/./x    =  http://a/b/c/g?y/./x        [R,X,5]
              http://a/b/c/g?y/x          [1,2,3,4]

g?y/../x   =  http://a/b/c/g?y/../x       [R,X,5]
              http://a/b/c/x              [1,2,3,4]

g#s/./x    =  http://a/b/c/g#s/./x        [R,X,2,3,4,5]
              http://a/b/c/g#s/x          [1]

g#s/../x   =  http://a/b/c/g#s/../x       [R,X,2,3,4,5]
              http://a/b/c/x              [1]
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. 
http:g    =  http:g                       [R,X,5]
          |  http://a/b/c/g               [1,2,3,4]  (ok for compat.)

http:     =  http:                        [R,X,5]
             http://a/b/c/                [1]
             http://a/b/c/d;p?q           [2,3,4]
URI-5.28/t/path-segments.t0000644000175000017500000000175014600675475013763 0ustar olafolafuse 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'; } URI-5.28/t/rel.t0000644000175000017500000000103514600675475011762 0ustar olafolafuse 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"); URI-5.28/t/roytest3.html0000644000175000017500000000601714600675475013502 0ustar olafolaf Examples of Resolving Relative URLs, Part 3

Examples of Resolving Relative URLs, Part 3

This document has an embedded base URL of 
   Content-Base: http://a/b/c/d;p=1/2?q
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.

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).

Tested Clients and Client Libraries

[R]
RFC 2396 (the right way to parse)
[X]
RFC 1808
[1]
Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
[2]
Lynx/2.7.1 libwww-FM/2.14
[3]
MSIE 3.01; Windows 95
[4]
NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12

Synopsis

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.

Examples

              RESULTS                     from

g          =  http://a/b/c/d;p=1/g        [R,1,2,3,4]
              http://a/b/c/g              [X]

./g        =  http://a/b/c/d;p=1/g        [R,1,2,3,4]
              http://a/b/c/g              [X]

g/         =  http://a/b/c/d;p=1/g/       [R,1,2,3,4]
              http://a/b/c/g/             [X]

g?y        =  http://a/b/c/d;p=1/g?y      [R,1,2,3,4]
              http://a/b/c/g?y            [X]

;x         =  http://a/b/c/d;p=1/;x       [R,1,2,3,4]
              http://a/b/c/d;x            [X]

g;x        =  http://a/b/c/d;p=1/g;x      [R,1,2,3,4]
              http://a/b/c/g;x            [X]

g;x=1/./y  =  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]

g;x=1/../y =  http://a/b/c/d;p=1/y        [R,1,2,3,4]
              http://a/b/c/g;x=1/../y     [X]

./         =  http://a/b/c/d;p=1/         [R,1,2,3,4]
              http://a/b/c/               [X]

../        =  http://a/b/c/               [R,1,2,3,4]
              http://a/b/                 [X]

../g       =  http://a/b/c/g              [R,1,2,3,4]
              http://a/b/g                [X]

../../     =  http://a/b/                 [R,1,2,3,4]
              http://a/                   [X]

../../g    =  http://a/b/g                [R,1,2,3,4]
              http://a/g                  [X]
URI-5.28/t/punycode.t0000644000175000017500000000434314600675475013033 0ustar olafolafuse strict; use warnings; use utf8; use Test::More tests => 15; use URI::_punycode qw( decode_punycode encode_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); } URI-5.28/t/roy-test.t0000644000175000017500000000165014600675475012771 0ustar olafolafuse strict; use warnings; use Test::More 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: $!"; note $file; my $base = undef; while () { if (/^/) { $base = URI->new($1); } elsif (/^.*<\/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"; } is(URI->new($link)->abs($base), $exp); $no++; } } close(FILE); } URI-5.28/t/urn-isbn.t0000644000175000017500000000135214600675475012737 0ustar olafolafuse strict; use warnings; use Test::Needs { 'Business::ISBN' => 3.005 }; use Test::More tests => 13; use URI (); my $u = URI->new("URN:ISBN:0395363411"); ok($u eq "URN:ISBN:0395363411" && $u->scheme eq "urn" && $u->nid eq "isbn"); is($u->canonical, "urn:isbn:0-395-36341-1"); is($u->isbn, "0-395-36341-1"); is($u->isbn_group_code, 0); is($u->isbn_publisher_code, 395); is($u->isbn13, "9780395363416"); is($u->nss, "0395363411"); is($u->isbn("0-88730-866-x"), "0-395-36341-1"); is($u->nss, "0-88730-866-x"); is($u->isbn, "0-88730-866-X"); ok(URI::eq("urn:isbn:088730866x", "URN:ISBN:0-88-73-08-66-X")); # try to illegal ones $u = URI->new("urn:ISBN:abc"); is($u, "urn:ISBN:abc"); ok($u->nss eq "abc" && !defined $u->isbn); URI-5.28/t/heuristic.t0000644000175000017500000000632714600675475013210 0ustar olafolafuse 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; }; } use Test::More tests => 26; use URI::Heuristic qw( uf_url uf_urlstr ); if (shift) { $URI::Heuristic::DEBUG++; open(STDERR, ">&STDOUT"); # redirect STDERR } is(uf_urlstr("http://www.sn.no/"), "http://www.sn.no/"); if ($^O eq "MacOS") { is(uf_urlstr("etc:passwd"), "file:/etc/passwd"); } else { is(uf_urlstr("/etc/passwd"), "file:/etc/passwd"); } if ($^O eq "MacOS") { is(uf_urlstr(":foo.txt"), "file:./foo.txt"); } else { is(uf_urlstr("./foo.txt"), "file:./foo.txt"); } is(uf_urlstr("ftp.aas.no/lwp.tar.gz"), "ftp://ftp.aas.no/lwp.tar.gz"); if($^O eq "MacOS") { # its a weird, but valid, MacOS path, so it can't be left alone is(uf_urlstr("C:\\CONFIG.SYS"), "file:/C/%5CCONFIG.SYS"); } else { is(uf_urlstr("C:\\CONFIG.SYS"), "file:C:\\CONFIG.SYS"); } { local $ENV{LC_ALL} = ""; local $ENV{LANG} = ""; local $ENV{HTTP_ACCEPT_LANGUAGE} = ""; $ENV{LC_ALL} = "en_GB.UTF-8"; undef $URI::Heuristic::MY_COUNTRY; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org|co)\.uk/camel\.gif$,); use Net::Domain (); $ENV{LC_ALL} = "C"; { no warnings; *Net::Domain::hostfqdn = sub { return 'vasya.su' } } undef $URI::Heuristic::MY_COUNTRY; is(uf_urlstr("perl/camel.gif"), "http://www.perl.su/camel.gif"); $ENV{LC_ALL} = "C"; { no warnings; *Net::Domain::hostfqdn = sub { return '' } } undef $URI::Heuristic::MY_COUNTRY; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(com|org)/camel\.gif$,); $ENV{HTTP_ACCEPT_LANGUAGE} = "en-ca"; undef $URI::Heuristic::MY_COUNTRY; is(uf_urlstr("perl/camel.gif"), "http://www.perl.ca/camel.gif"); } $URI::Heuristic::MY_COUNTRY = "bv"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(com|org)/camel\.gif$,); # Backwards compatibility; uk != United Kingdom in ISO 3166 $URI::Heuristic::MY_COUNTRY = "uk"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org|co)\.uk/camel\.gif$,); $URI::Heuristic::MY_COUNTRY = "gb"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org|co)\.uk/camel\.gif$,); $ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com"; is(uf_urlstr("perl"), "http://www.perl.org"); { local $ENV{URL_GUESS_PATTERN} = ""; is(uf_urlstr("perl"), "http://perl"); is(uf_urlstr("http:80"), "http:80"); is(uf_urlstr("mailto:gisle\@aas.no"), "mailto:gisle\@aas.no"); is(uf_urlstr("gisle\@aas.no"), "mailto:gisle\@aas.no"); is(uf_urlstr("Gisle.Aas\@aas.perl.org"), "mailto:Gisle.Aas\@aas.perl.org"); is(uf_url("gopher.sn.no")->scheme, "gopher"); is(uf_urlstr("123.3.3.3:8080/foo"), "http://123.3.3.3:8080/foo"); is(uf_urlstr("123.3.3.3:443/foo"), "https://123.3.3.3:443/foo"); is(uf_urlstr("123.3.3.3:21/foo"), "ftp://123.3.3.3:21/foo"); is(uf_url("FTP.example.com")->scheme, "ftp"); is(uf_url("ftp2.example.com")->scheme, "ftp"); is(uf_url("ftp")->scheme, "ftp"); is(uf_url("https.example.com")->scheme, "https"); } URI-5.28/t/geo_construct.t0000644000175000017500000000415014600675475014057 0ustar olafolaf#!perl use strict; use warnings; use URI::geo; use Test::More; use Data::Dumper; package Pointy; sub new { my ( $class, $lat, $lon, $alt ) = @_; return bless { lat => $lat, lon => $lon, alt => $alt }, $class; } sub lat { shift->{lat} } sub lon { shift->{lon} } sub alt { shift->{alt} } package Pointy::Point; our @ISA = qw( Pointy ); sub latlong { my $self = shift; return $self->{lat}, $self->{lon}; } package main; my @case = ( { name => 'Simple', args => [ 54.786989, -2.344214 ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Simple w/ alt', args => [ 54.786989, -2.344214, 120 ], lat => 54.786989, lon => -2.344214, alt => 120, }, { name => 'Array', args => [ [ 54.786989, -2.344214 ] ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Hash, short names', args => [ { lat => 54.786989, lon => -2.344214 } ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Hash, long names', args => [ { latitude => 54.786989, longitude => -2.344214, elevation => 3 } ], lat => 54.786989, lon => -2.344214, alt => 3, }, { name => 'Point object', args => [ new Pointy( 54.786989, -2.344214, 3 ) ], lat => 54.786989, lon => -2.344214, alt => 3, }, { name => 'Point object', args => [ new Pointy::Point( 54.786989, -2.344214 ) ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'URI::geo object', args => [ new URI::geo( 54.786989, -2.344214, 99 ) ], lat => 54.786989, lon => -2.344214, alt => 99, }, ); plan tests => @case * 5; for my $case ( @case ) { my ( $name, $args, $lat, $lon, $alt ) = @{$case}{ 'name', 'args', 'lat', 'lon', 'alt' }; ok my $guri = URI::geo->new( @$args ), "$name: created"; is $guri->scheme, 'geo', "$name: scheme"; is $guri->latitude, $lat, "$name: latitude"; is $guri->longitude, $lon, "$name: longitude"; is $guri->altitude, $alt, "$name: altitude"; } # vim:ts=2:sw=2:et:ft=perl URI-5.28/t/utf8.t0000644000175000017500000000103714600675475012070 0ustar olafolafuse 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 qw( decode_utf8 ); $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]), 'äöü'); URI-5.28/t/00-report-prereqs.t0000644000175000017500000001360114600675475014411 0ustar olafolaf#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.029 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if grep { $_ eq $mod } @exclude; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; if ($mod eq 'perl') { push @reports, ['perl', $want, $]]; next; } my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error || @dep_errors ) { diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass('Reported prereqs'); # vim: ts=4 sts=4 sw=4 et: URI-5.28/t/idna.t0000644000175000017500000000076714600675475012126 0ustar olafolafuse 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"; URI-5.28/t/cwd.t0000644000175000017500000000026014600675475011754 0ustar olafolafuse 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'); URI-5.28/t/pop.t0000644000175000017500000000147414600675475012005 0ustar olafolafuse strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new('pop://aas@pop.sn.no'); ok($u->user eq "aas" && !defined($u->auth) && $u->host eq "pop.sn.no" && $u->port == 110 && $u eq 'pop://aas@pop.sn.no'); $u->auth("+APOP"); ok($u->auth eq "+APOP" && $u eq 'pop://aas;AUTH=+APOP@pop.sn.no'); $u->user("gisle"); ok($u->user eq "gisle" && $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no'); $u->port(4000); is($u, 'pop://gisle;AUTH=+APOP@pop.sn.no:4000'); $u = URI->new("pop:"); $u->host("pop.sn.no"); $u->user("aas"); $u->auth("*"); is($u, 'pop://aas;AUTH=*@pop.sn.no'); $u->auth(undef); is($u, 'pop://aas@pop.sn.no'); $u->user(undef); is($u, 'pop://pop.sn.no'); # Try some funny characters too $u->user('fr;k@l'); ok($u->user eq 'fr;k@l' && $u eq 'pop://f%E5r%3Bk%40l@pop.sn.no'); URI-5.28/LICENSE0000644000175000017500000004641614600675475011571 0ustar olafolafThis software is copyright (c) 1998 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 1998 by Gisle Aas. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 1998 by Gisle Aas. This is free software, licensed under: The Perl Artistic License 1.0 The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End URI-5.28/MANIFEST0000644000175000017500000000424614600675475011710 0ustar olafolaf# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.031. CONTRIBUTING.md Changes LICENSE MANIFEST META.json META.yml Makefile.PL README cpanfile dist.ini lib/URI.pm lib/URI/Escape.pm lib/URI/Heuristic.pm lib/URI/IRI.pm lib/URI/QueryParam.pm lib/URI/Split.pm lib/URI/URL.pm lib/URI/WithBase.pm lib/URI/_foreign.pm lib/URI/_generic.pm lib/URI/_idna.pm lib/URI/_ldap.pm lib/URI/_login.pm lib/URI/_punycode.pm lib/URI/_query.pm lib/URI/_segment.pm lib/URI/_server.pm lib/URI/_userpass.pm lib/URI/data.pm lib/URI/file.pm lib/URI/file/Base.pm lib/URI/file/FAT.pm lib/URI/file/Mac.pm lib/URI/file/OS2.pm lib/URI/file/QNX.pm lib/URI/file/Unix.pm lib/URI/file/Win32.pm lib/URI/ftp.pm lib/URI/geo.pm lib/URI/gopher.pm lib/URI/http.pm lib/URI/https.pm lib/URI/icap.pm lib/URI/icaps.pm lib/URI/ldap.pm lib/URI/ldapi.pm lib/URI/ldaps.pm lib/URI/mailto.pm lib/URI/mms.pm lib/URI/news.pm lib/URI/nntp.pm lib/URI/nntps.pm lib/URI/pop.pm lib/URI/rlogin.pm lib/URI/rsync.pm lib/URI/rtsp.pm lib/URI/rtspu.pm lib/URI/sftp.pm lib/URI/sip.pm lib/URI/sips.pm lib/URI/snews.pm lib/URI/ssh.pm lib/URI/telnet.pm lib/URI/tn3270.pm lib/URI/urn.pm lib/URI/urn/isbn.pm lib/URI/urn/oid.pm perlimports.toml t/00-report-prereqs.dd t/00-report-prereqs.t t/abs.t t/clone.t t/cwd.t t/data.t t/escape-char.t t/escape.t t/file.t t/ftp.t t/generic.t t/geo_basic.t t/geo_construct.t t/geo_point.t t/gopher.t t/heuristic.t t/http.t t/icap.t t/idna.t t/ipv6.t t/iri.t t/ldap.t t/mailto.t t/mix.t t/mms.t t/news.t t/num_eq.t t/old-absconf.t t/old-base.t t/old-file.t t/old-relbase.t t/path-segments.t t/pop.t t/punycode.t t/query-param.t t/query.t t/rel.t t/rfc2732.t t/roy-test.t t/roytest1.html t/roytest2.html t/roytest3.html t/roytest4.html t/roytest5.html t/rsync.t t/rtsp.t t/scheme-exceptions.t t/sip.t t/sort-hash-query-form.t t/split.t t/sq-brackets-legacy.t t/sq-brackets.t t/storable-test.pl t/storable.t t/urn-isbn.t t/urn-oid.t t/urn-scheme-exceptions.t t/userpass.t t/utf8.t uri-test xt/author/00-compile.t xt/author/distmeta.t xt/author/minimum-version.t xt/author/mojibake.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/portability.t xt/author/test-version.t xt/dependent-modules.t URI-5.28/Makefile.PL0000644000175000017500000000370014600675475012523 0ustar olafolaf# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.031. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Uniform Resource Identifiers (absolute and relative)", "AUTHOR" => "Gisle Aas ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "URI", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "URI", "PREREQ_PM" => { "Carp" => 0, "Cwd" => 0, "Data::Dumper" => 0, "Encode" => 0, "Exporter" => "5.57", "MIME::Base64" => 2, "Net::Domain" => 0, "Scalar::Util" => 0, "constant" => 0, "integer" => 0, "overload" => 0, "parent" => 0, "strict" => 0, "utf8" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "Test::Fatal" => 0, "Test::More" => "0.96", "Test::Needs" => 0, "Test::Warnings" => 0, "utf8" => 0 }, "VERSION" => "5.28", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Cwd" => 0, "Data::Dumper" => 0, "Encode" => 0, "Exporter" => "5.57", "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "MIME::Base64" => 2, "Net::Domain" => 0, "Scalar::Util" => 0, "Test::Fatal" => 0, "Test::More" => "0.96", "Test::Needs" => 0, "Test::Warnings" => 0, "constant" => 0, "integer" => 0, "overload" => 0, "parent" => 0, "strict" => 0, "utf8" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); URI-5.28/dist.ini0000644000175000017500000001136514600675475012223 0ustar olafolafname = URI author = Gisle Aas license = Perl_5 main_module = lib/URI.pm copyright_holder = Gisle Aas copyright_year = 1998 ; for version management, see the end of this file ; Gather stuff in [Git::GatherDir] exclude_filename = LICENSE exclude_filename = README.md exclude_filename = draft-duerst-iri-bis.txt exclude_filename = rfc2396.txt exclude_filename = rfc3986.txt exclude_filename = rfc3987.txt [Encoding] encoding = latin1 filename = t/data.t filename = t/escape.t filename = t/http.t filename = t/icap.t filename = t/old-base.t filename = t/pop.t filename = t/rtsp.t filename = uri-test ; Handle the META resources [MetaConfig] [MetaProvides::Package] inherit_version = 0 inherit_missing = 0 [MetaNoIndex] directory = t directory = xt [MetaYAML] [MetaJSON] [MetaResources] x_IRC = irc://irc.perl.org/#lwp x_MailingList = mailto:libwww@perl.org [Git::Contributors] version = 0.029 order_by = commits [GithubMeta] issues = 1 user = libwww-perl [Manifest] [License] ; make the bin dir executables [ExecDir] ; [ShareDir] [Prereqs::FromCPANfile] [Readme] [MakeMaker] [CheckChangesHasContent] ; TODO strict and warnings to quiet the kwalitee tests ; [Test::Kwalitee] ; filename = xt/author/kwalitee.t [MojibakeTests] [Test::Version] [Test::ReportPrereqs] [Test::Compile] bail_out_on_fail = 1 xt_mode = 1 [Test::Portability] ; TODO perltidy for NoTabs and namespace::autoclean ; [Test::CleanNamespaces] ; TODO ; [Test::NoTabs] ; TODO ; [Test::EOL] ; TODO [MetaTests] [Test::MinimumVersion] [PodSyntaxTests] [Test::Pod::Coverage::Configurable] skip = URI::IRI skip = URI::_foreign skip = URI::_idna skip = URI::_login skip = URI::_ldap skip = URI::file::QNX skip = URI::nntp skip = URI::urn::isbn skip = URI::urn::oid skip = URI::sftp trustme = URI => qr/^(?:STORABLE_freeze|STORABLE_thaw|TO_JSON|implementor)$/ trustme = URI::Escape => qr/^(?:escape_char)$/ trustme = URI::Heuristic => qr/^(?:MY_COUNTRY|uf_url|uf_urlstr)$/ trustme = URI::URL => qr/^(?:address|article|crack|dos_path|encoded822addr|eparams|epath|frag)$/ trustme = URI::URL => qr/^(?:full_path|groupart|keywords|local_path|mac_path|netloc|newlocal|params|path|path_components|print_on|query|strict|unix_path|url|vms_path)$/ trustme = URI::WithBase => qr/^(?:can|clone|eq|new_abs)$/ trustme = URI::_query => qr/^(?:equery|query|query_form|query_form_hash|query_keywords|query_param|query_param_append|query_param_delete)$/ trustme = URI::_segment => qr/^(?:new)$/ trustme = URI::_userpass => qr/^(?:password|user)$/ trustme = URI::file => qr/^(?:os_class)$/ trustme = URI::file::Base => qr/^(?:dir|file|new)$/ trustme = URI::file::FAT => qr/^(?:fix_path)$/ trustme = URI::file::Mac => qr/^(?:dir|file)$/ trustme = URI::file::OS2 => qr/^(?:file)$/ trustme = URI::file::Unix => qr/^(?:file)$/ trustme = URI::file::Win32 => qr/^(?:file|fix_path)$/ trustme = URI::ftp => qr/^(?:password|user)$/ trustme = URI::gopher => qr/^(?:gopher_type|gtype|search|selector|string)$/ trustme = URI::ldapi => qr/^(?:un_path)$/ trustme = URI::mailto => qr/^(?:headers|to)$/ trustme = URI::news => qr/^(?:group|message)$/ trustme = URI::pop => qr/^(?:auth|user)$/ trustme = URI::sip => qr/^(?:params|params_form)$/ trustme = URI::urn => qr/^(?:nid|nss)$/ [Test::PodSpelling] wordlist = Pod::Wordlist spell_cmd = aspell list stopword = Berners stopword = CRS stopword = etype stopword = evalue stopword = IDNA stopword = ISBNs stopword = Koster stopword = lon stopword = lowercasing stopword = Martijn stopword = Masinter stopword = Miyagawa stopword = OIDs stopword = OpenLDAP stopword = Punycode stopword = relativize stopword = Tatsuhiko stopword = TCP stopword = TLS stopword = UDP stopword = UNC stopword = uppercasing stopword = unicode stopword = xn ;;; pre-release actions [CheckStrictVersion] decimal_only = 1 [Git::Check] allow_dirty = [Git::CheckFor::MergeConflicts] [Git::CheckFor::CorrectBranch] :version = 0.004 release_branch = master [Git::Remote::Check] branch = master remote_branch = master [TestRelease] [RunExtraTests] ;;; release actions [UploadToCPAN] ;;; post-release actions [ReadmeAnyFromPod / Markdown_Readme] source_filename = lib/URI.pm type = markdown filename = README.md location = root phase = release ; the distribution version is read from lib/URI.pm's $VERSION. ; at release, all matching versions are bumped. ; To change the release version, update *every* .pm file's ; $VERSION. You can do this easily with this oneliner (e.g. for 1.70 -> 2.00): ; perl -p -i -e's/.VERSION = .\K1.70/2.00/;' `find lib -type f` ; (and don't forget to add $VERSION = eval $VERSION; for underscore releases!) [@Git::VersionManager] :version = 0.003 bump_only_matching_versions = 1 commit_files_after_release = LICENSE commit_files_after_release = README.md release snapshot.commit_msg = %N-%v%t%n%n%c [Git::Push] [ConfirmRelease] URI-5.28/README0000644000175000017500000000056514600675475011437 0ustar olafolafThis archive contains the distribution URI, version 5.28: Uniform Resource Identifiers (absolute and relative) This software is copyright (c) 1998 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. This README file was generated by Dist::Zilla::Plugin::Readme v6.031. URI-5.28/CONTRIBUTING.md0000644000175000017500000001020414600675475012777 0ustar olafolaf# HOW TO CONTRIBUTE Thank you for considering contributing to this distribution. This file contains instructions that will help you work with the source code. The distribution is managed with [Dist::Zilla](https://metacpan.org/pod/Dist::Zilla). This means that many of the usual files you might expect are not in the repository, but are generated at release time. Some generated files are kept in the repository as a convenience (e.g. Build.PL/Makefile.PL and META.json). Generally, **you do not need Dist::Zilla to contribute patches**. You may need Dist::Zilla to create a tarball. See below for guidance. ## Getting dependencies If you have App::cpanminus 1.6 or later installed, you can use [cpanm](https://metacpan.org/pod/cpanm) to satisfy dependencies like this: $ cpanm --installdeps --with-develop . You can also run this command (or any other cpanm command) without installing App::cpanminus first, using the fatpacked `cpanm` script via curl or wget: $ curl -L https://cpanmin.us | perl - --installdeps --with-develop . $ wget -qO - https://cpanmin.us | perl - --installdeps --with-develop . Otherwise, look for either a `cpanfile` or `META.json` file for a list of dependencies to satisfy. ## Running tests You can run tests directly using the `prove` tool: $ prove -l $ prove -lv t/some_test_file.t For most of my distributions, `prove` is entirely sufficient for you to test any patches you have. I use `prove` for 99% of my testing during development. ## Code style and tidying Please try to match any existing coding style. If there is a `.perltidyrc` file, please install Perl::Tidy and use perltidy before submitting patches. ## Installing and using Dist::Zilla [Dist::Zilla](https://metacpan.org/pod/Dist::Zilla) is a very powerful authoring tool, optimized for maintaining a large number of distributions with a high degree of automation, but it has a large dependency chain, a bit of a learning curve and requires a number of author-specific plugins. To install it from CPAN, I recommend one of the following approaches for the quickest installation: # using CPAN.pm, but bypassing non-functional pod tests $ cpan TAP::Harness::Restricted $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla # using cpanm, bypassing *all* tests $ cpanm -n Dist::Zilla In either case, it's probably going to take about 10 minutes. Go for a walk, go get a cup of your favorite beverage, take a bathroom break, or whatever. When you get back, Dist::Zilla should be ready for you. Then you need to install any plugins specific to this distribution: $ dzil authordeps --missing | cpanm You can use Dist::Zilla to install the distribution's dependencies if you haven't already installed them with cpanm: $ dzil listdeps --missing --develop | cpanm Once everything is installed, here are some dzil commands you might try: $ dzil build $ dzil test $ dzil regenerate You can learn more about Dist::Zilla at http://dzil.org/ ## Other notes This distribution maintains the generated `META.json` and either `Makefile.PL` or `Build.PL` in the repository. This allows two things: [Travis CI](https://travis-ci.org/) can build and test the distribution without requiring Dist::Zilla, and the distribution can be installed directly from Github or a local git repository using `cpanm` for testing (again, not requiring Dist::Zilla). $ cpanm git://github.com/Author/Distribution-Name.git $ cd Distribution-Name; cpanm . Contributions are preferred in the form of a Github pull request. See [Using pull requests](https://help.github.com/articles/using-pull-requests/) for further information. You can use the Github issue tracker to report issues without an accompanying patch. # CREDITS This file was adapted from an initial `CONTRIBUTING.mkdn` file from David Golden under the terms of the Apache 2 license, with inspiration from the contributing documents from [Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING](https://metacpan.org/pod/Dist::Zilla::Plugin::Author::KENTNL::CONTRIBUTING) and [Dist::Zilla::PluginBundle::Author::ETHER](https://metacpan.org/pod/Dist::Zilla::PluginBundle::Author::ETHER). URI-5.28/uri-test0000755000175000017500000000222414600675475012253 0ustar olafolaf#!/usr/bin/perl -w use strict; use warnings; sub usage { my $prog = $0; $prog =~ s,.*/,,; die "Usage: $prog [ []...]\n"; } usage() unless @ARGV; my $uri = shift; my $orig = $uri; require URI; warn "Using: $INC{'URI.pm'}\n" if $INC{'URI.pm'} ne 'lib/URI.pm' and -t STDOUT and -t STDIN; my @ctor_arg = ($uri); push(@ctor_arg, shift) while @ARGV && $ARGV[0] =~ s/^\+//; $uri = URI->new(@ctor_arg); if (@ARGV) { my $method = shift; my $list_context = ($method =~ s/^\@//); #print "URI->new(\"$uri\")->$method ==> "; for (@ARGV) { undef($_) if $_ eq "UNDEF"; } my @result; if ($list_context) { @result = $uri->$method(@ARGV); } else { @result = scalar($uri->$method(@ARGV)); } for (@result) { if (defined) { $_ = "$_" if /^\s*$/; } else { $_ = ""; } } print join(" ", @result), "\n"; } print "$uri\n" unless $orig eq $uri; exit; # Some extra methods that might be nice sub UNIVERSAL::class { ref($_[0]) } sub UNIVERSAL::dump { require Data::Dumper; my $d = Data::Dumper->Dump(\@_, ["self", "arg1", "arg2", "arg3", "arg4"]); chomp($d); $d; } URI-5.28/perlimports.toml0000644000175000017500000000211214600675475014022 0ustar olafolaf# Valid log levels are: # debug, info, notice, warning, error, critical, alert, emergency # critical, alert and emergency are not currently used. # # Please use boolean values in this config file. Negated options (--no-*) are # not permitted here. Explicitly set options to true or false. # # Some of these values deviate from the regular perlimports defaults. In # particular, you're encouraged to leave preserve_duplicates and # preserve_unused disabled. cache = false # setting this to true is currently discouraged ignore_modules = ["Test::More"] ignore_modules_filename = "" ignore_modules_pattern = "" # regex like "^(Foo|Foo::Bar)" ignore_modules_pattern_filename = "" libs = ["lib", "t/lib"] log_filename = "" log_level = "warn" never_export_modules = [] never_export_modules_filename = "" padding = true preserve_duplicates = false preserve_unused = false tidy_whitespace = true URI-5.28/cpanfile0000644000175000017500000000321014600675475012251 0ustar olafolafon 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; suggests "JSON::PP" => "2.27300"; }; on 'develop' => sub { recommends 'Business::ISBN' => "3.005"; recommends "Storable" => "0"; requires "File::Spec" => "0"; requires "IO::Handle" => "0"; requires "IPC::Open3" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Test::CPAN::Meta" => "0"; requires "Test::DependentModules" => "0.27"; requires "Test::MinimumVersion" => "0"; requires "Test::Mojibake" => "0"; requires "Test::More" => "0.94"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; requires "Test::Portability::Files" => "0"; requires "Test::Spelling" => "0.12"; requires "Test::Version" => "1"; }; on 'runtime' => sub { requires "Carp" => "0"; requires "Cwd" => "0"; requires "Data::Dumper" => "0"; requires "Encode" => "0"; requires "Exporter" => "5.57"; requires "MIME::Base64" => "2"; requires "Net::Domain" => "0"; requires "Scalar::Util" => "0"; requires "constant" => "0"; requires "integer" => "0"; requires "overload" => "0"; requires "parent" => "0"; requires "perl" => "5.008001"; requires "strict" => "0"; requires "warnings" => "0"; requires "utf8" => '0'; suggests 'Regexp::IPv6' => "0.03"; suggests 'Business::ISBN' => "3.005"; }; on 'test' => sub { requires "File::Spec::Functions" => "0"; requires "File::Temp" => "0"; requires "Test::Fatal" => "0"; requires "Test::More" => "0.96"; requires "Test::Needs" => '0'; requires "Test::Warnings" => '0'; requires "utf8" => "0"; }; URI-5.28/META.json0000644000175000017500000006742714600675475012212 0ustar olafolaf{ "abstract" : "Uniform Resource Identifiers (absolute and relative)", "author" : [ "Gisle Aas " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.031, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "URI", "no_index" : { "directory" : [ "t", "xt" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "recommends" : { "Business::ISBN" : "3.005", "Dist::Zilla::PluginBundle::Git::VersionManager" : "0.007", "Storable" : "0" }, "requires" : { "File::Spec" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::DependentModules" : "0.27", "Test::MinimumVersion" : "0", "Test::Mojibake" : "0", "Test::More" : "0.94", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "requires" : { "Carp" : "0", "Cwd" : "0", "Data::Dumper" : "0", "Encode" : "0", "Exporter" : "5.57", "MIME::Base64" : "2", "Net::Domain" : "0", "Scalar::Util" : "0", "constant" : "0", "integer" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008001", "strict" : "0", "utf8" : "0", "warnings" : "0" }, "suggests" : { "Business::ISBN" : "3.005", "Regexp::IPv6" : "0.03" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "File::Spec::Functions" : "0", "File::Temp" : "0", "Test::Fatal" : "0", "Test::More" : "0.96", "Test::Needs" : "0", "Test::Warnings" : "0", "utf8" : "0" } } }, "provides" : { "URI" : { "file" : "lib/URI.pm", "version" : "5.28" }, "URI::Escape" : { "file" : "lib/URI/Escape.pm", "version" : "5.28" }, "URI::Heuristic" : { "file" : "lib/URI/Heuristic.pm", "version" : "5.28" }, "URI::IRI" : { "file" : "lib/URI/IRI.pm", "version" : "5.28" }, "URI::QueryParam" : { "file" : "lib/URI/QueryParam.pm", "version" : "5.28" }, "URI::Split" : { "file" : "lib/URI/Split.pm", "version" : "5.28" }, "URI::URL" : { "file" : "lib/URI/URL.pm", "version" : "5.28" }, "URI::WithBase" : { "file" : "lib/URI/WithBase.pm", "version" : "5.28" }, "URI::data" : { "file" : "lib/URI/data.pm", "version" : "5.28" }, "URI::file" : { "file" : "lib/URI/file.pm", "version" : "5.28" }, "URI::file::Base" : { "file" : "lib/URI/file/Base.pm", "version" : "5.28" }, "URI::file::FAT" : { "file" : "lib/URI/file/FAT.pm", "version" : "5.28" }, "URI::file::Mac" : { "file" : "lib/URI/file/Mac.pm", "version" : "5.28" }, "URI::file::OS2" : { "file" : "lib/URI/file/OS2.pm", "version" : "5.28" }, "URI::file::QNX" : { "file" : "lib/URI/file/QNX.pm", "version" : "5.28" }, "URI::file::Unix" : { "file" : "lib/URI/file/Unix.pm", "version" : "5.28" }, "URI::file::Win32" : { "file" : "lib/URI/file/Win32.pm", "version" : "5.28" }, "URI::ftp" : { "file" : "lib/URI/ftp.pm", "version" : "5.28" }, "URI::geo" : { "file" : "lib/URI/geo.pm", "version" : "5.28" }, "URI::gopher" : { "file" : "lib/URI/gopher.pm", "version" : "5.28" }, "URI::http" : { "file" : "lib/URI/http.pm", "version" : "5.28" }, "URI::https" : { "file" : "lib/URI/https.pm", "version" : "5.28" }, "URI::icap" : { "file" : "lib/URI/icap.pm", "version" : "5.28" }, "URI::icaps" : { "file" : "lib/URI/icaps.pm", "version" : "5.28" }, "URI::ldap" : { "file" : "lib/URI/ldap.pm", "version" : "5.28" }, "URI::ldapi" : { "file" : "lib/URI/ldapi.pm", "version" : "5.28" }, "URI::ldaps" : { "file" : "lib/URI/ldaps.pm", "version" : "5.28" }, "URI::mailto" : { "file" : "lib/URI/mailto.pm", "version" : "5.28" }, "URI::mms" : { "file" : "lib/URI/mms.pm", "version" : "5.28" }, "URI::news" : { "file" : "lib/URI/news.pm", "version" : "5.28" }, "URI::nntp" : { "file" : "lib/URI/nntp.pm", "version" : "5.28" }, "URI::nntps" : { "file" : "lib/URI/nntps.pm", "version" : "5.28" }, "URI::pop" : { "file" : "lib/URI/pop.pm", "version" : "5.28" }, "URI::rlogin" : { "file" : "lib/URI/rlogin.pm", "version" : "5.28" }, "URI::rsync" : { "file" : "lib/URI/rsync.pm", "version" : "5.28" }, "URI::rtsp" : { "file" : "lib/URI/rtsp.pm", "version" : "5.28" }, "URI::rtspu" : { "file" : "lib/URI/rtspu.pm", "version" : "5.28" }, "URI::sftp" : { "file" : "lib/URI/sftp.pm", "version" : "5.28" }, "URI::sip" : { "file" : "lib/URI/sip.pm", "version" : "5.28" }, "URI::sips" : { "file" : "lib/URI/sips.pm", "version" : "5.28" }, "URI::snews" : { "file" : "lib/URI/snews.pm", "version" : "5.28" }, "URI::ssh" : { "file" : "lib/URI/ssh.pm", "version" : "5.28" }, "URI::telnet" : { "file" : "lib/URI/telnet.pm", "version" : "5.28" }, "URI::tn3270" : { "file" : "lib/URI/tn3270.pm", "version" : "5.28" }, "URI::urn" : { "file" : "lib/URI/urn.pm", "version" : "5.28" }, "URI::urn::isbn" : { "file" : "lib/URI/urn/isbn.pm", "version" : "5.28" }, "URI::urn::oid" : { "file" : "lib/URI/urn/oid.pm", "version" : "5.28" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/libwww-perl/URI/issues" }, "homepage" : "https://github.com/libwww-perl/URI", "repository" : { "type" : "git", "url" : "https://github.com/libwww-perl/URI.git", "web" : "https://github.com/libwww-perl/URI" }, "x_IRC" : "irc://irc.perl.org/#lwp", "x_MailingList" : "mailto:libwww@perl.org" }, "version" : "5.28", "x_Dist_Zilla" : { "perl" : { "version" : "5.034000" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::Git::GatherDir", "config" : { "Dist::Zilla::Plugin::GatherDir" : { "exclude_filename" : [ "LICENSE", "README.md", "draft-duerst-iri-bis.txt", "rfc2396.txt", "rfc3986.txt", "rfc3987.txt" ], "exclude_match" : [], "include_dotfiles" : 0, "prefix" : "", "prune_directory" : [], "root" : "." }, "Dist::Zilla::Plugin::Git::GatherDir" : { "include_untracked" : 0 } }, "name" : "Git::GatherDir", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::Encoding", "name" : "Encoding", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "MetaConfig", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "config" : { "Dist::Zilla::Plugin::MetaProvides::Package" : { "finder_objects" : [ { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.031" } ], "include_underscores" : 0 }, "Dist::Zilla::Role::MetaProvider::Provider" : { "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004", "inherit_missing" : "0", "inherit_version" : "0", "meta_noindex" : 1 }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000037", "version" : "0.006" } }, "name" : "MetaProvides::Package", "version" : "2.004003" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "MetaNoIndex", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "MetaYAML", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "MetaJSON", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "MetaResources", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::Git::Contributors", "config" : { "Dist::Zilla::Plugin::Git::Contributors" : { "git_version" : "2.34.1", "include_authors" : 0, "include_releaser" : 1, "order_by" : "commits", "paths" : [] } }, "name" : "Git::Contributors", "version" : "0.036" }, { "class" : "Dist::Zilla::Plugin::GithubMeta", "name" : "GithubMeta", "version" : "0.58" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "Manifest", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "License", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "ExecDir", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::Prereqs::FromCPANfile", "name" : "Prereqs::FromCPANfile", "version" : "0.08" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "Readme", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::MakeMaker", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : "8" } }, "name" : "MakeMaker", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", "name" : "CheckChangesHasContent", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::MojibakeTests", "name" : "MojibakeTests", "version" : "0.8" }, { "class" : "Dist::Zilla::Plugin::Test::Version", "name" : "Test::Version", "version" : "1.09" }, { "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", "name" : "Test::ReportPrereqs", "version" : "0.029" }, { "class" : "Dist::Zilla::Plugin::Test::Compile", "config" : { "Dist::Zilla::Plugin::Test::Compile" : { "bail_out_on_fail" : "1", "fail_on_warning" : "author", "fake_home" : 0, "filename" : "xt/author/00-compile.t", "module_finder" : [ ":InstallModules" ], "needs_display" : 0, "phase" : "develop", "script_finder" : [ ":PerlExecFiles" ], "skips" : [], "switch" : [] } }, "name" : "Test::Compile", "version" : "2.058" }, { "class" : "Dist::Zilla::Plugin::Test::Portability", "config" : { "Dist::Zilla::Plugin::Test::Portability" : { "options" : "" } }, "name" : "Test::Portability", "version" : "2.001001" }, { "class" : "Dist::Zilla::Plugin::MetaTests", "name" : "MetaTests", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::Test::MinimumVersion", "config" : { "Dist::Zilla::Plugin::Test::MinimumVersion" : { "max_target_perl" : null } }, "name" : "Test::MinimumVersion", "version" : "2.000010" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "PodSyntaxTests", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable", "name" : "Test::Pod::Coverage::Configurable", "version" : "0.07" }, { "class" : "Dist::Zilla::Plugin::Test::PodSpelling", "config" : { "Dist::Zilla::Plugin::Test::PodSpelling" : { "directories" : [ "bin", "lib" ], "spell_cmd" : "aspell list", "stopwords" : [ "Berners", "CRS", "IDNA", "ISBNs", "Koster", "Martijn", "Masinter", "Miyagawa", "OIDs", "OpenLDAP", "Punycode", "TCP", "TLS", "Tatsuhiko", "UDP", "UNC", "etype", "evalue", "lon", "lowercasing", "relativize", "unicode", "uppercasing", "xn" ], "wordlist" : "Pod::Wordlist" } }, "name" : "Test::PodSpelling", "version" : "2.007005" }, { "class" : "Dist::Zilla::Plugin::CheckStrictVersion", "name" : "CheckStrictVersion", "version" : "0.001" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "config" : { "Dist::Zilla::Plugin::Git::Check" : { "untracked_files" : "die" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." } }, "name" : "Git::Check", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts", "config" : { "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." } }, "name" : "Git::CheckFor::MergeConflicts", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch", "config" : { "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." } }, "name" : "Git::CheckFor::CorrectBranch", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::Git::Remote::Check", "name" : "Git::Remote::Check", "version" : "0.1.2" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "TestRelease", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : "8" } }, "name" : "RunExtraTests", "version" : "0.029" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "UploadToCPAN", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", "config" : { "Dist::Zilla::Role::FileWatcher" : { "version" : "0.006" } }, "name" : "Markdown_Readme", "version" : "0.163250" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "recommends" } }, "name" : "@Git::VersionManager/pluginbundle version", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::VersionFromMainModule", "config" : { "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000037", "version" : "0.006" } }, "name" : "@Git::VersionManager/VersionFromMainModule", "version" : "0.04" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Update", "name" : "@Git::VersionManager/MetaProvides::Update", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", "config" : { "Dist::Zilla::Plugin::CopyFilesFromRelease" : { "filename" : [ "Changes" ], "match" : [] } }, "name" : "@Git::VersionManager/CopyFilesFromRelease", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "%N-%v%t%n%n%c", "signoff" : 0 }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Changes", "LICENSE", "README.md" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Git::VersionManager/release snapshot", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "config" : { "Dist::Zilla::Plugin::Git::Tag" : { "branch" : null, "changelog" : "Changes", "signed" : 0, "tag" : "v5.28", "tag_format" : "v%V", "tag_message" : "v%V" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Git::VersionManager/Git::Tag", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease", "config" : { "Dist::Zilla::Plugin::BumpVersionAfterRelease" : { "finders" : [ ":ExecFiles", ":InstallModules" ], "global" : 0, "munge_makefile_pl" : 1 } }, "name" : "@Git::VersionManager/BumpVersionAfterRelease", "version" : "0.018" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "@Git::VersionManager/NextRelease", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "increment $VERSION after %v release", "signoff" : 0 }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Build.PL", "Changes", "Makefile.PL" ], "allow_dirty_match" : [ "(?^:^lib/.*\\.pm$)" ], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Git::VersionManager/post-release commit", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "config" : { "Dist::Zilla::Plugin::Git::Push" : { "push_to" : [ "origin" ], "remotes_must_exist" : 1 }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.34.1", "repo_root" : "." } }, "name" : "Git::Push", "version" : "2.049" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "ConfirmRelease", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.031" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.031" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.031" } }, "x_contributors" : [ "Gisle Aas ", "Karen Etheridge ", "Olaf Alders ", "Chase Whitener ", "Julien Fiegehenn ", "Ville Skytt\u00e4 ", "Mark Stosberg ", "David Dick ", "Graham Knop ", "Michael G. Schwern ", "Shoichi Kaji ", "Branislav Zahradn\u00edk ", "dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>", "Perlbotics ", "Jacques Deguest ", "James Raspass ", "Matthew Chae ", "Slaven Rezic ", "Adam Herzog ", "Alex Kapranoff ", "Brendan Byrd ", "brian d foy ", "David Schmidt ", "Dorian Taylor ", "gerard ", "Gianni Ceccarelli ", "gregor herrmann ", "H\u00e5kon H\u00e6gland ", "Jan Dubois ", "Joenio Costa ", "John Karr ", "John Miller ", "Kaitlyn Parkhurst ", "Kenichi Ishigaki ", "Kent Fredric ", "Masahiro Honma ", "Matt Lawrence ", "Peter Rabbitson ", "Piotr Roszatycki ", "Ryan Kereliuk ", "Salvatore Bonaccorso ", "Sebastian Willing ", "Tatsuhiko Miyagawa ", "Torsten F\u00f6rtsch " ], "x_generated_by_perl" : "v5.34.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.37", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } URI-5.28/xt/0000775000175000017500000000000014600675475011206 5ustar olafolafURI-5.28/xt/author/0000775000175000017500000000000014600675475012510 5ustar olafolafURI-5.28/xt/author/portability.t0000644000175000017500000000013014600675475015227 0ustar olafolafuse strict; use warnings; use Test::More; use Test::Portability::Files; run_tests(); URI-5.28/xt/author/minimum-version.t0000644000175000017500000000015414600675475016031 0ustar olafolafuse strict; use warnings; use Test::More; use Test::MinimumVersion; all_minimum_version_from_metayml_ok(); URI-5.28/xt/author/distmeta.t0000644000175000017500000000022314600675475014502 0ustar olafolaf#!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use strict; use warnings; use Test::CPAN::Meta; meta_yaml_ok(); URI-5.28/xt/author/00-compile.t0000644000175000017500000000474614600675475014553 0ustar olafolafuse 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 use Test::More 0.94; plan tests => 58; my @module_files = ( 'URI.pm', 'URI/Escape.pm', 'URI/Heuristic.pm', 'URI/IRI.pm', 'URI/QueryParam.pm', 'URI/Split.pm', 'URI/URL.pm', 'URI/WithBase.pm', 'URI/_foreign.pm', 'URI/_generic.pm', 'URI/_idna.pm', 'URI/_ldap.pm', 'URI/_login.pm', 'URI/_punycode.pm', 'URI/_query.pm', 'URI/_segment.pm', 'URI/_server.pm', 'URI/_userpass.pm', 'URI/data.pm', 'URI/file.pm', 'URI/file/Base.pm', 'URI/file/FAT.pm', 'URI/file/Mac.pm', 'URI/file/OS2.pm', 'URI/file/QNX.pm', 'URI/file/Unix.pm', 'URI/file/Win32.pm', 'URI/ftp.pm', 'URI/geo.pm', 'URI/gopher.pm', 'URI/http.pm', 'URI/https.pm', 'URI/icap.pm', 'URI/icaps.pm', 'URI/ldap.pm', 'URI/ldapi.pm', 'URI/ldaps.pm', 'URI/mailto.pm', 'URI/mms.pm', 'URI/news.pm', 'URI/nntp.pm', 'URI/nntps.pm', 'URI/pop.pm', 'URI/rlogin.pm', 'URI/rsync.pm', 'URI/rtsp.pm', 'URI/rtspu.pm', 'URI/sftp.pm', 'URI/sip.pm', 'URI/sips.pm', 'URI/snews.pm', 'URI/ssh.pm', 'URI/telnet.pm', 'URI/tn3270.pm', 'URI/urn.pm', 'URI/urn/isbn.pm', 'URI/urn/oid.pm' ); # no fake home requested my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { +require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', explain(\@warnings); BAIL_OUT("Compilation problems") if !Test::More->builder->is_passing; URI-5.28/xt/author/pod-coverage.t0000644000175000017500000001022514600675475015246 0ustar olafolaf#!perl # This file was automatically generated by Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable 0.07. use Test::Pod::Coverage 1.08; use Test::More 0.88; BEGIN { if ( $] <= 5.008008 ) { plan skip_all => 'These tests require Pod::Coverage::TrustPod, which only works with Perl 5.8.9+'; } } use Pod::Coverage::TrustPod; my %skip = map { $_ => 1 } qw( URI::IRI URI::_foreign URI::_idna URI::_login URI::_ldap URI::file::QNX URI::nntp URI::urn::isbn URI::urn::oid URI::sftp ); my @modules; for my $module ( all_modules() ) { next if $skip{$module}; push @modules, $module; } plan skip_all => 'All the modules we found were excluded from POD coverage test.' unless @modules; plan tests => scalar @modules; my %trustme = ( 'URI' => [ qr/^(?:STORABLE_freeze|STORABLE_thaw|TO_JSON|implementor)$/ ], 'URI::Escape' => [ qr/^(?:escape_char)$/ ], 'URI::Heuristic' => [ qr/^(?:MY_COUNTRY|uf_url|uf_urlstr)$/ ], 'URI::URL' => [ qr/^(?:address|article|crack|dos_path|encoded822addr|eparams|epath|frag)$/, qr/^(?:full_path|groupart|keywords|local_path|mac_path|netloc|newlocal|params|path|path_components|print_on|query|strict|unix_path|url|vms_path)$/ ], 'URI::WithBase' => [ qr/^(?:can|clone|eq|new_abs)$/ ], 'URI::_query' => [ qr/^(?:equery|query|query_form|query_form_hash|query_keywords|query_param|query_param_append|query_param_delete)$/ ], 'URI::_segment' => [ qr/^(?:new)$/ ], 'URI::_userpass' => [ qr/^(?:password|user)$/ ], 'URI::file' => [ qr/^(?:os_class)$/ ], 'URI::file::Base' => [ qr/^(?:dir|file|new)$/ ], 'URI::file::FAT' => [ qr/^(?:fix_path)$/ ], 'URI::file::Mac' => [ qr/^(?:dir|file)$/ ], 'URI::file::OS2' => [ qr/^(?:file)$/ ], 'URI::file::Unix' => [ qr/^(?:file)$/ ], 'URI::file::Win32' => [ qr/^(?:file|fix_path)$/ ], 'URI::ftp' => [ qr/^(?:password|user)$/ ], 'URI::gopher' => [ qr/^(?:gopher_type|gtype|search|selector|string)$/ ], 'URI::ldapi' => [ qr/^(?:un_path)$/ ], 'URI::mailto' => [ qr/^(?:headers|to)$/ ], 'URI::news' => [ qr/^(?:group|message)$/ ], 'URI::pop' => [ qr/^(?:auth|user)$/ ], 'URI::sip' => [ qr/^(?:params|params_form)$/ ], 'URI::urn' => [ qr/^(?:nid|nss)$/ ] ); my @also_private; for my $module ( sort @modules ) { pod_coverage_ok( $module, { coverage_class => 'Pod::Coverage::TrustPod', also_private => \@also_private, trustme => $trustme{$module} || [], }, "pod coverage for $module" ); } done_testing(); URI-5.28/xt/author/pod-spell.t0000644000175000017500000000321714600675475014575 0ustar olafolafuse strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005 use Test::Spelling 0.12; use Pod::Wordlist; set_spell_cmd('aspell list'); add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ 49699333 Aas Adam Alders Alex Base Berners Bonaccorso Branislav Brendan Byrd CRS Ceccarelli Chae Chase Costa David Deguest Dick Dorian Dubois Escape Etheridge FAT Fiegehenn Fredric Förtsch Gianni Gisle Graham Herzog Heuristic Honma Håkon Hægland IDNA IRI ISBNs Ishigaki Jacques James Jan Joenio John Julien Kaitlyn Kaji Kapranoff Karen Karr Kenichi Kent Kereliuk Knop Koster Lawrence Mac Mark Martijn Masahiro Masinter Matt Matthew Michael Miller Miyagawa OIDs OS2 Olaf OpenLDAP Parkhurst Perl Perlbotics Peter Piotr Punycode QNX QueryParam Rabbitson Raspass Rezic Roszatycki Ryan Salvatore Schmidt Schwern Sebastian Shoichi Skyttä Slaven Split Stosberg TCP TLS Tatsuhiko Taylor Torsten UDP UNC URI URL Unix Ville Whitener Willing Win32 WithBase Zahradník _foreign _generic _idna _ldap _login _punycode _query _segment _server _userpass adam brainbuz brian capoeirab carnil data davewood ddick dependabot dorian ether etype evalue file foy ftp geo gerard gianni gisle gopher gregoa gregor haarg hakon happy herrmann hiratara http https icap icaps isbn ishigaki jack jand joenio john jraspass kapranoff kentfredric ldap ldapi ldaps lib lon lowercasing mailto mark matthewlawrence miyagawa mms mschae news nntp nntps oid olaf perlbotix piotr pop relativize ribasushi rlogin rsync rtsp rtspu ryker schwern sewi sftp simbabque sip sips skaji slaven snews ssh symkat telnet tn3270 torsten unicode uppercasing urn ville xn URI-5.28/xt/author/pod-syntax.t0000644000175000017500000000025214600675475015000 0ustar olafolaf#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); URI-5.28/xt/author/mojibake.t0000644000175000017500000000015114600675475014451 0ustar olafolaf#!perl use strict; use warnings qw(all); use Test::More; use Test::Mojibake; all_files_encoding_ok(); URI-5.28/xt/author/test-version.t0000644000175000017500000000063714600675475015343 0ustar olafolafuse strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; URI-5.28/xt/dependent-modules.t0000644000175000017500000000050214600675475015002 0ustar olafolafuse strict; use warnings; use Test::Needs qw( Test::DependentModules ); use Test::DependentModules qw( test_modules ); use Test::More; my @modules = ('HTTP::Message'); SKIP: { skip '$ENV{TEST_DEPENDENTS} not set', scalar @modules unless $ENV{TEST_DEPENDENTS}; test_modules(@modules); } done_testing(); URI-5.28/META.yml0000644000175000017500000004331114600675475012024 0ustar olafolaf--- abstract: 'Uniform Resource Identifiers (absolute and relative)' author: - 'Gisle Aas ' build_requires: ExtUtils::MakeMaker: '0' File::Spec: '0' File::Spec::Functions: '0' File::Temp: '0' Test::Fatal: '0' Test::More: '0.96' Test::Needs: '0' Test::Warnings: '0' utf8: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.031, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: URI no_index: directory: - t - xt provides: URI: file: lib/URI.pm version: '5.28' URI::Escape: file: lib/URI/Escape.pm version: '5.28' URI::Heuristic: file: lib/URI/Heuristic.pm version: '5.28' URI::IRI: file: lib/URI/IRI.pm version: '5.28' URI::QueryParam: file: lib/URI/QueryParam.pm version: '5.28' URI::Split: file: lib/URI/Split.pm version: '5.28' URI::URL: file: lib/URI/URL.pm version: '5.28' URI::WithBase: file: lib/URI/WithBase.pm version: '5.28' URI::data: file: lib/URI/data.pm version: '5.28' URI::file: file: lib/URI/file.pm version: '5.28' URI::file::Base: file: lib/URI/file/Base.pm version: '5.28' URI::file::FAT: file: lib/URI/file/FAT.pm version: '5.28' URI::file::Mac: file: lib/URI/file/Mac.pm version: '5.28' URI::file::OS2: file: lib/URI/file/OS2.pm version: '5.28' URI::file::QNX: file: lib/URI/file/QNX.pm version: '5.28' URI::file::Unix: file: lib/URI/file/Unix.pm version: '5.28' URI::file::Win32: file: lib/URI/file/Win32.pm version: '5.28' URI::ftp: file: lib/URI/ftp.pm version: '5.28' URI::geo: file: lib/URI/geo.pm version: '5.28' URI::gopher: file: lib/URI/gopher.pm version: '5.28' URI::http: file: lib/URI/http.pm version: '5.28' URI::https: file: lib/URI/https.pm version: '5.28' URI::icap: file: lib/URI/icap.pm version: '5.28' URI::icaps: file: lib/URI/icaps.pm version: '5.28' URI::ldap: file: lib/URI/ldap.pm version: '5.28' URI::ldapi: file: lib/URI/ldapi.pm version: '5.28' URI::ldaps: file: lib/URI/ldaps.pm version: '5.28' URI::mailto: file: lib/URI/mailto.pm version: '5.28' URI::mms: file: lib/URI/mms.pm version: '5.28' URI::news: file: lib/URI/news.pm version: '5.28' URI::nntp: file: lib/URI/nntp.pm version: '5.28' URI::nntps: file: lib/URI/nntps.pm version: '5.28' URI::pop: file: lib/URI/pop.pm version: '5.28' URI::rlogin: file: lib/URI/rlogin.pm version: '5.28' URI::rsync: file: lib/URI/rsync.pm version: '5.28' URI::rtsp: file: lib/URI/rtsp.pm version: '5.28' URI::rtspu: file: lib/URI/rtspu.pm version: '5.28' URI::sftp: file: lib/URI/sftp.pm version: '5.28' URI::sip: file: lib/URI/sip.pm version: '5.28' URI::sips: file: lib/URI/sips.pm version: '5.28' URI::snews: file: lib/URI/snews.pm version: '5.28' URI::ssh: file: lib/URI/ssh.pm version: '5.28' URI::telnet: file: lib/URI/telnet.pm version: '5.28' URI::tn3270: file: lib/URI/tn3270.pm version: '5.28' URI::urn: file: lib/URI/urn.pm version: '5.28' URI::urn::isbn: file: lib/URI/urn/isbn.pm version: '5.28' URI::urn::oid: file: lib/URI/urn/oid.pm version: '5.28' requires: Carp: '0' Cwd: '0' Data::Dumper: '0' Encode: '0' Exporter: '5.57' MIME::Base64: '2' Net::Domain: '0' Scalar::Util: '0' constant: '0' integer: '0' overload: '0' parent: '0' perl: '5.008001' strict: '0' utf8: '0' warnings: '0' resources: IRC: irc://irc.perl.org/#lwp MailingList: mailto:libwww@perl.org bugtracker: https://github.com/libwww-perl/URI/issues homepage: https://github.com/libwww-perl/URI repository: https://github.com/libwww-perl/URI.git version: '5.28' x_Dist_Zilla: perl: version: '5.034000' plugins: - class: Dist::Zilla::Plugin::Git::GatherDir config: Dist::Zilla::Plugin::GatherDir: exclude_filename: - LICENSE - README.md - draft-duerst-iri-bis.txt - rfc2396.txt - rfc3986.txt - rfc3987.txt exclude_match: [] include_dotfiles: 0 prefix: '' prune_directory: [] root: . Dist::Zilla::Plugin::Git::GatherDir: include_untracked: 0 name: Git::GatherDir version: '2.049' - class: Dist::Zilla::Plugin::Encoding name: Encoding version: '6.031' - class: Dist::Zilla::Plugin::MetaConfig name: MetaConfig version: '6.031' - class: Dist::Zilla::Plugin::MetaProvides::Package config: Dist::Zilla::Plugin::MetaProvides::Package: finder_objects: - class: Dist::Zilla::Plugin::FinderCode name: MetaProvides::Package/AUTOVIV/:InstallModulesPM version: '6.031' include_underscores: 0 Dist::Zilla::Role::MetaProvider::Provider: $Dist::Zilla::Role::MetaProvider::Provider::VERSION: '2.002004' inherit_missing: '0' inherit_version: '0' meta_noindex: '1' Dist::Zilla::Role::ModuleMetadata: Module::Metadata: '1.000037' version: '0.006' name: MetaProvides::Package version: '2.004003' - class: Dist::Zilla::Plugin::MetaNoIndex name: MetaNoIndex version: '6.031' - class: Dist::Zilla::Plugin::MetaYAML name: MetaYAML version: '6.031' - class: Dist::Zilla::Plugin::MetaJSON name: MetaJSON version: '6.031' - class: Dist::Zilla::Plugin::MetaResources name: MetaResources version: '6.031' - class: Dist::Zilla::Plugin::Git::Contributors config: Dist::Zilla::Plugin::Git::Contributors: git_version: 2.34.1 include_authors: 0 include_releaser: 1 order_by: commits paths: [] name: Git::Contributors version: '0.036' - class: Dist::Zilla::Plugin::GithubMeta name: GithubMeta version: '0.58' - class: Dist::Zilla::Plugin::Manifest name: Manifest version: '6.031' - class: Dist::Zilla::Plugin::License name: License version: '6.031' - class: Dist::Zilla::Plugin::ExecDir name: ExecDir version: '6.031' - class: Dist::Zilla::Plugin::Prereqs::FromCPANfile name: Prereqs::FromCPANfile version: '0.08' - class: Dist::Zilla::Plugin::Readme name: Readme version: '6.031' - class: Dist::Zilla::Plugin::MakeMaker config: Dist::Zilla::Role::TestRunner: default_jobs: '8' name: MakeMaker version: '6.031' - class: Dist::Zilla::Plugin::CheckChangesHasContent name: CheckChangesHasContent version: '0.011' - class: Dist::Zilla::Plugin::MojibakeTests name: MojibakeTests version: '0.8' - class: Dist::Zilla::Plugin::Test::Version name: Test::Version version: '1.09' - class: Dist::Zilla::Plugin::Test::ReportPrereqs name: Test::ReportPrereqs version: '0.029' - class: Dist::Zilla::Plugin::Test::Compile config: Dist::Zilla::Plugin::Test::Compile: bail_out_on_fail: '1' fail_on_warning: author fake_home: 0 filename: xt/author/00-compile.t module_finder: - ':InstallModules' needs_display: 0 phase: develop script_finder: - ':PerlExecFiles' skips: [] switch: [] name: Test::Compile version: '2.058' - class: Dist::Zilla::Plugin::Test::Portability config: Dist::Zilla::Plugin::Test::Portability: options: '' name: Test::Portability version: '2.001001' - class: Dist::Zilla::Plugin::MetaTests name: MetaTests version: '6.031' - class: Dist::Zilla::Plugin::Test::MinimumVersion config: Dist::Zilla::Plugin::Test::MinimumVersion: max_target_perl: ~ name: Test::MinimumVersion version: '2.000010' - class: Dist::Zilla::Plugin::PodSyntaxTests name: PodSyntaxTests version: '6.031' - class: Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable name: Test::Pod::Coverage::Configurable version: '0.07' - class: Dist::Zilla::Plugin::Test::PodSpelling config: Dist::Zilla::Plugin::Test::PodSpelling: directories: - bin - lib spell_cmd: 'aspell list' stopwords: - Berners - CRS - IDNA - ISBNs - Koster - Martijn - Masinter - Miyagawa - OIDs - OpenLDAP - Punycode - TCP - TLS - Tatsuhiko - UDP - UNC - etype - evalue - lon - lowercasing - relativize - unicode - uppercasing - xn wordlist: Pod::Wordlist name: Test::PodSpelling version: '2.007005' - class: Dist::Zilla::Plugin::CheckStrictVersion name: CheckStrictVersion version: '0.001' - class: Dist::Zilla::Plugin::Git::Check config: Dist::Zilla::Plugin::Git::Check: untracked_files: die Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: [] allow_dirty_match: [] changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . name: Git::Check version: '2.049' - class: Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts config: Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . name: Git::CheckFor::MergeConflicts version: '0.014' - class: Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch config: Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . name: Git::CheckFor::CorrectBranch version: '0.014' - class: Dist::Zilla::Plugin::Git::Remote::Check name: Git::Remote::Check version: 0.1.2 - class: Dist::Zilla::Plugin::TestRelease name: TestRelease version: '6.031' - class: Dist::Zilla::Plugin::RunExtraTests config: Dist::Zilla::Role::TestRunner: default_jobs: '8' name: RunExtraTests version: '0.029' - class: Dist::Zilla::Plugin::UploadToCPAN name: UploadToCPAN version: '6.031' - class: Dist::Zilla::Plugin::ReadmeAnyFromPod config: Dist::Zilla::Role::FileWatcher: version: '0.006' name: Markdown_Readme version: '0.163250' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: recommends name: '@Git::VersionManager/pluginbundle version' version: '6.031' - class: Dist::Zilla::Plugin::VersionFromMainModule config: Dist::Zilla::Role::ModuleMetadata: Module::Metadata: '1.000037' version: '0.006' name: '@Git::VersionManager/VersionFromMainModule' version: '0.04' - class: Dist::Zilla::Plugin::MetaProvides::Update name: '@Git::VersionManager/MetaProvides::Update' version: '0.007' - class: Dist::Zilla::Plugin::CopyFilesFromRelease config: Dist::Zilla::Plugin::CopyFilesFromRelease: filename: - Changes match: [] name: '@Git::VersionManager/CopyFilesFromRelease' version: '0.007' - class: Dist::Zilla::Plugin::Git::Commit config: Dist::Zilla::Plugin::Git::Commit: add_files_in: [] commit_msg: '%N-%v%t%n%n%c' signoff: '0' Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: - Changes - LICENSE - README.md allow_dirty_match: [] changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@Git::VersionManager/release snapshot' version: '2.049' - class: Dist::Zilla::Plugin::Git::Tag config: Dist::Zilla::Plugin::Git::Tag: branch: ~ changelog: Changes signed: 0 tag: v5.28 tag_format: v%V tag_message: v%V Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@Git::VersionManager/Git::Tag' version: '2.049' - class: Dist::Zilla::Plugin::BumpVersionAfterRelease config: Dist::Zilla::Plugin::BumpVersionAfterRelease: finders: - ':ExecFiles' - ':InstallModules' global: 0 munge_makefile_pl: 1 name: '@Git::VersionManager/BumpVersionAfterRelease' version: '0.018' - class: Dist::Zilla::Plugin::NextRelease name: '@Git::VersionManager/NextRelease' version: '6.031' - class: Dist::Zilla::Plugin::Git::Commit config: Dist::Zilla::Plugin::Git::Commit: add_files_in: [] commit_msg: 'increment $VERSION after %v release' signoff: '0' Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: - Build.PL - Changes - Makefile.PL allow_dirty_match: - (?^:^lib/.*\.pm$) changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@Git::VersionManager/post-release commit' version: '2.049' - class: Dist::Zilla::Plugin::Git::Push config: Dist::Zilla::Plugin::Git::Push: push_to: - origin remotes_must_exist: 1 Dist::Zilla::Role::Git::Repo: git_version: 2.34.1 repo_root: . name: Git::Push version: '2.049' - class: Dist::Zilla::Plugin::ConfirmRelease name: ConfirmRelease version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':ExtraTestFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':PerlExecFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':AllFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: ':NoFiles' version: '6.031' - class: Dist::Zilla::Plugin::FinderCode name: MetaProvides::Package/AUTOVIV/:InstallModulesPM version: '6.031' zilla: class: Dist::Zilla::Dist::Builder config: is_trial: '0' version: '6.031' x_contributors: - 'Gisle Aas ' - 'Karen Etheridge ' - 'Olaf Alders ' - 'Chase Whitener ' - 'Julien Fiegehenn ' - 'Ville Skyttä ' - 'Mark Stosberg ' - 'David Dick ' - 'Graham Knop ' - 'Michael G. Schwern ' - 'Shoichi Kaji ' - 'Branislav Zahradník ' - 'dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>' - 'Perlbotics ' - 'Jacques Deguest ' - 'James Raspass ' - 'Matthew Chae ' - 'Slaven Rezic ' - 'Adam Herzog ' - 'Alex Kapranoff ' - 'Brendan Byrd ' - 'brian d foy ' - 'David Schmidt ' - 'Dorian Taylor ' - 'gerard ' - 'Gianni Ceccarelli ' - 'gregor herrmann ' - 'Håkon Hægland ' - 'Jan Dubois ' - 'Joenio Costa ' - 'John Karr ' - 'John Miller ' - 'Kaitlyn Parkhurst ' - 'Kenichi Ishigaki ' - 'Kent Fredric ' - 'Masahiro Honma ' - 'Matt Lawrence ' - 'Peter Rabbitson ' - 'Piotr Roszatycki ' - 'Ryan Kereliuk ' - 'Salvatore Bonaccorso ' - 'Sebastian Willing ' - 'Tatsuhiko Miyagawa ' - 'Torsten Förtsch ' x_generated_by_perl: v5.34.0 x_serialization_backend: 'YAML::Tiny version 1.74' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' URI-5.28/lib/0000775000175000017500000000000014600675475011321 5ustar olafolafURI-5.28/lib/URI.pm0000644000175000017500000012124014600675475012314 0ustar olafolafpackage URI; use strict; use warnings; our $VERSION = '5.28'; # 1=version 5.10 and earlier; 0=version 5.11 and later use constant HAS_RESERVED_SQUARE_BRACKETS => $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} ? 1 : 0; our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER); my %implements; # mapping from scheme to implementor class # Some "official" character classes our $reserved = HAS_RESERVED_SQUARE_BRACKETS ? q(;/?:@&=+$,[]) : q(;/?:@&=+$,); our $mark = q(-_.!~*'()); #'; emacs our $unreserved = "A-Za-z0-9\Q$mark\E"; our $uric = quotemeta($reserved) . $unreserved . "%"; our $uric4host = $uric . ( HAS_RESERVED_SQUARE_BRACKETS ? '' : quotemeta( q([]) ) ); our $uric4user = quotemeta( q{!$'()*,;:._~%-+=%&} ) . "A-Za-z0-9" . ( HAS_RESERVED_SQUARE_BRACKETS ? quotemeta( q([]) ) : '' ); # RFC-3987: iuserinfo w/o UTF our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*'; # These schemes don't have an IPv6+ address part. our $schemes_without_host_part_re = 'data|ldapi|urn|sqlite|sqlite3'; # These schemes can have an IPv6+ authority part: # file, ftp, gopher, http, https, ldap, ldaps, mms, news, nntp, nntps, pop, rlogin, rtsp, rtspu, rsync, sip, sips, snews, # telnet, tn3270, ssh, sftp # (all DB URIs, i.e. cassandra, couch, couchdb, etc.), except 'sqlite:', 'sqlite3:'. Others? #MAINT: URI has no test coverage for DB schemes #MAINT: decoupling - perhaps let each class decide itself by defining a member function 'scheme_has_authority_part()'? #MAINT: 'mailto:' needs special treatment for IPv* addresses / RFC 5321 (4.1.3). Until then: restore all '[', ']' # These schemes need fallback to previous (<= 5.10) encoding until a specific handler is available. our $fallback_schemes_re = 'mailto'; use Carp (); use URI::Escape (); use overload ('""' => sub { ${$_[0]} }, '==' => sub { _obj_eq(@_) }, '!=' => sub { !_obj_eq(@_) }, fallback => 1, ); # Check if two objects are the same object sub _obj_eq { return overload::StrVal($_[0]) eq overload::StrVal($_[1]); } sub new { my($class, $uri, $scheme) = @_; $uri = defined ($uri) ? "$uri" : ""; # stringify # Get rid of potential wrapping $uri =~ s/^<(?:URL:)?(.*)>$/$1/; # $uri =~ s/^"(.*)"$/$1/; $uri =~ s/^\s+//; $uri =~ s/\s+$//; my $impclass; if ($uri =~ m/^($scheme_re):/so) { $scheme = $1; } else { if (($impclass = ref($scheme))) { $scheme = $scheme->scheme; } elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) { $scheme = $1; } } $impclass ||= implementor($scheme) || do { require URI::_foreign; $impclass = 'URI::_foreign'; }; return $impclass->_init($uri, $scheme); } sub new_abs { my($class, $uri, $base) = @_; $uri = $class->new($uri, $base); $uri->abs($base); } sub _init { my $class = shift; my($str, $scheme) = @_; # find all funny characters and encode the bytes. $str = $class->_uric_escape($str); $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o || $class->_no_scheme_ok; my $self = bless \$str, $class; $self; } #-- Version: 5.11+ # Since the complete URI will be percent-encoded including '[' and ']', # we selectively unescape square brackets from the authority/host part of the URI. # Derived modules that implement _uric_escape() should take this into account # if they do not rely on URI::_uric_escape(). # No unescaping is performed for the userinfo@ part of the authority part. sub _fix_uric_escape_for_host_part { return if HAS_RESERVED_SQUARE_BRACKETS; return if $_[0] !~ /%/; return if $_[0] =~ m{^(?:$URI::schemes_without_host_part_re):}os; # until a scheme specific handler is available, fall back to previous behavior of v5.10 (i.e. 'mailto:') if ($_[0] =~ m{^(?:$URI::fallback_schemes_re):}os) { $_[0] =~ s/\%5B/[/gi; $_[0] =~ s/\%5D/]/gi; return; } if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//([^/?\#]+)(.*)$}os) { my $orig = $2; my ($user, $host) = $orig =~ /^(.*@)?([^@]*)$/; $user ||= ''; my $port = $host =~ s/(:\d+)$// ? $1 : ''; #MAINT: die() here if scheme indicates TCP/UDP and port is out of range [0..65535] ? $host =~ s/\%5B/[/gi; $host =~ s/\%5D/]/gi; $_[0] =~ s/\Q$orig\E/$user$host$port/; } } sub _uric_escape { my($class, $str) = @_; $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego; _fix_uric_escape_for_host_part( $str ); utf8::downgrade($str); return $str; } my %require_attempted; sub implementor { my($scheme, $impclass) = @_; if (!$scheme || $scheme !~ /\A$scheme_re\z/o) { require URI::_generic; return "URI::_generic"; } $scheme = lc($scheme); if ($impclass) { # Set the implementor class for a given scheme my $old = $implements{$scheme}; $impclass->_init_implementor($scheme); $implements{$scheme} = $impclass; return $old; } my $ic = $implements{$scheme}; return $ic if $ic; # scheme not yet known, look for internal or # preloaded (with 'use') implementation $ic = "URI::$scheme"; # default location # turn scheme into a valid perl identifier by a simple transformation... $ic =~ s/\+/_P/g; $ic =~ s/\./_O/g; $ic =~ s/\-/_/g; no strict 'refs'; # check we actually have one for the scheme: unless (@{"${ic}::ISA"}) { if (not exists $require_attempted{$ic}) { $require_attempted{$ic} = 1; # Try to load it my $_old_error = $@; eval "require $ic"; die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; $@ = $_old_error; } return undef unless @{"${ic}::ISA"}; } $ic->_init_implementor($scheme); $implements{$scheme} = $ic; $ic; } sub _init_implementor { my($class, $scheme) = @_; # Remember that one implementor class may actually # serve to implement several URI schemes. } sub clone { my $self = shift; my $other = $$self; bless \$other, ref $self; } sub TO_JSON { ${$_[0]} } sub _no_scheme_ok { 0 } sub _scheme { my $self = shift; unless (@_) { return undef unless $$self =~ /^($scheme_re):/o; return $1; } my $old; my $new = shift; if (defined($new) && length($new)) { Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o; $old = $1 if $$self =~ s/^($scheme_re)://o; my $newself = URI->new("$new:$$self"); $$self = $$newself; bless $self, ref($newself); } else { if ($self->_no_scheme_ok) { $old = $1 if $$self =~ s/^($scheme_re)://o; Carp::carp("Oops, opaque part now look like scheme") if $^W && $$self =~ m/^$scheme_re:/o } else { $old = $1 if $$self =~ m/^($scheme_re):/o; } } return $old; } sub scheme { my $scheme = shift->_scheme(@_); return undef unless defined $scheme; lc($scheme); } sub has_recognized_scheme { my $self = shift; return ref($self) !~ /^URI::_(?:foreign|generic)\z/; } sub opaque { my $self = shift; unless (@_) { $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die; return $1; } $$self =~ /^($scheme_re:)? # optional scheme ([^\#]*) # opaque (\#.*)? # optional fragment $/sx or die; my $old_scheme = $1; my $old_opaque = $2; my $old_frag = $3; my $new_opaque = shift; $new_opaque = "" unless defined $new_opaque; $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_opaque); $$self = defined($old_scheme) ? $old_scheme : ""; $$self .= $new_opaque; $$self .= $old_frag if defined $old_frag; $old_opaque; } sub path { goto &opaque } # alias sub fragment { my $self = shift; unless (@_) { return undef unless $$self =~ /\#(.*)/s; return $1; } my $old; $old = $1 if $$self =~ s/\#(.*)//s; my $new_frag = shift; if (defined $new_frag) { $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego; utf8::downgrade($new_frag); $$self .= "#$new_frag"; } $old; } sub as_string { my $self = shift; $$self; } sub as_iri { my $self = shift; my $str = $$self; if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) { # All this crap because the more obvious: # # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift }) # # doesn't work before Encode 2.39. Wait for a standard release # to bundle that version. require Encode; my $enc = Encode::find_encoding("UTF-8"); my $u = ""; while (length $str) { $u .= $enc->decode($str, Encode::FB_QUIET()); if (length $str) { # escape next char $u .= URI::Escape::escape_char(substr($str, 0, 1, "")); } } $str = $u; } return $str; } sub canonical { # Make sure scheme is lowercased, that we don't escape unreserved chars, # and that we use upcase escape sequences. my $self = shift; my $scheme = $self->_scheme || ""; my $uc_scheme = $scheme =~ /[A-Z]/; my $esc = $$self =~ /%[a-fA-F0-9]{2}/; return $self unless $uc_scheme || $esc; my $other = $self->clone; if ($uc_scheme) { $other->_scheme(lc $scheme); } if ($esc) { $$other =~ s{%([0-9a-fA-F]{2})} { my $a = chr(hex($1)); $a =~ /^[$unreserved]\z/o ? $a : "%\U$1" }ge; } return $other; } # Compare two URIs, subclasses will provide a more correct implementation sub eq { my($self, $other) = @_; $self = URI->new($self, $other) unless ref $self; $other = URI->new($other, $self) unless ref $other; ref($self) eq ref($other) && # same class $self->canonical->as_string eq $other->canonical->as_string; } # generic-URI transformation methods sub abs { $_[0]; } sub rel { $_[0]; } sub secure { 0 } # help out Storable sub STORABLE_freeze { my($self, $cloning) = @_; return $$self; } sub STORABLE_thaw { my($self, $cloning, $str) = @_; $$self = $str; } 1; __END__ =head1 NAME URI - Uniform Resource Identifiers (absolute and relative) =head1 SYNOPSIS use URI (); $u1 = URI->new("http://www.example.com"); $u2 = URI->new("foo", "http"); $u3 = $u2->abs($u1); $u4 = $u3->clone; $u5 = URI->new("HTTP://WWW.example.com:80")->canonical; $str = $u->as_string; $str = "$u"; $scheme = $u->scheme; $opaque = $u->opaque; $path = $u->path; $frag = $u->fragment; $u->scheme("ftp"); $u->host("ftp.example.com"); $u->path("cpan/"); =head1 DESCRIPTION This module implements the C class. Objects of this class represent "Uniform Resource Identifier references" as specified in RFC 2396 (and updated by RFC 2732). A Uniform Resource Identifier is a compact string of characters that identifies an abstract or physical resource. A Uniform Resource Identifier can be further classified as either a Uniform Resource Locator (URL) or a Uniform Resource Name (URN). The distinction between URL and URN does not matter to the C class interface. A "URI-reference" is a URI that may have additional information attached in the form of a fragment identifier. An absolute URI reference consists of three parts: a I, a I and a I identifier. A subset of URI references share a common syntax for hierarchical namespaces. For these, the scheme-specific part is further broken down into I, I and I components. These URIs can also take the form of relative URI references, where the scheme (and usually also the authority) component is missing, but implied by the context of the URI reference. The three forms of URI reference syntax are summarized as follows: :# ://?# ?# The components into which a URI reference can be divided depend on the I. The C class provides methods to get and set the individual components. The methods available for a specific C object depend on the scheme. =head1 CONSTRUCTORS The following methods construct new C objects: =over 4 =item $uri = URI->new( $str ) =item $uri = URI->new( $str, $scheme ) Constructs a new URI object. The string representation of a URI is given as argument, together with an optional scheme specification. Common URI wrappers like "" and <>, as well as leading and trailing white space, are automatically removed from the $str argument before it is processed further. The constructor determines the scheme, maps this to an appropriate URI subclass, constructs a new object of that class and returns it. If the scheme isn't one of those that URI recognizes, you still get an URI object back that you can access the generic methods on. The C<< $uri->has_recognized_scheme >> method can be used to test for this. The $scheme argument is only used when $str is a relative URI. It can be either a simple string that denotes the scheme, a string containing an absolute URI reference, or an absolute C object. If no $scheme is specified for a relative URI $str, then $str is simply treated as a generic URI (no scheme-specific methods available). The set of characters available for building URI references is restricted (see L). Characters outside this set are automatically escaped by the URI constructor. =item $uri = URI->new_abs( $str, $base_uri ) Constructs a new absolute URI object. The $str argument can denote a relative or absolute URI. If relative, then it is absolutized using $base_uri as base. The $base_uri must be an absolute URI. =item $uri = URI::file->new( $filename ) =item $uri = URI::file->new( $filename, $os ) Constructs a new I URI from a file name. See L. =item $uri = URI::file->new_abs( $filename ) =item $uri = URI::file->new_abs( $filename, $os ) Constructs a new absolute I URI from a file name. See L. =item $uri = URI::file->cwd Returns the current working directory as a I URI. See L. =item $uri->clone Returns a copy of the $uri. =back =head1 COMMON METHODS The methods described in this section are available for all C objects. Methods that give access to components of a URI always return the old value of the component. The value returned is C if the component was not present. There is generally a difference between a component that is empty (represented as C<"">) and a component that is missing (represented as C). If an accessor method is given an argument, it updates the corresponding component in addition to returning the old value of the component. Passing an undefined argument removes the component (if possible). The description of each accessor method indicates whether the component is passed as an escaped (percent-encoded) or an unescaped string. A component that can be further divided into sub-parts are usually passed escaped, as unescaping might change its semantics. The common methods available for all URI are: =over 4 =item $uri->scheme =item $uri->scheme( $new_scheme ) Sets and returns the scheme part of the $uri. If the $uri is relative, then $uri->scheme returns C. If called with an argument, it updates the scheme of $uri, possibly changing the class of $uri, and returns the old scheme value. The method croaks if the new scheme name is illegal; a scheme name must begin with a letter and must consist of only US-ASCII letters, numbers, and a few special marks: ".", "+", "-". This restriction effectively means that the scheme must be passed unescaped. Passing an undefined argument to the scheme method makes the URI relative (if possible). Letter case does not matter for scheme names. The string returned by $uri->scheme is always lowercase. If you want the scheme just as it was written in the URI in its original case, you can use the $uri->_scheme method instead. =item $uri->has_recognized_scheme Returns TRUE if the URI scheme is one that URI recognizes. It will also be TRUE for relative URLs where a recognized scheme was provided to the constructor, even if C<< $uri->scheme >> returns C for these. =item $uri->opaque =item $uri->opaque( $new_opaque ) Sets and returns the scheme-specific part of the $uri (everything between the scheme and the fragment) as an escaped string. =item $uri->path =item $uri->path( $new_path ) Sets and returns the same value as $uri->opaque unless the URI supports the generic syntax for hierarchical namespaces. In that case the generic method is overridden to set and return the part of the URI between the I and the I. =item $uri->fragment =item $uri->fragment( $new_frag ) Returns the fragment identifier of a URI reference as an escaped string. =item $uri->as_string Returns a URI object to a plain ASCII string. URI objects are also converted to plain strings automatically by overloading. This means that $uri objects can be used as plain strings in most Perl constructs. =item $uri->as_iri Returns a Unicode string representing the URI. Escaped UTF-8 sequences representing non-ASCII characters are turned into their corresponding Unicode code point. =item $uri->canonical Returns a normalized version of the URI. The rules for normalization are scheme-dependent. They usually involve lowercasing the scheme and Internet host name components, removing the explicit port specification if it matches the default port, uppercasing all escape sequences, and unescaping octets that can be better represented as plain characters. For efficiency reasons, if the $uri is already in normalized form, then a reference to it is returned instead of a copy. =item $uri->eq( $other_uri ) =item URI::eq( $first_uri, $other_uri ) Tests whether two URI references are equal. URI references that normalize to the same string are considered equal. The method can also be used as a plain function which can also test two string arguments. If you need to test whether two C object references denote the same object, use the '==' operator. =item $uri->abs( $base_uri ) Returns an absolute URI reference. If $uri is already absolute, then a reference to it is simply returned. If the $uri is relative, then a new absolute URI is constructed by combining the $uri and the $base_uri, and returned. =item $uri->rel( $base_uri ) Returns a relative URI reference if it is possible to make one that denotes the same resource relative to $base_uri. If not, then $uri is simply returned. =item $uri->secure Returns a TRUE value if the URI is considered to point to a resource on a secure channel, such as an SSL or TLS encrypted one. =back =head1 GENERIC METHODS The following methods are available to schemes that use the common/generic syntax for hierarchical namespaces. The descriptions of schemes below indicate which these are. Unrecognized schemes are assumed to support the generic syntax, and therefore the following methods: =over 4 =item $uri->authority =item $uri->authority( $new_authority ) Sets and returns the escaped authority component of the $uri. =item $uri->path =item $uri->path( $new_path ) Sets and returns the escaped path component of the $uri (the part between the host name and the query or fragment). The path can never be undefined, but it can be the empty string. =item $uri->path_query =item $uri->path_query( $new_path_query ) Sets and returns the escaped path and query components as a single entity. The path and the query are separated by a "?" character, but the query can itself contain "?". =item $uri->path_segments =item $uri->path_segments( $segment, ... ) Sets and returns the path. In a scalar context, it returns the same value as $uri->path. In a list context, it returns the unescaped path segments that make up the path. Path segments that have parameters are returned as an anonymous array. The first element is the unescaped path segment proper; subsequent elements are escaped parameter strings. Such an anonymous array uses overloading so it can be treated as a string too, but this string does not include the parameters. Note that absolute paths have the empty string as their first I, i.e. the I C have 3 I; "", "foo" and "bar". =item $uri->query =item $uri->query( $new_query ) Sets and returns the escaped query component of the $uri. =item $uri->query_form =item $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) =item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim ) =item $uri->query_form( \@key_value_pairs ) =item $uri->query_form( \@key_value_pairs, $delim ) =item $uri->query_form( \%hash ) =item $uri->query_form( \%hash, $delim ) Sets and returns query components that use the I format. Key/value pairs are separated by "&", and the key is separated from the value by a "=" character. The form can be set either by passing separate key/value pairs, or via an array or hash reference. Passing an empty array or an empty hash removes the query component, whereas passing no arguments at all leaves the component unchanged. The order of keys is undefined if a hash reference is passed. The old value is always returned as a list of separate key/value pairs. Assigning this list to a hash is unwise as the keys returned might repeat. The values passed when setting the form can be plain strings or references to arrays of strings. Passing an array of values has the same effect as passing the key repeatedly with one value at a time. All the following statements have the same effect: $uri->query_form(foo => 1, foo => 2); $uri->query_form(foo => [1, 2]); $uri->query_form([ foo => 1, foo => 2 ]); $uri->query_form([ foo => [1, 2] ]); $uri->query_form({ foo => [1, 2] }); The $delim parameter can be passed as ";" to force the key/value pairs to be delimited by ";" instead of "&" in the query string. This practice is often recommended for URLs embedded in HTML or XML documents as this avoids the trouble of escaping the "&" character. You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to ";" for the same global effect. =item @keys = $u->query_param =item @values = $u->query_param( $key ) =item $first_value = $u->query_param( $key ) =item $u->query_param( $key, $value,... ) If $u->query_param is called with no arguments, it returns all the distinct parameter keys of the URI. In a scalar context it returns the number of distinct keys. When a $key argument is given, the method returns the parameter values with the given key. In a scalar context, only the first parameter value is returned. If additional arguments are given, they are used to update successive parameters with the given key. If any of the values provided are array references, then the array is dereferenced to get the actual values. Please note that you can supply multiple values to this method, but you cannot supply multiple keys. Do this: $uri->query_param( widget_id => 1, 5, 9 ); Do NOT do this: $uri->query_param( widget_id => 1, frobnicator_id => 99 ); =item $u->query_param_append($key, $value,...) Adds new parameters with the given key without touching any old parameters with the same key. It can be explained as a more efficient version of: $u->query_param($key, $u->query_param($key), $value,...); One difference is that this expression would return the old values of $key, whereas the query_param_append() method does not. =item @values = $u->query_param_delete($key) =item $first_value = $u->query_param_delete($key) Deletes all key/value pairs with the given key. The old values are returned. In a scalar context, only the first value is returned. Using the query_param_delete() method is slightly more efficient than the equivalent: $u->query_param($key, []); =item $hashref = $u->query_form_hash =item $u->query_form_hash( \%new_form ) Returns a reference to a hash that represents the query form's key/value pairs. If a key occurs multiple times, then the hash value becomes an array reference. Note that sequence information is lost. This means that: $u->query_form_hash($u->query_form_hash); is not necessarily a no-op, as it may reorder the key/value pairs. The values returned by the query_param() method should stay the same though. =item $uri->query_keywords =item $uri->query_keywords( $keywords, ... ) =item $uri->query_keywords( \@keywords ) Sets and returns query components that use the keywords separated by "+" format. The keywords can be set either by passing separate keywords directly or by passing a reference to an array of keywords. Passing an empty array removes the query component, whereas passing no arguments at all leaves the component unchanged. The old value is always returned as a list of separate words. =back =head1 SERVER METHODS For schemes where the I component denotes an Internet host, the following methods are available in addition to the generic methods. =over 4 =item $uri->userinfo =item $uri->userinfo( $new_userinfo ) Sets and returns the escaped userinfo part of the authority component. For some schemes this is a user name and a password separated by a colon. This practice is not recommended. Embedding passwords in clear text (such as URI) has proven to be a security risk in almost every case where it has been used. =item $uri->host =item $uri->host( $new_host ) Sets and returns the unescaped hostname. If the C<$new_host> string ends with a colon and a number, then this number also sets the port. For IPv6 addresses the brackets around the raw address is removed in the return value from $uri->host. When setting the host attribute to an IPv6 address you can use a raw address or one enclosed in brackets. The address needs to be enclosed in brackets if you want to pass in a new port value as well. my $uri = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html"); print $u->host; # www.xn--ri-sample-fra0f =item $uri->ihost Returns the host in Unicode form. Any IDNA A-labels (encoded unicode chars with I prefix) are turned into U-labels (unicode chars). my $uri = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html"); print $u->ihost; # www.\xC3\xBCri-sample =item $uri->port =item $uri->port( $new_port ) Sets and returns the port. The port is a simple integer that should be greater than 0. If a port is not specified explicitly in the URI, then the URI scheme's default port is returned. If you don't want the default port substituted, then you can use the $uri->_port method instead. =item $uri->host_port =item $uri->host_port( $new_host_port ) Sets and returns the host and port as a single unit. The returned value includes a port, even if it matches the default port. The host part and the port part are separated by a colon: ":". For IPv6 addresses the bracketing is preserved; thus URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with $uri->host which will remove the brackets. =item $uri->default_port Returns the default port of the URI scheme to which $uri belongs. For I this is the number 80, for I this is the number 21, etc. The default port for a scheme can not be changed. =back =head1 SCHEME-SPECIFIC SUPPORT Scheme-specific support is provided for the following URI schemes. For C objects that do not belong to one of these, you can only use the common and generic methods. =over 4 =item B: The I URI scheme is specified in RFC 2397. It allows inclusion of small data items as "immediate" data, as if it had been included externally. C objects belonging to the data scheme support the common methods and two new methods to access their scheme-specific components: $uri->media_type and $uri->data. See L for details. =item B: An old specification of the I URI scheme is found in RFC 1738. A new RFC 2396 based specification in not available yet, but file URI references are in common use. C objects belonging to the file scheme support the common and generic methods. In addition, they provide two methods for mapping file URIs back to local file names; $uri->file and $uri->dir. See L for details. =item B: An old specification of the I URI scheme is found in RFC 1738. A new RFC 2396 based specification in not available yet, but ftp URI references are in common use. C objects belonging to the ftp scheme support the common, generic and server methods. In addition, they provide two methods for accessing the userinfo sub-components: $uri->user and $uri->password. =item B: The I URI scheme is specified in and will hopefully be available as a RFC 2396 based specification. C objects belonging to the gopher scheme support the common, generic and server methods. In addition, they support some methods for accessing gopher-specific path components: $uri->gopher_type, $uri->selector, $uri->search, $uri->string. =item B: The I URI scheme is specified in RFC 2616. The scheme is used to reference resources hosted by HTTP servers. C objects belonging to the http scheme support the common, generic and server methods. =item B: The I URI scheme is a Netscape invention which is commonly implemented. The scheme is used to reference HTTP servers through SSL connections. Its syntax is the same as http, but the default port is different. =item B: The I URI scheme is specified in L. The scheme is used to reference physical location in a two- or three-dimensional coordinate reference system in a compact, simple, human-readable, and protocol-independent way. C objects belonging to the geo scheme support the common methods. =item B: The I URI scheme is specified in L. The scheme is used to reference resources hosted by ICAP servers. C objects belonging to the icap scheme support the common, generic and server methods. =item B: The I URI scheme is specified in L as well. The scheme is used to reference ICAP servers through SSL connections. Its syntax is the same as icap, including the same default port. =item B: The I URI scheme is specified in RFC 2255. LDAP is the Lightweight Directory Access Protocol. An ldap URI describes an LDAP search operation to perform to retrieve information from an LDAP directory. C objects belonging to the ldap scheme support the common, generic and server methods as well as ldap-specific methods: $uri->dn, $uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See L for details. =item B: Like the I URI scheme, but uses a UNIX domain socket. The server methods are not supported, and the local socket path is available as $uri->un_path. The I scheme is used by the OpenLDAP package. There is no real specification for it, but it is mentioned in various OpenLDAP manual pages. =item B: Like the I URI scheme, but uses an SSL connection. This scheme is deprecated, as the preferred way is to use the I mechanism. =item B: The I URI scheme is specified in RFC 2368. The scheme was originally used to designate the Internet mailing address of an individual or service. It has (in RFC 2368) been extended to allow setting of other mail header fields and the message body. C objects belonging to the mailto scheme support the common methods and the generic query methods. In addition, they support the following mailto-specific methods: $uri->to, $uri->headers. Note that the "foo@example.com" part of a mailto is I the C and C but instead the C. This allows a mailto URI to contain multiple comma separated email addresses. =item B: The I URL specification can be found at L. C objects belonging to the mms scheme support the common, generic, and server methods, with the exception of userinfo and query-related sub-components. =item B: The I, I and I URI schemes are specified in and will hopefully be available as an RFC 2396 based specification soon. (Update: as of April 2010, they are in L. C objects belonging to the news scheme support the common, generic and server methods. In addition, they provide some methods to access the path: $uri->group and $uri->message. =item B: See I scheme. =item B: See I scheme and L. =item B: The I URI scheme is specified in RFC 2384. The scheme is used to reference a POP3 mailbox. C objects belonging to the pop scheme support the common, generic and server methods. In addition, they provide two methods to access the userinfo components: $uri->user and $uri->auth =item B: An old specification of the I URI scheme is found in RFC 1738. C objects belonging to the rlogin scheme support the common, generic and server methods. =item B: The I URL specification can be found in section 3.2 of RFC 2326. C objects belonging to the rtsp scheme support the common, generic, and server methods, with the exception of userinfo and query-related sub-components. =item B: The I URI scheme is used to talk to RTSP servers over UDP instead of TCP. The syntax is the same as rtsp. =item B: Information about rsync is available from L. C objects belonging to the rsync scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B: The I URI specification is described in sections 19.1 and 25 of RFC 3261. C objects belonging to the sip scheme support the common, generic, and server methods with the exception of path related sub-components. In addition, they provide two methods to get and set I parameters: $uri->params_form and $uri->params. =item B: See I scheme. Its syntax is the same as sip, but the default port is different. =item B: See I scheme. Its syntax is the same as news, but the default port is different. =item B: An old specification of the I URI scheme is found in RFC 1738. C objects belonging to the telnet scheme support the common, generic and server methods. =item B: These URIs are used like I URIs but for connections to IBM mainframes. C objects belonging to the tn3270 scheme support the common, generic and server methods. =item B: Information about ssh is available at L. C objects belonging to the ssh scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B: C objects belonging to the sftp scheme support the common, generic and server methods. In addition, they provide methods to access the userinfo sub-components: $uri->user and $uri->password. =item B: The syntax of Uniform Resource Names is specified in RFC 2141. C objects belonging to the urn scheme provide the common methods, and also the methods $uri->nid and $uri->nss, which return the Namespace Identifier and the Namespace-Specific String respectively. The Namespace Identifier basically works like the Scheme identifier of URIs, and further divides the URN namespace. Namespace Identifier assignments are maintained at L. Letter case is not significant for the Namespace Identifier. It is always returned in lower case by the $uri->nid method. The $uri->_nid method can be used if you want it in its original case. =item B:B: The C namespace contains International Standard Book Numbers (ISBNs) and is described in RFC 3187. A C object belonging to this namespace has the following extra methods (if the Business::ISBN module is available): $uri->isbn, $uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code, which is still supported by issues a deprecation warning), $uri->isbn_as_ean. =item B:B: The C namespace contains Object Identifiers (OIDs) and is described in RFC 3061. An object identifier consists of sequences of digits separated by dots. A C object belonging to this namespace has an additional method called $uri->oid that can be used to get/set the oid value. In a list context, oid numbers are returned as separate elements. =back =head1 CONFIGURATION VARIABLES The following configuration variables influence how the class and its methods behave: =over 4 =item $URI::ABS_ALLOW_RELATIVE_SCHEME Some older parsers used to allow the scheme name to be present in the relative URL if it was the same as the base URL scheme. RFC 2396 says that this should be avoided, but you can enable this old behaviour by setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value. The difference is demonstrated by the following examples: URI->new("http:foo")->abs("http://host/a/b") ==> "http:foo" local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; URI->new("http:foo")->abs("http://host/a/b") ==> "http:/host/a/foo" =item $URI::ABS_REMOTE_LEADING_DOTS You can also have the abs() method ignore excess ".." segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS to a TRUE value. The difference is demonstrated by the following examples: URI->new("../../../foo")->abs("http://host/a/b") ==> "http://host/../../foo" local $URI::ABS_REMOTE_LEADING_DOTS = 1; URI->new("../../../foo")->abs("http://host/a/b") ==> "http://host/foo" =item $URI::DEFAULT_QUERY_FORM_DELIMITER This value can be set to ";" to have the query form C pairs delimited by ";" instead of "&" which is the default. =back =head1 ENVIRONMENT VARIABLES =over 4 =item URI_HAS_RESERVED_SQUARE_BRACKETS Before version 5.11, URI treated square brackets as reserved characters throughout the whole URI string. However, these brackets are reserved only within the authority/host part of the URI and nowhere else (RFC 3986). Starting with version 5.11, URI takes this distinction into account. Setting the environment variable C (programmatically or via the shell), restores the old behavior. #-- restore 5.10 behavior programmatically BEGIN { $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 1; } use URI (); I: This environment variable is just used during initialization and has to be set I module URI is used/required. Changing it at run time has no effect. Its value can be checked programmatically by accessing the constant C. =back =head1 BUGS There are some things that are not quite right: =over =item * Using regexp variables like $1 directly as arguments to the URI accessor methods does not work too well with current perl implementations. I would argue that this is actually a bug in perl. The workaround is to quote them. Example: /(...)/ || die; $u->query("$1"); =item * The escaping (percent encoding) of chars in the 128 .. 255 range passed to the URI constructor or when setting URI parts using the accessor methods depend on the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed. If the UTF8 flag is set the UTF-8 encoded version of the character is percent encoded. If the UTF8 flag isn't set the Latin-1 version (byte) of the character is percent encoded. This basically exposes the internal encoding of Perl strings. =back =head1 PARSING URIs WITH REGEXP As an alternative to this module, the following (official) regular expression can be used to decode a URI: my($scheme, $authority, $path, $query, $fragment) = $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; The C module provides the function uri_split() as a readable alternative. =head1 SEE ALSO L, L, L, L, L RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax", Berners-Lee, Fielding, Masinter, August 1998. L L L =head1 COPYRIGHT Copyright 1995-2009 Gisle Aas. Copyright 1995 Martijn Koster. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHORS / ACKNOWLEDGMENTS This module is based on the C module, which in turn was (distantly) based on the C code in the libwww-perl for perl4 developed by Roy Fielding, as part of the Arcadia project at the University of California, Irvine, with contributions from Brooks Cutter. C was developed by Gisle Aas, Tim Bunce, Roy Fielding and Martijn Koster with input from other people on the libwww-perl mailing list. C and related subclasses was developed by Gisle Aas. =cut URI-5.28/lib/URI/0000775000175000017500000000000014600675475011760 5ustar olafolafURI-5.28/lib/URI/_server.pm0000644000175000017500000000745614600675475013775 0ustar olafolafpackage URI::_server; use strict; use warnings; use parent 'URI::_generic'; use URI::Escape qw(uri_unescape); our $VERSION = '5.28'; sub _uric_escape { my($class, $str) = @_; if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { my($scheme, $host, $rest) = ($1, $2, $3); my $ui = $host =~ s/(.*@)// ? $1 : ""; my $port = $host =~ s/(:\d+)\z// ? $1 : ""; if (_host_escape($host)) { $str = "$scheme//$ui$host$port$rest"; } } return $class->SUPER::_uric_escape($str); } sub _host_escape { return if URI::HAS_RESERVED_SQUARE_BRACKETS and $_[0] !~ /[^$URI::uric]/; return if !URI::HAS_RESERVED_SQUARE_BRACKETS and $_[0] !~ /[^$URI::uric4host]/; eval { require URI::_idna; $_[0] = URI::_idna::encode($_[0]); }; return 0 if $@; return 1; } sub as_iri { my $self = shift; my $str = $self->SUPER::as_iri; if ($str =~ /\bxn--/) { if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) { my($scheme, $host, $rest) = ($1, $2, $3); my $ui = $host =~ s/(.*@)// ? $1 : ""; my $port = $host =~ s/(:\d+)\z// ? $1 : ""; require URI::_idna; $host = URI::_idna::decode($host); $str = "$scheme//$ui$host$port$rest"; } } return $str; } sub userinfo { my $self = shift; my $old = $self->authority; if (@_) { my $new = $old; $new = "" unless defined $new; $new =~ s/.*@//; # remove old stuff my $ui = shift; if (defined $ui) { $ui =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego; $new = "$ui\@$new"; } $self->authority($new); } return undef if !defined($old) || $old !~ /(.*)@/; return $1; } sub host { my $self = shift; my $old = $self->authority; if (@_) { my $tmp = $old; $tmp = "" unless defined $tmp; my $ui = ($tmp =~ /(.*@)/) ? $1 : ""; my $port = ($tmp =~ /(:\d+)$/) ? $1 : ""; my $new = shift; $new = "" unless defined $new; if (length $new) { $new =~ s/[@]/%40/g; # protect @ if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) { $new =~ s/(:\d*)\z// || die "Assert"; $port = $1; } $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address _host_escape($new); } $self->authority("$ui$new$port"); } return undef unless defined $old; $old =~ s/.*@//; $old =~ s/:\d+$//; # remove the port $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2) return uri_unescape($old); } sub ihost { my $self = shift; my $old = $self->host(@_); if ($old =~ /(^|\.)xn--/) { require URI::_idna; $old = URI::_idna::decode($old); } return $old; } sub _port { my $self = shift; my $old = $self->authority; if (@_) { my $new = $old; $new =~ s/:\d*$//; my $port = shift; $new .= ":$port" if defined $port; $self->authority($new); } return $1 if defined($old) && $old =~ /:(\d*)$/; return; } sub port { my $self = shift; my $port = $self->_port(@_); $port = $self->default_port if !defined($port) || $port eq ""; $port; } sub host_port { my $self = shift; my $old = $self->authority; $self->host(shift) if @_; return undef unless defined $old; $old =~ s/.*@//; # zap userinfo $old =~ s/:$//; # empty port should be treated the same a no port $old .= ":" . $self->port unless $old =~ /:\d+$/; $old; } sub default_port { undef } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $host = $other->host || ""; my $port = $other->_port; my $uc_host = $host =~ /[A-Z]/; my $def_port = defined($port) && ($port eq "" || $port == $self->default_port); if ($uc_host || $def_port) { $other = $other->clone if $other == $self; $other->host(lc $host) if $uc_host; $other->port(undef) if $def_port; } $other; } 1; URI-5.28/lib/URI/Escape.pm0000644000175000017500000001735314600675475013525 0ustar olafolafpackage URI::Escape; use strict; use warnings; =head1 NAME URI::Escape - Percent-encode and percent-decode unsafe characters =head1 SYNOPSIS use URI::Escape; $safe = uri_escape("10% is enough\n"); $verysafe = uri_escape("foo", "\0-\377"); $str = uri_unescape($safe); =head1 DESCRIPTION This module provides functions to percent-encode and percent-decode URI strings as defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping". This is the terminology used by this module, which predates the formalization of the terms by the RFC by several years. A URI consists of a restricted set of characters. The restricted set of characters consists of digits, letters, and a few graphic symbols chosen from those common to most of the character encodings and input facilities available to Internet users. They are made up of the "unreserved" and "reserved" character sets as defined in RFC 3986. unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@" "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "=" In addition, any byte (octet) can be represented in a URI by an escape sequence: a triplet consisting of the character "%" followed by two hexadecimal digits. A byte can also be represented directly by a character, using the US-ASCII character for that octet. Some of the characters are I for use as delimiters or as part of certain URI components. These must be escaped if they are to be treated as ordinary data. Read RFC 3986 for further details. The functions provided (and exported by default) from this module are: =over 4 =item uri_escape( $string ) =item uri_escape( $string, $unsafe ) Replaces each unsafe character in the $string with the corresponding escape sequence and returns the result. The $string argument should be a string of bytes. The uri_escape() function will croak if given a characters with code above 255. Use uri_escape_utf8() if you know you have such chars or/and want chars in the 128 .. 255 range treated as UTF-8. The uri_escape() function takes an optional second argument that overrides the set of characters that are to be escaped. The set is specified as a string that can be used in a regular expression character class (between [ ]). E.g.: "\x00-\x1f\x7f-\xff" # all control and hi-bit characters "a-z" # all lower case characters "^A-Za-z" # everything not a letter The default set of characters to be escaped is all those which are I part of the C character class shown above as well as the reserved characters. I.e. the default is: "^A-Za-z0-9\-\._~" The second argument can also be specified as a regular expression object: qr/[^A-Za-z]/ Any strings matched by this regular expression will have all of their characters escaped. =item uri_escape_utf8( $string ) =item uri_escape_utf8( $string, $unsafe ) Works like uri_escape(), but will encode chars as UTF-8 before escaping them. This makes this function able to deal with characters with code above 255 in $string. Note that chars in the 128 .. 255 range will be escaped differently by this function compared to what uri_escape() would. For chars in the 0 .. 127 range there is no difference. Equivalent to: utf8::encode($string); my $uri = uri_escape($string); Note: JavaScript has a function called escape() that produces the sequence "%uXXXX" for chars in the 256 .. 65535 range. This function has really nothing to do with URI escaping but some folks got confused since it "does the right thing" in the 0 .. 255 range. Because of this you sometimes see "URIs" with these kind of escapes. The JavaScript encodeURIComponent() function is similar to uri_escape_utf8(). =item uri_unescape($string,...) Returns a string with each %XX sequence replaced with the actual byte (octet). This does the same as: $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; but does not modify the string in-place as this RE would. Using the uri_unescape() function instead of the RE might make the code look cleaner and is a few characters less to type. In a simple benchmark test I did, calling the function (instead of the inline RE above) if a few chars were unescaped was something like 40% slower, and something like 700% slower if none were. If you are going to unescape a lot of times it might be a good idea to inline the RE. If the uri_unescape() function is passed multiple strings, then each one is returned unescaped. =back The module can also export the C<%escapes> hash, which contains the mapping from all 256 bytes to the corresponding escape codes. Lookup in this hash is faster than evaluating C each time. =head1 SEE ALSO L =head1 COPYRIGHT Copyright 1995-2004 Gisle Aas. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use Exporter 5.57 'import'; our %escapes; our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8); our @EXPORT_OK = qw(%escapes); our $VERSION = '5.28'; use Carp (); # Build a char->hex map for (0..255) { $escapes{chr($_)} = sprintf("%%%02X", $_); } my %subst; # compiled patterns my %Unsafe = ( RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/, RFC3986 => qr/[^A-Za-z0-9\-\._~]/, ); sub uri_escape { my($text, $patn) = @_; return undef unless defined $text; my $re; if (defined $patn){ if (ref $patn eq 'Regexp') { $text =~ s{($patn)}{ join('', map +($escapes{$_} || _fail_hi($_)), split //, "$1") }ge; return $text; } $re = $subst{$patn}; if (!defined $re) { $re = $patn; # we need to escape the [] characters, except for those used in # posix classes. if they are prefixed by a backslash, allow them # through unmodified. $re =~ s{(\[:\w+:\])|(\\)?([\[\]]|\\\z)}{ defined $1 ? $1 : defined $2 ? "$2$3" : "\\$3" }ge; eval { # disable the warnings here, since they will trigger later # when used, and we only want them to appear once per call, # but every time the same pattern is used. no warnings 'regexp'; $re = $subst{$patn} = qr{[$re]}; 1; } or Carp::croak("uri_escape: $@"); } } else { $re = $Unsafe{RFC3986}; } $text =~ s/($re)/$escapes{$1} || _fail_hi($1)/ge; $text; } sub _fail_hi { my $chr = shift; Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr)); } sub uri_escape_utf8 { my $text = shift; return undef unless defined $text; utf8::encode($text); return uri_escape($text, @_); } sub uri_unescape { # Note from RFC1630: "Sequences which start with a percent sign # but are not followed by two hexadecimal characters are reserved # for future extension" my $str = shift; if (@_ && wantarray) { # not executed for the common case of a single argument my @str = ($str, @_); # need to copy for (@str) { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; } return @str; } $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; $str; } # XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format. sub escape_char { # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1). # The following forces a fetch to occur beforehand. my $dummy = substr($_[0], 0, 0); if (utf8::is_utf8($_[0])) { my $s = shift; utf8::encode($s); unshift(@_, $s); } return join '', @URI::Escape::escapes{split //, $_[0]}; } 1; URI-5.28/lib/URI/snews.pm0000644000175000017500000000025414600675475013454 0ustar olafolafpackage URI::snews; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::news'; sub default_port { 563 } sub secure { 1 } 1; URI-5.28/lib/URI/URL.pm0000644000175000017500000001255714600675475012770 0ustar olafolafpackage URI::URL; use strict; use warnings; use parent 'URI::WithBase'; our $VERSION = '5.28'; # Provide as much as possible of the old URI::URL interface for backwards # compatibility... use Exporter 5.57 'import'; our @EXPORT = qw(url); # Easy to use constructor sub url ($;$) { URI::URL->new(@_); } use URI::Escape qw(uri_unescape); sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->[0] = $self->[0]->canonical; $self; } sub newlocal { my $class = shift; require URI::file; bless [URI::file->new_abs(shift)], $class; } {package URI::_foreign; sub _init # hope it is not defined { my $class = shift; die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT; $class->SUPER::_init(@_); } } sub strict { my $old = $URI::URL::STRICT; $URI::URL::STRICT = shift if @_; $old; } sub print_on { my $self = shift; require Data::Dumper; print STDERR Data::Dumper::Dumper($self); } sub _try { my $self = shift; my $method = shift; scalar(eval { $self->$method(@_) }); } sub crack { # should be overridden by subclasses my $self = shift; (scalar($self->scheme), $self->_try("user"), $self->_try("password"), $self->_try("host"), $self->_try("port"), $self->_try("path"), $self->_try("params"), $self->_try("query"), scalar($self->fragment), ) } sub full_path { my $self = shift; my $path = $self->path_query; $path = "/" unless length $path; $path; } sub netloc { shift->authority(@_); } sub epath { my $path = shift->SUPER::path(@_); $path =~ s/;.*//; $path; } sub eparams { my $self = shift; my @p = $self->path_segments; return undef unless ref($p[-1]); @p = @{$p[-1]}; shift @p; join(";", @p); } sub params { shift->eparams(@_); } sub path { my $self = shift; my $old = $self->epath(@_); return unless defined wantarray; return '/' if !defined($old) || !length($old); Carp::croak("Path components contain '/' (you must call epath)") if $old =~ /%2[fF]/ and !@_; $old = "/$old" if $old !~ m|^/| && defined $self->netloc; return uri_unescape($old); } sub path_components { shift->path_segments(@_); } sub query { my $self = shift; my $old = $self->equery(@_); if (defined(wantarray) && defined($old)) { if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+' my $mess; for ($old) { $mess = "Query contains both '+' and '%2B'" if /\+/ && /%2[bB]/; $mess = "Form query contains escaped '=' or '&'" if /=/ && /%(?:3[dD]|26)/; } if ($mess) { Carp::croak("$mess (you must call equery)"); } } # Now it should be safe to unescape the string without losing # information return uri_unescape($old); } undef; } sub abs { my $self = shift; my $base = shift; my $allow_scheme = shift; $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME unless defined $allow_scheme; local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme; local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS; $self->SUPER::abs($base); } sub frag { shift->fragment(@_); } sub keywords { shift->query_keywords(@_); } # file: sub local_path { shift->file; } sub unix_path { shift->file("unix"); } sub dos_path { shift->file("dos"); } sub mac_path { shift->file("mac"); } sub vms_path { shift->file("vms"); } # mailto: sub address { shift->to(@_); } sub encoded822addr { shift->to(@_); } sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work # news: sub groupart { shift->_group(@_); } sub article { shift->message(@_); } 1; __END__ =head1 NAME URI::URL - Uniform Resource Locators =head1 SYNOPSIS $u1 = URI::URL->new($str, $base); $u2 = $u1->abs; =head1 DESCRIPTION This module is provided for backwards compatibility with modules that depend on the interface provided by the C class that used to be distributed with the libwww-perl library. The following differences exist compared to the C class interface: =over 3 =item * The URI::URL module exports the url() function as an alternate constructor interface. =item * The constructor takes an optional $base argument. The C class is a subclass of C. =item * The URI::URL->newlocal class method is the same as URI::file->new_abs. =item * URI::URL::strict(1) =item * $url->print_on method =item * $url->crack method =item * $url->full_path: same as ($uri->abs_path || "/") =item * $url->netloc: same as $uri->authority =item * $url->epath, $url->equery: same as $uri->path, $uri->query =item * $url->path and $url->query pass unescaped strings. =item * $url->path_components: same as $uri->path_segments (if you don't consider path segment parameters) =item * $url->params and $url->eparams methods =item * $url->base method. See L. =item * $url->abs and $url->rel have an optional $base argument. See L. =item * $url->frag: same as $uri->fragment =item * $url->keywords: same as $uri->query_keywords =item * $url->localpath and friends map to $uri->file. =item * $url->address and $url->encoded822addr: same as $uri->to for mailto URI =item * $url->groupart method for news URI =item * $url->article: same as $uri->message =back =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright 1998-2000 Gisle Aas. =cut URI-5.28/lib/URI/ldaps.pm0000644000175000017500000000022014600675475013411 0ustar olafolafpackage URI::ldaps; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::ldap'; sub default_port { 636 } sub secure { 1 } 1; URI-5.28/lib/URI/rlogin.pm0000644000175000017500000000020114600675475013577 0ustar olafolafpackage URI::rlogin; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_login'; sub default_port { 513 } 1; URI-5.28/lib/URI/_generic.pm0000644000175000017500000001524514600675475014076 0ustar olafolafpackage URI::_generic; use strict; use warnings; use parent qw(URI URI::_query); use URI::Escape qw(uri_unescape); use Carp (); our $VERSION = '5.28'; my $ACHAR = URI::HAS_RESERVED_SQUARE_BRACKETS ? $URI::uric : $URI::uric4host; $ACHAR =~ s,\\[/?],,g; my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; sub _no_scheme_ok { 1 } our $IPv6_re; sub _looks_like_raw_ip6_address { my $addr = shift; if ( !$IPv6_re ) { #-- lazy / runs once / use Regexp::IPv6 if installed eval { require Regexp::IPv6; Regexp::IPv6->import( qw($IPv6_re) ); 1; } || do { $IPv6_re = qr/[:0-9a-f]{3,}/; }; #-- fallback: unambitious guess } return 0 unless $addr; return 0 if $addr =~ tr/:/:/ < 2; #-- fallback must not create false positive for IPv4:Port = 0:0 return 1 if $addr =~ /^$IPv6_re$/i; return 0; } sub authority { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; if (@_) { my $auth = shift; $$self = $1; my $rest = $3; if (defined $auth) { $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego; if ( my ($user, $host) = $auth =~ /^(.*@)?([^@]+)$/ ) { #-- special escape userinfo part $user ||= ''; $user =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego; $user =~ s/%40$/\@/; # recover final '@' $host = "[$host]" if _looks_like_raw_ip6_address( $host ); $auth = $user . $host; } utf8::downgrade($auth); $$self .= "//$auth"; } _check_path($rest, $$self); $$self .= $rest; } $2; } sub path { my $self = shift; $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; if (@_) { $$self = $1; my $rest = $3; my $new_path = shift; $new_path = "" unless defined $new_path; $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_path); _check_path($new_path, $$self); $$self .= $new_path . $rest; } $2; } sub path_query { my $self = shift; $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; if (@_) { $$self = $1; my $rest = $3; my $new_path = shift; $new_path = "" unless defined $new_path; $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($new_path); _check_path($new_path, $$self); $$self .= $new_path . $rest; } $2; } sub _check_path { my($path, $pre) = @_; my $prefix; if ($pre =~ m,/,) { # authority present $prefix = "/" if length($path) && $path !~ m,^[/?\#],; } else { if ($path =~ m,^//,) { Carp::carp("Path starting with double slash is confusing") if $^W; } elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { Carp::carp("Path might look like scheme, './' prepended") if $^W; $prefix = "./"; } } substr($_[0], 0, 0) = $prefix if defined $prefix; } sub path_segments { my $self = shift; my $path = $self->path; if (@_) { my @arg = @_; # make a copy for (@arg) { if (ref($_)) { my @seg = @$_; $seg[0] =~ s/%/%25/g; for (@seg) { s/;/%3B/g; } $_ = join(";", @seg); } else { s/%/%25/g; s/;/%3B/g; } s,/,%2F,g; } $self->path(join("/", @arg)); } return $path unless wantarray; map {/;/ ? $self->_split_segment($_) : uri_unescape($_) } split('/', $path, -1); } sub _split_segment { my $self = shift; require URI::_segment; URI::_segment->new(@_); } sub abs { my $self = shift; my $base = shift || Carp::croak("Missing base argument"); if (my $scheme = $self->scheme) { return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; $base = URI->new($base) unless ref $base; return $self unless $scheme eq $base->scheme; } $base = URI->new($base) unless ref $base; my $abs = $self->clone; $abs->scheme($base->scheme); return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; $abs->authority($base->authority); my $path = $self->path; return $abs if $path =~ m,^/,; if (!length($path)) { my $abs = $base->clone; my $query = $self->query; $abs->query($query) if defined $query; my $fragment = $self->fragment; $abs->fragment($fragment) if defined $fragment; return $abs; } my $p = $base->path; $p =~ s,[^/]+$,,; $p .= $path; my @p = split('/', $p, -1); shift(@p) if @p && !length($p[0]); my $i = 1; while ($i < @p) { #print "$i ", join("/", @p), " ($p[$i])\n"; if ($p[$i-1] eq ".") { splice(@p, $i-1, 1); $i-- if $i > 1; } elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { splice(@p, $i-1, 2); if ($i > 1) { $i--; push(@p, "") if $i == @p; } } else { $i++; } } $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." if ($URI::ABS_REMOTE_LEADING_DOTS) { shift @p while @p && $p[0] =~ /^\.\.?$/; } $abs->path("/" . join("/", @p)); $abs; } # The opposite of $url->abs. Return a URI which is as relative as possible sub rel { my $self = shift; my $base = shift || Carp::croak("Missing base argument"); my $rel = $self->clone; $base = URI->new($base) unless ref $base; #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; my $scheme = $rel->scheme; my $auth = $rel->canonical->authority; my $path = $rel->path; if (!defined($scheme) && !defined($auth)) { # it is already relative return $rel; } #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; my $bscheme = $base->scheme; my $bauth = $base->canonical->authority; my $bpath = $base->path; for ($bscheme, $bauth, $auth) { $_ = '' unless defined } unless ($scheme eq $bscheme && $auth eq $bauth) { # different location, can't make it relative return $rel; } for ($path, $bpath) { $_ = "/$_" unless m,^/,; } # Make it relative by eliminating scheme and authority $rel->scheme(undef); $rel->authority(undef); # This loop is based on code from Nicolai Langfeldt . # First we calculate common initial path components length ($li). my $li = 1; while (1) { my $i = index($path, '/', $li); last if $i < 0 || $i != index($bpath, '/', $li) || substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); $li=$i+1; } # then we nuke it from both paths substr($path, 0,$li) = ''; substr($bpath,0,$li) = ''; if ($path eq $bpath && defined($rel->fragment) && !defined($rel->query)) { $rel->path(""); } else { # Add one "../" for each path component left in the base path $path = ('../' x $bpath =~ tr|/|/|) . $path; $path = "./" if $path eq ""; $rel->path($path); } $rel; } 1; URI-5.28/lib/URI/IRI.pm0000644000175000017500000000143214600675475012737 0ustar olafolafpackage URI::IRI; # Experimental use strict; use warnings; use URI (); use overload '""' => sub { shift->as_string }; our $VERSION = '5.28'; sub new { my($class, $uri, $scheme) = @_; utf8::upgrade($uri); return bless { uri => URI->new($uri, $scheme), }, $class; } sub clone { my $self = shift; return bless { uri => $self->{uri}->clone, }, ref($self); } sub as_string { my $self = shift; return $self->{uri}->as_iri; } our $AUTOLOAD; sub AUTOLOAD { my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); # We create the function here so that it will not need to be # autoloaded the next time. no strict 'refs'; *$method = sub { shift->{uri}->$method(@_) }; goto &$method; } sub DESTROY {} # avoid AUTOLOADing it 1; URI-5.28/lib/URI/ldap.pm0000644000175000017500000000555414600675475013245 0ustar olafolaf# Copyright (c) 1998 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package URI::ldap; use strict; use warnings; our $VERSION = '5.28'; use parent qw(URI::_ldap URI::_server); sub default_port { 389 } sub _nonldap_canonical { my $self = shift; $self->URI::_server::canonical(@_); } 1; __END__ =head1 NAME URI::ldap - LDAP Uniform Resource Locators =head1 SYNOPSIS use URI; $uri = URI->new("ldap:$uri_string"); $dn = $uri->dn; $filter = $uri->filter; @attr = $uri->attributes; $scope = $uri->scope; %extn = $uri->extensions; $uri = URI->new("ldap:"); # start empty $uri->host("ldap.itd.umich.edu"); $uri->dn("o=University of Michigan,c=US"); $uri->attributes(qw(postalAddress)); $uri->scope('sub'); $uri->filter('(cn=Babs Jensen)'); print $uri->as_string,"\n"; =head1 DESCRIPTION C provides an interface to parse an LDAP URI into its constituent parts and also to build a URI as described in RFC 2255. =head1 METHODS C supports all the generic and server methods defined by L, plus the following. Each of the following methods can be used to set or get the value in the URI. The values are passed in unescaped form. None of these return undefined values, but elements without a default can be empty. If arguments are given, then a new value is set for the given part of the URI. =over 4 =item $uri->dn( [$new_dn] ) Sets or gets the I part of the URI. The DN identifies the base object of the LDAP search. =item $uri->attributes( [@new_attrs] ) Sets or gets the list of attribute names which are returned by the search. =item $uri->scope( [$new_scope] ) Sets or gets the scope to be used by the search. The value can be one of C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the return value defaults to C<"base">. =item $uri->_scope( [$new_scope] ) Same as scope(), but does not default to anything. =item $uri->filter( [$new_filter] ) Sets or gets the filter to be used by the search. If none is given in the URI then the return value defaults to C<"(objectClass=*)">. =item $uri->_filter( [$new_filter] ) Same as filter(), but does not default to anything. =item $uri->extensions( [$etype => $evalue,...] ) Sets or gets the extensions used for the search. The list passed should be in the form etype1 => evalue1, etype2 => evalue2,... This is also the form of list that is returned. =back =head1 SEE ALSO L =head1 AUTHOR Graham Barr EFE Slightly modified by Gisle Aas to fit into the URI distribution. =head1 COPYRIGHT Copyright (c) 1998 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-5.28/lib/URI/_query.pm0000644000175000017500000001136714600675475013630 0ustar olafolafpackage URI::_query; use strict; use warnings; use URI (); use URI::Escape qw(uri_unescape); use Scalar::Util (); our $VERSION = '5.28'; sub query { my $self = shift; $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die; if (@_) { my $q = shift; $$self = $1; if (defined $q) { $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; utf8::downgrade($q); $$self .= "?$q"; } $$self .= $3; } $2; } # Handle ...?foo=bar&bar=foo type of query sub query_form { my $self = shift; my $old = $self->query; if (@_) { # Try to set query string my $delim; my $r = $_[0]; if (_is_array($r)) { $delim = $_[1]; @_ = @$r; } elsif (ref($r) eq "HASH") { $delim = $_[1]; @_ = map { $_ => $r->{$_} } sort keys %$r; } $delim = pop if @_ % 2; my @query; while (my($key,$vals) = splice(@_, 0, 2)) { $key = '' unless defined $key; $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; $key =~ s/ /+/g; $vals = [_is_array($vals) ? @$vals : $vals]; for my $val (@$vals) { if (defined $val) { $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; $val =~ s/ /+/g; push(@query, "$key=$val"); } else { push(@query, $key); } } } if (@query) { unless ($delim) { $delim = $1 if $old && $old =~ /([&;])/; $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&"; } $self->query(join($delim, @query)); } else { $self->query(undef); } } return if !defined($old) || !length($old) || !defined(wantarray); return unless $old =~ /=/; # not a form map { ( defined ) ? do { s/\+/ /g; uri_unescape($_) } : undef } map { /=/ ? split(/=/, $_, 2) : ($_ => undef)} split(/[&;]/, $old); } # Handle ...?dog+bones type of query sub query_keywords { my $self = shift; my $old = $self->query; if (@_) { # Try to set query string my @copy = @_; @copy = @{$copy[0]} if @copy == 1 && _is_array($copy[0]); for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; } $self->query(@copy ? join('+', @copy) : undef); } return if !defined($old) || !defined(wantarray); return if $old =~ /=/; # not keywords, but a form map { uri_unescape($_) } split(/\+/, $old, -1); } # Some URI::URL compatibility stuff sub equery { goto &query } sub query_param { my $self = shift; my @old = $self->query_form; if (@_ == 0) { # get keys my (%seen, $i); return grep !($i++ % 2 || $seen{$_}++), @old; } my $key = shift; my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old; if (@_) { my @new = @old; my @new_i = @i; my @vals = map { _is_array($_) ? @$_ : $_ } @_; while (@new_i > @vals) { splice @new, pop @new_i, 2; } if (@vals > @new_i) { my $i = @new_i ? $new_i[-1] + 2 : @new; my @splice = splice @vals, @new_i, @vals - @new_i; splice @new, $i, 0, map { $key => $_ } @splice; } if (@vals) { #print "SET $new_i[0]\n"; @new[ map $_ + 1, @new_i ] = @vals; } $self->query_form(\@new); } return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef; } sub query_param_append { my $self = shift; my $key = shift; my @vals = map { _is_array($_) ? @$_ : $_ } @_; $self->query_form($self->query_form, $key => \@vals); # XXX return; } sub query_param_delete { my $self = shift; my $key = shift; my @old = $self->query_form; my @vals; for (my $i = @old - 2; $i >= 0; $i -= 2) { next if $old[$i] ne $key; push(@vals, (splice(@old, $i, 2))[1]); } $self->query_form(\@old) if @vals; return wantarray ? reverse @vals : $vals[-1]; } sub query_form_hash { my $self = shift; my @old = $self->query_form; if (@_) { $self->query_form(@_ == 1 ? %{shift(@_)} : @_); } my %hash; while (my($k, $v) = splice(@old, 0, 2)) { if (exists $hash{$k}) { for ($hash{$k}) { $_ = [$_] unless _is_array($_); push(@$_, $v); } } else { $hash{$k} = $v; } } return \%hash; } sub _is_array { return( defined($_[0]) && ( Scalar::Util::reftype($_[0]) || '' ) eq "ARRAY" && !( Scalar::Util::blessed( $_[0] ) && overload::Method( $_[0], '""' ) ) ); } 1; URI-5.28/lib/URI/urn/0000775000175000017500000000000014600675475012564 5ustar olafolafURI-5.28/lib/URI/urn/isbn.pm0000644000175000017500000000474414600675475014064 0ustar olafolafpackage URI::urn::isbn; # RFC 3187 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::urn'; use Carp qw(carp); BEGIN { require Business::ISBN; local $^W = 0; # don't warn about dev versions, perl5.004 style warn "Using Business::ISBN version " . Business::ISBN->VERSION . " which is deprecated.\nUpgrade to Business::ISBN version 3.005\n" if Business::ISBN->VERSION < 3.005; } sub _isbn { my $nss = shift; $nss = $nss->nss if ref($nss); my $isbn = Business::ISBN->new($nss); $isbn = undef if $isbn && !$isbn->is_valid; return $isbn; } sub _nss_isbn { my $self = shift; my $nss = $self->nss(@_); my $isbn = _isbn($nss); $isbn = $isbn->as_string if $isbn; return($nss, $isbn); } sub isbn { my $self = shift; my $isbn; (undef, $isbn) = $self->_nss_isbn(@_); return $isbn; } sub isbn_publisher_code { my $isbn = shift->_isbn || return undef; return $isbn->publisher_code; } BEGIN { my $group_method = do { local $^W = 0; # don't warn about dev versions, perl5.004 style Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code'; }; sub isbn_group_code { my $isbn = shift->_isbn || return undef; return $isbn->$group_method; } } sub isbn_country_code { my $name = (caller(0))[3]; $name =~ s/.*:://; carp "$name is DEPRECATED. Use isbn_group_code instead"; no strict 'refs'; &isbn_group_code; } BEGIN { my $isbn13_method = do { local $^W = 0; # don't warn about dev versions, perl5.004 style Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean'; }; sub isbn13 { my $isbn = shift->_isbn || return undef; # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects # and it uses the hyphens, so call as_string with an empty anon array # or, adjust the test and features to say that it comes out with hyphens. my $thingy = $isbn->$isbn13_method; return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy; } } sub isbn_as_ean { my $name = (caller(0))[3]; $name =~ s/.*:://; carp "$name is DEPRECATED. Use isbn13 instead"; no strict 'refs'; &isbn13; } sub canonical { my $self = shift; my($nss, $isbn) = $self->_nss_isbn; my $new = $self->SUPER::canonical; return $new unless $nss && $isbn && $nss ne $isbn; $new = $new->clone if $new == $self; $new->nss($isbn); return $new; } 1; URI-5.28/lib/URI/urn/oid.pm0000644000175000017500000000043314600675475013673 0ustar olafolafpackage URI::urn::oid; # RFC 2061 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::urn'; sub oid { my $self = shift; my $old = $self->nss; if (@_) { $self->nss(join(".", @_)); } return split(/\./, $old) if wantarray; return $old; } 1; URI-5.28/lib/URI/Heuristic.pm0000644000175000017500000001457714600675475014271 0ustar olafolafpackage URI::Heuristic; =head1 NAME URI::Heuristic - Expand URI using heuristics =head1 SYNOPSIS use URI::Heuristic qw(uf_uristr); $u = uf_uristr("example"); # http://www.example.com $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol $u = uf_uristr("aas"); # http://www.aas.no $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi $u = uf_uristr("/etc/passwd"); # file:/etc/passwd =head1 DESCRIPTION This module provides functions that expand strings into real absolute URIs using some built-in heuristics. Strings that already represent absolute URIs (i.e. that start with a C part) are never modified and are returned unchanged. The main use of these functions is to allow abbreviated URIs similar to what many web browsers allow for URIs typed in by the user. The following functions are provided: =over 4 =item uf_uristr($str) Tries to make the argument string into a proper absolute URI string. The "uf_" prefix stands for "User Friendly". Under MacOS, it assumes that any string with a common URL scheme (http, ftp, etc.) is a URL rather than a local path. So don't name your volumes after common URL schemes and expect uf_uristr() to construct valid file: URL's on those volumes for you, because it won't. =item uf_uri($str) Works the same way as uf_uristr() but returns a C object. =back =head1 ENVIRONMENT If the hostname portion of a URI does not contain any dots, then certain qualified guesses are made. These guesses are governed by the following environment variables: =over 10 =item COUNTRY The two-letter country code (ISO 3166) for your location. If the domain name of your host ends with two letters, then it is taken to be the default country. See also L. =item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG If COUNTRY is not set, these standard environment variables are examined and country (not language) information possibly found in them is used as the default country. =item URL_GUESS_PATTERN Contains a space-separated list of URL patterns to try. The string "ACME" is for some reason used as a placeholder for the host name in the URL provided. Example: URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com" export URL_GUESS_PATTERN Specifying URL_GUESS_PATTERN disables any guessing rules based on country. An empty URL_GUESS_PATTERN disables any guessing that involves host name lookups. =back =head1 COPYRIGHT Copyright 1997-1998, Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr); our $VERSION = '5.28'; our ($MY_COUNTRY, $DEBUG); sub MY_COUNTRY() { for ($MY_COUNTRY) { return $_ if defined; # First try the environment. $_ = $ENV{COUNTRY}; return $_ if defined; # Try the country part of LC_ALL and LANG from environment my @srcs = ($ENV{LC_ALL}, $ENV{LANG}); # ...and HTTP_ACCEPT_LANGUAGE before those if present if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) { # TODO: q-value processing/ordering for $httplang (split(/\s*,\s*/, $httplang)) { if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) { unshift(@srcs, "${1}_${2}"); last; } } } for (@srcs) { next unless defined; return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/; } # Last bit of domain name. This may access the network. require Net::Domain; my $fqdn = Net::Domain::hostfqdn(); $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/; return $_ if defined; # Give up. Defined but false. return ($_ = 0); } } our %LOCAL_GUESSING = ( 'us' => [qw(www.ACME.gov www.ACME.mil)], 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)], 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)], 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)], # send corrections and new entries to ); # Backwards compatibility; uk != United Kingdom in ISO 3166 $LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb}; sub uf_uristr ($) { local($_) = @_; print STDERR "uf_uristr: resolving $_\n" if $DEBUG; return unless defined; s/^\s+//; s/\s+$//; if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) { $_ = "http://$_"; } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) { $_ = lc($1) . "://$_"; } elsif ($^O ne "MacOS" && (m,^/, || # absolute file name m,^\.\.?/, || # relative file name m,^[a-zA-Z]:[/\\],) # dosish file name ) { $_ = "file:$_"; } elsif ($^O eq "MacOS" && m/:/) { # potential MacOS file name unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) { require URI::file; my $a = URI::file->new($_)->as_string; $_ = ($a =~ m/^file:/) ? $a : "file:$a"; } } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) { $_ = "mailto:$_"; } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) { my $host = $1; my $scheme = "http"; if (/^:(\d+)\b/) { # Some more or less well known ports if ($1 =~ /^[56789]?443$/) { $scheme = "https"; } elsif ($1 eq "21") { $scheme = "ftp"; } } if ($host !~ /\./ && $host ne "localhost") { my @guess; if (exists $ENV{URL_GUESS_PATTERN}) { @guess = map { s/\bACME\b/$host/; $_ } split(' ', $ENV{URL_GUESS_PATTERN}); } else { if (MY_COUNTRY()) { my $special = $LOCAL_GUESSING{MY_COUNTRY()}; if ($special) { my @special = @$special; push(@guess, map { s/\bACME\b/$host/; $_ } @special); } else { push(@guess, "www.$host." . MY_COUNTRY()); } } push(@guess, map "www.$host.$_", "com", "org", "net", "edu", "int"); } my $guess; for $guess (@guess) { print STDERR "uf_uristr: gethostbyname('$guess.')..." if $DEBUG; if (gethostbyname("$guess.")) { print STDERR "yes\n" if $DEBUG; $host = $guess; last; } print STDERR "no\n" if $DEBUG; } } $_ = "$scheme://$host$_"; } else { # pure junk, just return it unchanged... } } print STDERR "uf_uristr: ==> $_\n" if $DEBUG; $_; } sub uf_uri ($) { require URI; URI->new(uf_uristr($_[0])); } # legacy *uf_urlstr = \*uf_uristr; sub uf_url ($) { require URI::URL; URI::URL->new(uf_uristr($_[0])); } 1; URI-5.28/lib/URI/news.pm0000644000175000017500000000265614600675475013301 0ustar olafolafpackage URI::news; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); use Carp (); sub default_port { 119 } # newsURL = scheme ":" [ news-server ] [ refbygroup | message ] # scheme = "news" | "snews" | "nntp" # news-server = "//" server "/" # refbygroup = group [ "/" messageno [ "-" messageno ] ] # message = local-part "@" domain sub _group { my $self = shift; my $old = $self->path; if (@_) { my($group,$from,$to) = @_; if ($group =~ /\@/) { $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it } $group =~ s,%,%25,g; $group =~ s,/,%2F,g; my $path = $group; if (defined $from) { $path .= "/$from"; $path .= "-$to" if defined $to; } $self->path($path); } $old =~ s,^/,,; if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) { my $extra = $1; return (uri_unescape($old), split(/-/, $extra)); } uri_unescape($old); } sub group { my $self = shift; if (@_) { Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/; } my @old = $self->_group(@_); return if $old[0] =~ /\@/; wantarray ? @old : $old[0]; } sub message { my $self = shift; if (@_) { Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/; } my $old = $self->_group(@_); return undef unless $old =~ /\@/; return $old; } 1; URI-5.28/lib/URI/https.pm0000644000175000017500000000022014600675475013450 0ustar olafolafpackage URI::https; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::http'; sub default_port { 443 } sub secure { 1 } 1; URI-5.28/lib/URI/_idna.pm0000644000175000017500000000403714600675475013372 0ustar olafolafpackage URI::_idna; # This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep) # based on Python-2.6.4/Lib/encodings/idna.py use strict; use warnings; use URI::_punycode qw(decode_punycode encode_punycode); use Carp qw(croak); our $VERSION = '5.28'; BEGIN { *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003 ? sub () { 1 } : sub () { 0 } ; } my $ASCII = qr/^[\x00-\x7F]*\z/; sub encode { my $idomain = shift; my @labels = split(/\./, $idomain, -1); my @last_empty; push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq ""; for (@labels) { $_ = ToASCII($_); } return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS; return join(".", @labels, @last_empty); } sub decode { my $domain = shift; return join(".", map ToUnicode($_), split(/\./, $domain, -1)) } sub nameprep { # XXX real implementation missing my $label = shift; $label = lc($label); return $label; } sub check_size { my $label = shift; croak "Label empty" if $label eq ""; croak "Label too long" if length($label) > 63; return $label; } sub ToASCII { my $label = shift; return check_size($label) if $label =~ $ASCII; # Step 2: nameprep $label = nameprep($label); # Step 3: UseSTD3ASCIIRules is false # Step 4: try ASCII again return check_size($label) if $label =~ $ASCII; # Step 5: Check ACE prefix if ($label =~ /^xn--/) { croak "Label starts with ACE prefix"; } # Step 6: Encode with PUNYCODE $label = encode_punycode($label); # Step 7: Prepend ACE prefix $label = "xn--$label"; # Step 8: Check size return check_size($label); } sub ToUnicode { my $label = shift; $label = nameprep($label) unless $label =~ $ASCII; return $label unless $label =~ /^xn--/; my $result = decode_punycode(substr($label, 4)); my $label2 = ToASCII($result); if (lc($label) ne $label2) { croak "IDNA does not round-trip: '\L$label\E' vs '$label2'"; } return $result; } 1; URI-5.28/lib/URI/ldapi.pm0000644000175000017500000000067014600675475013410 0ustar olafolafpackage URI::ldapi; use strict; use warnings; our $VERSION = '5.28'; use parent qw(URI::_ldap URI::_generic); use URI::Escape (); sub un_path { my $self = shift; my $old = URI::Escape::uri_unescape($self->authority); if (@_) { my $p = shift; $p =~ s/:/%3A/g; $p =~ s/\@/%40/g; $self->authority($p); } return $old; } sub _nonldap_canonical { my $self = shift; $self->URI::_generic::canonical(@_); } 1; URI-5.28/lib/URI/mailto.pm0000644000175000017500000000317114600675475013603 0ustar olafolafpackage URI::mailto; # RFC 2368 use strict; use warnings; our $VERSION = '5.28'; use parent qw(URI URI::_query); sub to { my $self = shift; my @old = $self->headers; if (@_) { my @new = @old; # get rid of any other to: fields for (my $i = 0; $i < @new; $i += 2) { if (lc($new[$i] || '') eq "to") { splice(@new, $i, 2); redo; } } my $to = shift; $to = "" unless defined $to; unshift(@new, "to" => $to); $self->headers(@new); } return unless defined wantarray; my @to; while (@old) { my $h = shift @old; my $v = shift @old; push(@to, $v) if lc($h) eq "to"; } join(",", @to); } sub headers { my $self = shift; # The trick is to just treat everything as the query string... my $opaque = "to=" . $self->opaque; $opaque =~ s/\?/&/; if (@_) { my @new = @_; # strip out any "to" fields my @to; for (my $i=0; $i < @new; $i += 2) { if (lc($new[$i] || '') eq "to") { push(@to, (splice(@new, $i, 2))[1]); # remove header redo; } } my $new = join(",",@to); $new =~ s/%/%25/g; $new =~ s/\?/%3F/g; $self->opaque($new); $self->query_form(@new) if @new; } return unless defined wantarray; # I am lazy today... URI->new("mailto:?$opaque")->query_form; } # https://datatracker.ietf.org/doc/html/rfc6068#section-5 requires # plus signs (+) not to be turned into spaces sub query_form { my $self = shift; my @fields = $self->SUPER::query_form(@_); for ( my $i = 0 ; $i < @fields ; $i += 2 ) { if ( $fields[0] eq 'to' ) { $fields[1] =~ s/ /+/g; last; } } return @fields; } 1; URI-5.28/lib/URI/ssh.pm0000644000175000017500000000025714600675475013115 0ustar olafolafpackage URI::ssh; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_login'; # ssh://[USER@]HOST[:PORT]/SRC sub default_port { 22 } sub secure { 1 } 1; URI-5.28/lib/URI/_foreign.pm0000644000175000017500000000015314600675475014103 0ustar olafolafpackage URI::_foreign; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.28'; 1; URI-5.28/lib/URI/Split.pm0000644000175000017500000000446114600675475013414 0ustar olafolafpackage URI::Split; use strict; use warnings; our $VERSION = '5.28'; use Exporter 5.57 'import'; our @EXPORT_OK = qw(uri_split uri_join); use URI::Escape (); sub uri_split { return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; } sub uri_join { my($scheme, $auth, $path, $query, $frag) = @_; my $uri = defined($scheme) ? "$scheme:" : ""; $path = "" unless defined $path; if (defined $auth) { $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; $uri .= "//$auth"; $path = "/$path" if length($path) && $path !~ m,^/,; } elsif ($path =~ m,^//,) { $uri .= "//"; # XXX force empty auth } unless (length $uri) { $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,; } $path =~ s,([?\#]), URI::Escape::escape_char($1),eg; $uri .= $path; if (defined $query) { $query =~ s,(\#), URI::Escape::escape_char($1),eg; $uri .= "?$query"; } $uri .= "#$frag" if defined $frag; $uri; } 1; __END__ =head1 NAME URI::Split - Parse and compose URI strings =head1 SYNOPSIS use URI::Split qw(uri_split uri_join); ($scheme, $auth, $path, $query, $frag) = uri_split($uri); $uri = uri_join($scheme, $auth, $path, $query, $frag); =head1 DESCRIPTION Provides functions to parse and compose URI strings. The following functions are provided: =over =item ($scheme, $auth, $path, $query, $frag) = uri_split($uri) Breaks up a URI string into its component parts. An C value is returned for those parts that are not present. The $path part is always present (but can be the empty string) and is thus never returned as C. No sensible value is returned if this function is called in a scalar context. =item $uri = uri_join($scheme, $auth, $path, $query, $frag) Puts together a URI string from its parts. Missing parts are signaled by passing C for the corresponding argument. Minimal escaping is applied to parts that contain reserved chars that would confuse a parser. For instance, any occurrence of '?' or '#' in $path is always escaped, as it would otherwise be parsed back as a query or fragment. =back =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright 2003, Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-5.28/lib/URI/rsync.pm0000644000175000017500000000031714600675475013453 0ustar olafolafpackage URI::rsync; # http://rsync.samba.org/ # rsync://[USER@]HOST[:PORT]/SRC use strict; use warnings; our $VERSION = '5.28'; use parent qw(URI::_server URI::_userpass); sub default_port { 873 } 1; URI-5.28/lib/URI/file.pm0000644000175000017500000002273114600675475013240 0ustar olafolafpackage URI::file; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.28'; use URI::Escape qw(uri_unescape); our $DEFAULT_AUTHORITY = ""; # Map from $^O values to implementation classes. The Unix # class is the default. our %OS_CLASS = ( os2 => "OS2", mac => "Mac", MacOS => "Mac", MSWin32 => "Win32", win32 => "Win32", msdos => "FAT", dos => "FAT", qnx => "QNX", ); sub os_class { my($OS) = shift || $^O; my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix"); no strict 'refs'; unless (%{"$class\::"}) { eval "require $class"; die $@ if $@; } $class; } sub host { uri_unescape(shift->authority(@_)) } sub new { my($class, $path, $os) = @_; os_class($os)->new($path); } sub new_abs { my $class = shift; my $file = $class->new(@_); return $file->abs($class->cwd) unless $$file =~ /^file:/; $file; } sub cwd { my $class = shift; require Cwd; my $cwd = Cwd::cwd(); $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS'; $cwd = $class->new($cwd); $cwd .= "/" unless substr($cwd, -1, 1) eq "/"; $cwd; } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $scheme = $other->scheme; my $auth = $other->authority; return $other if !defined($scheme) && !defined($auth); # relative if (!defined($auth) || $auth eq "" || lc($auth) eq "localhost" || (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY)) ) { # avoid cloning if $auth already match if ((defined($auth) || defined($DEFAULT_AUTHORITY)) && (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY) ) { $other = $other->clone if $self == $other; $other->authority($DEFAULT_AUTHORITY); } } $other; } sub file { my($self, $os) = @_; os_class($os)->file($self); } sub dir { my($self, $os) = @_; os_class($os)->dir($self); } 1; __END__ =head1 NAME URI::file - URI that maps to local file names =head1 SYNOPSIS use URI::file; $u1 = URI->new("file:/foo/bar"); $u2 = URI->new("foo/bar", "file"); $u3 = URI::file->new($path); $u4 = URI::file->new("c:\\windows\\", "win32"); $u1->file; $u1->file("mac"); =head1 DESCRIPTION The C class supports C objects belonging to the I URI scheme. This scheme allows us to map the conventional file names found on various computer systems to the URI name space, see L. If you simply want to construct I URI objects from URI strings, use the normal C constructor. If you want to construct I URI objects from the actual file names used by various systems, then use one of the following C constructors: =over 4 =item $u = URI::file->new( $filename, [$os] ) Maps a file name to the I URI name space, creates a URI object and returns it. The $filename is interpreted as belonging to the indicated operating system ($os), which defaults to the value of the $^O variable. The $filename can be either absolute or relative, and the corresponding type of URI object for $os is returned. =item $u = URI::file->new_abs( $filename, [$os] ) Same as URI::file->new, but makes sure that the URI returned represents an absolute file name. If the $filename argument is relative, then the name is resolved relative to the current directory, i.e. this constructor is really the same as: URI::file->new($filename)->abs(URI::file->cwd); =item $u = URI::file->cwd Returns a I URI that represents the current working directory. See L. =back The following methods are supported for I URI (in addition to the common and generic methods described in L): =over 4 =item $u->file( [$os] ) Returns a file name. It maps from the URI name space to the file name space of the indicated operating system. It might return C if the name can not be represented in the indicated file system. =item $u->dir( [$os] ) Some systems use a different form for names of directories than for plain files. Use this method if you know you want to use the name for a directory. =back The C module can be used to map generic file names to names suitable for the current system. As such, it can work as a nice replacement for the C module. For instance, the following code translates the UNIX-style file name F to a name suitable for the local system: $file = URI::file->new("Foo/Bar.pm", "unix")->file; die "Can't map filename Foo/Bar.pm for $^O" unless defined $file; open(FILE, $file) || die "Can't open '$file': $!"; # do something with FILE =head1 MAPPING NOTES Most computer systems today have hierarchically organized file systems. Mapping the names used in these systems to the generic URI syntax allows us to work with relative file URIs that behave as they should when resolved using the generic algorithm for URIs (specified in L). Mapping a file name to the generic URI syntax involves mapping the path separator character to "/" and encoding any reserved characters that appear in the path segments of the file name. If path segments consisting of the strings "." or ".." have a different meaning than what is specified for generic URIs, then these must be encoded as well. If the file system has device, volume or drive specifications as the root of the name space, then it makes sense to map them to the authority field of the generic URI syntax. This makes sure that relative URIs can not be resolved "above" them, i.e. generally how relative file names work in those systems. Another common use of the authority field is to encode the host on which this file name is valid. The host name "localhost" is special and generally has the same meaning as a missing or empty authority field. This use is in conflict with using it as a device specification, but can often be resolved for device specifications having characters not legal in plain host names. File name to URI mapping in normally not one-to-one. There are usually many URIs that map to any given file name. For instance, an authority of "localhost" maps the same as a URI with a missing or empty authority. Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator, but not in the same way as a generic URI. ":foo" was a relative name. "foo:bar" was an absolute name. Also, path segments could contain the "/" character as well as the literal "." or "..". So the mapping looks like this: Mac classic URI ---------- ------------------- :foo:bar <==> foo/bar : <==> ./ ::foo:bar <==> ../foo/bar ::: <==> ../../ foo:bar <==> file:/foo/bar foo:bar: <==> file:/foo/bar/ .. <==> %2E%2E <== / foo/ <== file:/foo%2F ./foo.txt <== file:/.%2Ffoo.txt Note that if you want a relative URL, you *must* begin the path with a :. Any path that begins with [^:] is treated as absolute. Example 2: The UNIX file system is easy to map, as it uses the same path separator as URIs, has a single root, and segments of "." and ".." have the same meaning. URIs that have the character "\0" or "/" as part of any path segment can not be turned into valid UNIX file names. UNIX URI ---------- ------------------ foo/bar <==> foo/bar /foo/bar <==> file:/foo/bar /foo/bar <== file://localhost/foo/bar file: ==> ./file: <== file:/fo%00/bar / <==> file:/ =cut RFC 1630 [...] There is clearly a danger of confusion that a link made to a local file should be followed by someone on a different system, with unexpected and possibly harmful results. Therefore, the convention is that even a "file" URL is provided with a host part. This allows a client on another system to know that it cannot access the file system, or perhaps to use some other local mechanism to access the file. The special value "localhost" is used in the host field to indicate that the filename should really be used on whatever host one is. This for example allows links to be made to files which are distributed on many machines, or to "your unix local password file" subject of course to consistency across the users of the data. A void host field is equivalent to "localhost". =head1 CONFIGURATION VARIABLES The following configuration variables influence how the class and its methods behave: =over =item %URI::file::OS_CLASS This hash maps OS identifiers to implementation classes. You might want to add or modify this if you want to plug in your own file handler class. Normally the keys should match the $^O values in use. If there is no mapping then the "Unix" implementation is used. =item $URI::file::DEFAULT_AUTHORITY This determines what "authority" string to include in absolute file URIs. It defaults to "". If you prefer verbose URIs you might set it to be "localhost". Setting this value to C forces behaviour compatible to URI v1.31 and earlier. In this mode host names in UNC paths and drive letters are mapped to the authority component on Windows, while we produce authority-less URIs on Unix. =back =head1 SEE ALSO L, L, L =head1 COPYRIGHT Copyright 1995-1998,2004 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-5.28/lib/URI/icaps.pm0000644000175000017500000000264214600675475013417 0ustar olafolafpackage URI::icaps; use strict; use warnings; use base qw(URI::icap); our $VERSION = '5.28'; sub secure { return 1 } 1; __END__ =head1 NAME URI::icaps - URI scheme for ICAPS Identifiers =head1 VERSION Version 5.20 =head1 SYNOPSIS use URI::icaps; my $uri = URI->new('icaps://icap-proxy.example.com/'); =head1 DESCRIPTION This module implements the C URI scheme defined in L, for the L. =head1 SUBROUTINES/METHODS This module inherits the behaviour of L and overrides the Lsecure> method. =head2 secure returns 1 as icaps is a secure protocol =head1 DIAGNOSTICS See L =head1 CONFIGURATION AND ENVIRONMENT See L =head1 DEPENDENCIES None =head1 INCOMPATIBILITIES None reported =head1 BUGS AND LIMITATIONS See L =head1 SEE ALSO L =head1 AUTHOR David Dick, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2016 David Dick. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See L for more information. URI-5.28/lib/URI/geo.pm0000644000175000017500000002500214600675475013065 0ustar olafolafpackage URI::geo; use warnings; use strict; use Carp; use URI::Split qw( uri_split uri_join ); use base qw( URI ); our $VERSION = '5.28'; sub _MINIMUM_LATITUDE { return -90 } sub _MAXIMUM_LATITUDE { return 90 } sub _MINIMUM_LONGITUDE { return -180 } sub _MAXIMUM_LONGITUDE { return 180 } sub _MAX_POINTY_PARAMETERS { return 3 } sub _can { my ($can_pt, @keys) = @_; for my $key (@keys) { return $key if $can_pt->can($key); } return; } sub _has { my ($has_pt, @keys) = @_; for my $key (@keys) { return $key if exists $has_pt->{$key}; } return; } # Try hard to extract location information from something. We handle lat, # lon, alt as scalars, arrays containing lat, lon, alt, hashes with # suitably named keys and objects with suitably named methods. sub _location_of_pointy_thing { my ($class, @parameters) = @_; my @lat = qw( lat latitude ); my @lon = qw( lon long longitude lng ); my @ele = qw( ele alt elevation altitude ); if (ref $parameters[0]) { my $pt = shift @parameters; if (@parameters) { croak q[Too many arguments]; } if (eval { $pt->can('can') }) { for my $m (qw( location latlong )) { return $pt->$m() if _can($pt, $m); } my $latk = _can($pt, @lat); my $lonk = _can($pt, @lon); my $elek = _can($pt, @ele); if (defined $latk && defined $lonk) { return $pt->$latk(), $pt->$lonk(), defined $elek ? $pt->$elek() : undef; } } elsif ('ARRAY' eq ref $pt) { return $class->_location_of_pointy_thing(@{$pt}); } elsif ('HASH' eq ref $pt) { my $latk = _has($pt, @lat); my $lonk = _has($pt, @lon); my $elek = _has($pt, @ele); if (defined $latk && defined $lonk) { return $pt->{$latk}, $pt->{$lonk}, defined $elek ? $pt->{$elek} : undef; } } croak q[Don't know how to convert point]; } else { croak q[Need lat, lon or lat, lon, alt] if @parameters < 2 || @parameters > _MAX_POINTY_PARAMETERS(); return my ($lat, $lon, $alt) = @parameters; } } sub _num { my ($class, $n) = @_; if (!defined $n) { return q[]; } (my $rep = sprintf '%f', $n) =~ s/[.]0*$//smx; return $rep; } sub new { my ($self, @parameters) = @_; my $class = ref $self || $self; my $uri = uri_join 'geo', undef, $class->_path(@parameters); return bless \$uri, $class; } sub _init { my ($class, $uri, $scheme) = @_; my $self = $class->SUPER::_init($uri, $scheme); # Normalise at poles. my $lat = $self->latitude; if ($lat == _MAXIMUM_LATITUDE() || $lat == _MINIMUM_LATITUDE()) { $self->longitude(0); } return $self; } sub location { my ($self, @parameters) = @_; if (@parameters) { my ($lat, $lon, $alt) = @parameters; return $self->latitude($lat)->longitude($lon)->altitude($alt); } return $self->latitude, $self->longitude, $self->altitude; } sub latitude { my ($self, @parameters) = @_; return $self->field('latitude', @parameters); } sub longitude { my ($self, @parameters) = @_; return $self->field('longitude', @parameters); } sub altitude { my ($self, @parameters) = @_; return $self->field('altitude', @parameters); } sub crs { my ($self, @parameters) = @_; return $self->field('crs', @parameters); } sub uncertainty { my ($self, @parameters) = @_; return $self->field('uncertainty', @parameters); } sub field { my ($self, $name, @remainder) = @_; my ($scheme, $auth, $v, $query, $frag) = $self->_parse; if (!exists $v->{$name}) { croak "No such field: $name"; } if (!@remainder) { return $v->{$name}; } $v->{$name} = shift @remainder; ${$self} = uri_join $scheme, $auth, $self->_format($v), $query, $frag; return $self; } { my $pnum = qr{\d+(?:[.]\d+)?}smx; my $num = qr{-?$pnum}smx; my $crsp = qr{(?:;crs=(\w+))}smx; my $uncp = qr{(?:;u=($pnum))}smx; my $parm = qr{(?:;\w+=[^;]*)+}smx; sub _parse { my $self = shift; my ($scheme, $auth, $path, $query, $frag) = uri_split ${$self}; $path =~ m{^ ($num), ($num) (?: , ($num) ) ? (?: $crsp ) ? (?: $uncp ) ? ( $parm ) ? $}smx or croak 'Badly formed geo uri'; # No named captures before 5.10.0 return $scheme, $auth, { latitude => $1, longitude => $2, altitude => $3, crs => $4, uncertainty => $5, parameters => (defined $6 ? substr $6, 1 : undef), }, $query, $frag; } } sub _format { my ($class, $v) = @_; return join q[;], ( join q[,], map { $class->_num($_) } @{$v}{'latitude', 'longitude'}, (defined $v->{altitude} ? ($v->{altitude}) : ()) ), (defined $v->{crs} ? ('crs=' . $class->_num($v->{crs})) : ()), ( defined $v->{uncertainty} ? ('u=' . $class->_num($v->{uncertainty})) : ()), (defined $v->{parameters} ? ($v->{parameters}) : ()); } sub _path { my ($class, @parameters) = @_; my ($lat, $lon, $alt) = $class->_location_of_pointy_thing(@parameters); croak 'Latitude out of range' if $lat < _MINIMUM_LATITUDE() || $lat > _MAXIMUM_LATITUDE(); croak 'Longitude out of range' if $lon < _MINIMUM_LONGITUDE() || $lon > _MAXIMUM_LONGITUDE(); if ($lat == _MINIMUM_LATITUDE() || $lat == _MAXIMUM_LATITUDE()) { $lat = 0; } return $class->_format( {latitude => $lat, longitude => $lon, altitude => $alt}); } 1; __END__ =head1 NAME URI::geo - URI scheme for geo Identifiers =head1 SYNOPSIS use URI; # Geo URI from textual uri my $guri = URI->new( 'geo:54.786989,-2.344214' ); # From coordinates my $guri = URI::geo->new( 54.786989, -2.344214 ); # Decode my ( $lat, $lon, $alt ) = $guri->location; my $latitude = $guri->latitude; # Update $guri->location( 55, -1 ); $guri->longitude( -43.23 ); =head1 DESCRIPTION From L: More and more protocols and data formats are being extended by methods to add geographic information. However, all of those options are tied to that specific protocol or data format. A dedicated Uniform Resource Identifier (URI) scheme for geographic locations would be independent from any protocol, usable by any software/data format that can handle generich URIs. Like a "mailto:" URI launches your favourite mail application today, a "geo:" URI could soon launch your favourite mapping service, or queue that location for a navigation device. =head1 SUBROUTINES/METHODS =head2 C<< new >> Create a new URI::geo. The arguments should be either =over =item * latitude, longitude and optionally altitude =item * a reference to an array containing lat, lon, alt =item * a reference to a hash with suitably named keys or =item * a reference to an object with suitably named accessors =back To maximize the likelihood that you can pass in some object that represents a geographical location and have URI::geo do the right thing we try a number of different accessor names. If the object has a C method (e.g. L) we'll use that. If there's a C method we call that. Otherwise we look for accessors called C, C, C, C, C, C, C, C or C and use them. Often if you have an object or hash reference that represents a point you can pass it directly to C; so for example this will work: use URI::geo; use Geo::Point; my $pt = Geo::Point->latlong( 48.208333, 16.372778 ); my $guri = URI::geo->new( $pt ); As will this: my $guri = URI::geo->new( { lat => 55, lon => -1 } ); and this: my $guri = URI::geo->new( 55, -1 ); Note that you can also create a new C by passing a Geo URI to C: use URI; my $guri = URI->new( 'geo:55,-1' ); =head2 C Get or set the location of this geo URI. my ( $lat, $lon, $alt ) = $guri->location; $guri->location( 55.3, -3.7, 120 ); When setting the location it is possible to pass any of the argument types that can be passed to C. =head2 C Get or set the latitude of this geo URI. =head2 C Get or set the longitude of this geo URI. =head2 C Get or set the L of this geo URI. To delete the altitude set it to C. =head2 C Get or set the L of this geo URI. To delete the CRS set it to C. =head2 C Get or set the L of this geo URI. To delete the uncertainty set it to C. =head2 C =head1 CONFIGURATION AND ENVIRONMENT URI::geo requires no configuration files or environment variables. =head1 DEPENDENCIES L =head1 DIAGNOSTICS =over =item C<< Too many arguments >> The L method can only accept three parameters; latitude, longitude and altitude. =item C<< Don't know how to convert point >> The L method doesn't know how to convert the supplied parameters into a URI::geo object. =item C<< Need lat, lon or lat, lon, alt >> The L method needs two (latitude and longitude) or three (latitude, longitude and altitude) parameters in a list. Any less or more than this is an error. =item C<< No such field: %s >> This field is not a known field for the L object. =item C<< Badly formed geo uri >> The L cannot be parsed as a URI =item C<< Badly formed geo uri >> The L cannot be parsed as a URI =item C<< Latitude out of range >> Latitude may only be from -90 to +90 =item C<< Longitude out of range >> Longitude may only be from -180 to +180 =back =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS To report a bug, or view the current list of bugs, please visit L =head1 AUTHOR Andy Armstrong C<< >> =head1 LICENSE AND COPYRIGHT Copyright (c) 2009, Andy Armstrong C<< >>. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. URI-5.28/lib/URI/mms.pm0000644000175000017500000000017514600675475013113 0ustar olafolafpackage URI::mms; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::http'; sub default_port { 1755 } 1; URI-5.28/lib/URI/tn3270.pm0000644000175000017500000000020014600675475013241 0ustar olafolafpackage URI::tn3270; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_login'; sub default_port { 23 } 1; URI-5.28/lib/URI/data.pm0000644000175000017500000000647614600675475013242 0ustar olafolafpackage URI::data; # RFC 2397 use strict; use warnings; use parent 'URI'; our $VERSION = '5.28'; use MIME::Base64 qw(decode_base64 encode_base64); use URI::Escape qw(uri_unescape); sub media_type { my $self = shift; my $opaque = $self->opaque; $opaque =~ /^([^,]*),?/ or die; my $old = $1; my $base64; $base64 = $1 if $old =~ s/(;base64)$//i; if (@_) { my $new = shift; $new = "" unless defined $new; $new =~ s/%/%25/g; $new =~ s/,/%2C/g; $base64 = "" unless defined $base64; $opaque =~ s/^[^,]*,?/$new$base64,/; $self->opaque($opaque); } return uri_unescape($old) if $old; # media_type can't really be "0" "text/plain;charset=US-ASCII"; # default type } sub data { my $self = shift; my($enc, $data) = split(",", $self->opaque, 2); unless (defined $data) { $data = ""; $enc = "" unless defined $enc; } my $base64 = ($enc =~ /;base64$/i); if (@_) { $enc =~ s/;base64$//i if $base64; my $new = shift; $new = "" unless defined $new; my $uric_count = _uric_count($new); my $urienc_len = $uric_count + (length($new) - $uric_count) * 3; my $base64_len = int((length($new)+2) / 3) * 4; $base64_len += 7; # because of ";base64" marker if ($base64_len < $urienc_len || $_[0]) { $enc .= ";base64"; $new = encode_base64($new, ""); } else { $new =~ s/%/%25/g; } $self->opaque("$enc,$new"); } return unless defined wantarray; $data = uri_unescape($data); return $base64 ? decode_base64($data) : $data; } # I could not find a better way to interpolate the tr/// chars from # a variable. my $ENC = $URI::uric; $ENC =~ s/%//; eval <new("data:"); $u->media_type("image/gif"); $u->data(scalar(`cat camel.gif`)); print "$u\n"; open(XV, "|xv -") and print XV $u->data; =head1 DESCRIPTION The C class supports C objects belonging to the I URI scheme. The I URI scheme is specified in RFC 2397. It allows inclusion of small data items as "immediate" data, as if it had been included externally. Examples: data:,Perl%20is%20good data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs= C objects belonging to the data scheme support the common methods (described in L) and the following two scheme-specific methods: =over 4 =item $uri->media_type( [$new_media_type] ) Can be used to get or set the media type specified in the URI. If no media type is specified, then the default C<"text/plain;charset=US-ASCII"> is returned. =item $uri->data( [$new_data] ) Can be used to get or set the data contained in the URI. The data is passed unescaped (in binary form). The decision about whether to base64 encode the data in the URI is taken automatically, based on the encoding that produces the shorter URI string. =back =head1 SEE ALSO L =head1 COPYRIGHT Copyright 1995-1998 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-5.28/lib/URI/WithBase.pm0000644000175000017500000000742614600675475014033 0ustar olafolafpackage URI::WithBase; use strict; use warnings; use URI (); use Scalar::Util qw(blessed); our $VERSION = '5.28'; use overload '""' => "as_string", fallback => 1; sub as_string; # help overload find it sub new { my($class, $uri, $base) = @_; my $ibase = $base; if ($base && blessed($base) && $base->isa(__PACKAGE__)) { $base = $base->abs; $ibase = $base->[0]; } bless [URI->new($uri, $ibase), $base], $class; } sub new_abs { my $class = shift; my $self = $class->new(@_); $self->abs; } sub _init { my $class = shift; my($str, $scheme) = @_; bless [URI->new($str, $scheme), undef], $class; } sub eq { my($self, $other) = @_; $other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__); $self->[0]->eq($other); } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); return if $method eq "DESTROY"; $self->[0]->$method(@_); } sub can { # override UNIVERSAL::can my $self = shift; $self->SUPER::can(@_) || ( ref($self) ? $self->[0]->can(@_) : undef ) } sub base { my $self = shift; my $base = $self->[1]; if (@_) { # set my $new_base = shift; # ensure absoluteness $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__); $self->[1] = $new_base; } return unless defined wantarray; # The base attribute supports 'lazy' conversion from URL strings # to URL objects. Strings may be stored but when a string is # fetched it will automatically be converted to a URL object. # The main benefit is to make it much cheaper to say: # URI::WithBase->new($random_url_string, 'http:') if (defined($base) && !ref($base)) { $base = ref($self)->new($base); $self->[1] = $base unless @_; } $base; } sub clone { my $self = shift; my $base = $self->[1]; $base = $base->clone if ref($base); bless [$self->[0]->clone, $base], ref($self); } sub abs { my $self = shift; my $base = shift || $self->base || return $self->clone; $base = $base->as_string if ref($base); bless [$self->[0]->abs($base, @_), $base], ref($self); } sub rel { my $self = shift; my $base = shift || $self->base || return $self->clone; $base = $base->as_string if ref($base); bless [$self->[0]->rel($base, @_), $base], ref($self); } 1; __END__ =head1 NAME URI::WithBase - URIs which remember their base =head1 SYNOPSIS $u1 = URI::WithBase->new($str, $base); $u2 = $u1->abs; $base = $u1->base; $u1->base( $new_base ) =head1 DESCRIPTION This module provides the C class. Objects of this class are like C objects, but can keep their base too. The base represents the context where this URI was found and can be used to absolutize or relativize the URI. All the methods described in L are supported for C objects. The methods provided in addition to or modified from those of C are: =over 4 =item $uri = URI::WithBase->new($str, [$base]) The constructor takes an optional base URI as the second argument. If provided, this argument initializes the base attribute. =item $uri->base( [$new_base] ) Can be used to get or set the value of the base attribute. The return value, which is the old value, is a URI object or C. =item $uri->abs( [$base_uri] ) The $base_uri argument is now made optional as the object carries its base with it. A new object is returned even if $uri is already absolute (while plain URI objects simply return themselves in that case). =item $uri->rel( [$base_uri] ) The $base_uri argument is now made optional as the object carries its base with it. A new object is always returned. =back =head1 SEE ALSO L =head1 COPYRIGHT Copyright 1998-2002 Gisle Aas. =cut URI-5.28/lib/URI/sftp.pm0000644000175000017500000000014214600675475013265 0ustar olafolafpackage URI::sftp; use strict; use warnings; use parent 'URI::ssh'; our $VERSION = '5.28'; 1; URI-5.28/lib/URI/sips.pm0000644000175000017500000000021714600675475013272 0ustar olafolafpackage URI::sips; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::sip'; sub default_port { 5061 } sub secure { 1 } 1; URI-5.28/lib/URI/_userpass.pm0000644000175000017500000000201714600675475014320 0ustar olafolafpackage URI::_userpass; use strict; use warnings; use URI::Escape qw(uri_unescape); our $VERSION = '5.28'; sub user { my $self = shift; my $info = $self->userinfo; if (@_) { my $new = shift; my $pass = defined($info) ? $info : ""; $pass =~ s/^[^:]*//; if (!defined($new) && !length($pass)) { $self->userinfo(undef); } else { $new = "" unless defined($new); $new =~ s/%/%25/g; $new =~ s/:/%3A/g; $self->userinfo("$new$pass"); } } return undef unless defined $info; $info =~ s/:.*//; uri_unescape($info); } sub password { my $self = shift; my $info = $self->userinfo; if (@_) { my $new = shift; my $user = defined($info) ? $info : ""; $user =~ s/:.*//; if (!defined($new)) { $self->userinfo(length $user ? $user : undef); } else { $new = "" unless defined($new); $new =~ s/%/%25/g; $self->userinfo("$user:$new"); } } return undef unless defined $info; return undef unless $info =~ s/^[^:]*://; uri_unescape($info); } 1; URI-5.28/lib/URI/nntp.pm0000644000175000017500000000017714600675475013300 0ustar olafolafpackage URI::nntp; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::news'; 1; URI-5.28/lib/URI/pop.pm0000644000175000017500000000226714600675475013121 0ustar olafolafpackage URI::pop; # RFC 2384 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); sub default_port { 110 } #pop://;auth=@: sub user { my $self = shift; my $old = $self->userinfo; if (@_) { my $new_info = $old; $new_info = "" unless defined $new_info; $new_info =~ s/^[^;]*//; my $new = shift; if (!defined($new) && !length($new_info)) { $self->userinfo(undef); } else { $new = "" unless defined $new; $new =~ s/%/%25/g; $new =~ s/;/%3B/g; $self->userinfo("$new$new_info"); } } return undef unless defined $old; $old =~ s/;.*//; return uri_unescape($old); } sub auth { my $self = shift; my $old = $self->userinfo; if (@_) { my $new = $old; $new = "" unless defined $new; $new =~ s/(^[^;]*)//; my $user = $1; $new =~ s/;auth=[^;]*//i; my $auth = shift; if (defined $auth) { $auth =~ s/%/%25/g; $auth =~ s/;/%3B/g; $new = ";AUTH=$auth$new"; } $self->userinfo("$user$new"); } return undef unless defined $old; $old =~ s/^[^;]*//; return uri_unescape($1) if $old =~ /;auth=(.*)/i; return; } 1; URI-5.28/lib/URI/icap.pm0000644000175000017500000000272714600675475013240 0ustar olafolafpackage URI::icap; use strict; use warnings; use base qw(URI::http); our $VERSION = '5.28'; sub default_port { return 1344 } 1; __END__ =head1 NAME URI::icap - URI scheme for ICAP Identifiers =head1 VERSION Version 5.20 =head1 SYNOPSIS use URI::icap; my $uri = URI->new('icap://icap-proxy.example.com/'); =head1 DESCRIPTION This module implements the C URI scheme defined in L, for the L. =head1 SUBROUTINES/METHODS This module inherits the behaviour of L and overrides the Ldefault_port> method. =head2 default_port The default port for icap servers is 1344 =head1 DIAGNOSTICS See L =head1 CONFIGURATION AND ENVIRONMENT See L and L =head1 DEPENDENCIES None =head1 INCOMPATIBILITIES None reported =head1 BUGS AND LIMITATIONS See L =head1 SEE ALSO L =head1 AUTHOR David Dick, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2016 David Dick. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See L for more information. URI-5.28/lib/URI/telnet.pm0000644000175000017500000000020014600675475013577 0ustar olafolafpackage URI::telnet; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_login'; sub default_port { 23 } 1; URI-5.28/lib/URI/_ldap.pm0000644000175000017500000000626114600675475013400 0ustar olafolaf# Copyright (c) 1998 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package URI::_ldap; use strict; use warnings; our $VERSION = '5.28'; use URI::Escape qw(uri_unescape); sub _ldap_elem { my $self = shift; my $elem = shift; my $query = $self->query; my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4); my $old = $bits[$elem]; if (@_) { my $new = shift; $new =~ s/\?/%3F/g; $bits[$elem] = $new; $query = join("?",@bits); $query =~ s/\?+$//; $query = undef unless length($query); $self->query($query); } $old; } sub dn { my $old = shift->path(@_); $old =~ s:^/::; uri_unescape($old); } sub attributes { my $self = shift; my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ()); return $old unless wantarray; map { uri_unescape($_) } split(/,/,$old); } sub _scope { my $self = shift; my $old = _ldap_elem($self,1, @_); return undef unless defined wantarray && defined $old; uri_unescape($old); } sub scope { my $old = &_scope; $old = "base" unless length $old; $old; } sub _filter { my $self = shift; my $old = _ldap_elem($self,2, @_); return undef unless defined wantarray && defined $old; uri_unescape($old); # || "(objectClass=*)"; } sub filter { my $old = &_filter; $old = "(objectClass=*)" unless length $old; $old; } sub extensions { my $self = shift; my @ext; while (@_) { my $key = shift; my $value = shift; push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value)); } @ext = join(",", @ext) if @ext; my $old = _ldap_elem($self,3, @ext); return $old unless wantarray; map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old); } sub canonical { my $self = shift; my $other = $self->_nonldap_canonical; # The stuff below is not as efficient as one might hope... $other = $other->clone if $other == $self; $other->dn(_normalize_dn($other->dn)); # Should really know about mixed case "postalAddress", etc... $other->attributes(map lc, $other->attributes); # Lowercase scope, remove default my $old_scope = $other->scope; my $new_scope = lc($old_scope); $new_scope = "" if $new_scope eq "base"; $other->scope($new_scope) if $new_scope ne $old_scope; # Remove filter if default my $old_filter = $other->filter; $other->filter("") if lc($old_filter) eq "(objectclass=*)" || lc($old_filter) eq "objectclass=*"; # Lowercase extensions types and deal with known extension values my @ext = $other->extensions; for (my $i = 0; $i < @ext; $i += 2) { my $etype = $ext[$i] = lc($ext[$i]); if ($etype =~ /^!?bindname$/) { $ext[$i+1] = _normalize_dn($ext[$i+1]); } } $other->extensions(@ext) if @ext; $other; } sub _normalize_dn # RFC 2253 { my $dn = shift; return $dn; # The code below will fail if the "+" or "," is embedding in a quoted # string or simply escaped... my @dn = split(/([+,])/, $dn); for (@dn) { s/^([a-zA-Z]+=)/lc($1)/e; } join("", @dn); } 1; URI-5.28/lib/URI/_punycode.pm0000644000175000017500000001300014600675475014273 0ustar olafolafpackage URI::_punycode; use strict; use warnings; our $VERSION = '5.28'; use Exporter 'import'; our @EXPORT = qw(encode_punycode decode_punycode); use integer; our $DEBUG = 0; use constant BASE => 36; use constant TMIN => 1; use constant TMAX => 26; use constant SKEW => 38; use constant DAMP => 700; use constant INITIAL_BIAS => 72; use constant INITIAL_N => 128; my $Delimiter = chr 0x2D; my $BasicRE = qr/[\x00-\x7f]/; sub _croak { require Carp; Carp::croak(@_); } sub _digit_value { my $code = shift; return ord($code) - ord("A") if $code =~ /[A-Z]/; return ord($code) - ord("a") if $code =~ /[a-z]/; return ord($code) - ord("0") + 26 if $code =~ /[0-9]/; return; } sub _code_point { my $digit = shift; return $digit + ord('a') if 0 <= $digit && $digit <= 25; return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36; die 'NOT COME HERE'; } sub _adapt { my($delta, $numpoints, $firsttime) = @_; $delta = $firsttime ? $delta / DAMP : $delta / 2; $delta += $delta / $numpoints; my $k = 0; while ($delta > ((BASE - TMIN) * TMAX) / 2) { $delta /= BASE - TMIN; $k += BASE; } return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); } sub decode_punycode { my $code = shift; my $n = INITIAL_N; my $i = 0; my $bias = INITIAL_BIAS; my @output; if ($code =~ s/(.*)$Delimiter//o) { push @output, map ord, split //, $1; return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o; } while ($code) { my $oldi = $i; my $w = 1; LOOP: for (my $k = BASE; 1; $k += BASE) { my $cp = substr($code, 0, 1, ''); my $digit = _digit_value($cp); defined $digit or return _croak("invalid punycode input"); $i += $digit * $w; my $t = ($k <= $bias) ? TMIN : ($k >= $bias + TMAX) ? TMAX : $k - $bias; last LOOP if $digit < $t; $w *= (BASE - $t); } $bias = _adapt($i - $oldi, @output + 1, $oldi == 0); warn "bias becomes $bias" if $DEBUG; $n += $i / (@output + 1); $i = $i % (@output + 1); splice(@output, $i, 0, $n); warn join " ", map sprintf('%04x', $_), @output if $DEBUG; $i++; } return join '', map chr, @output; } sub encode_punycode { my $input = shift; my @input = split //, $input; my $n = INITIAL_N; my $delta = 0; my $bias = INITIAL_BIAS; my @output; my @basic = grep /$BasicRE/, @input; my $h = my $b = @basic; push @output, @basic; push @output, $Delimiter if $b && $h < @input; warn "basic codepoints: (@output)" if $DEBUG; while ($h < @input) { my $m = _min(grep { $_ >= $n } map ord, @input); warn sprintf "next code point to insert is %04x", $m if $DEBUG; $delta += ($m - $n) * ($h + 1); $n = $m; for my $i (@input) { my $c = ord($i); $delta++ if $c < $n; if ($c == $n) { my $q = $delta; LOOP: for (my $k = BASE; 1; $k += BASE) { my $t = ($k <= $bias) ? TMIN : ($k >= $bias + TMAX) ? TMAX : $k - $bias; last LOOP if $q < $t; my $cp = _code_point($t + (($q - $t) % (BASE - $t))); push @output, chr($cp); $q = ($q - $t) / (BASE - $t); } push @output, chr(_code_point($q)); $bias = _adapt($delta, $h + 1, $h == $b); warn "bias becomes $bias" if $DEBUG; $delta = 0; $h++; } } $delta++; $n++; } return join '', @output; } sub _min { my $min = shift; for (@_) { $min = $_ if $_ <= $min } return $min; } 1; __END__ =encoding utf8 =head1 NAME URI::_punycode - encodes Unicode string in Punycode =head1 SYNOPSIS use strict; use warnings; use utf8; use URI::_punycode qw(encode_punycode decode_punycode); # encode a unicode string my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g $punycode = encode_punycode('bücher'); # bcher-kva $punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye # decode a punycode string back into a unicode string my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net $unicode = decode_punycode('bcher-kva'); # bücher $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文 =head1 DESCRIPTION L is a module to encode / decode Unicode strings into L, an efficient encoding of Unicode for use with L. =head1 FUNCTIONS All functions throw exceptions on failure. You can C them with L or L. The following functions are exported by default. =head2 encode_punycode my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g $punycode = encode_punycode('bücher'); # bcher-kva $punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye Takes a Unicode string (UTF8-flagged variable) and returns a Punycode encoding for it. =head2 decode_punycode my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net $unicode = decode_punycode('bcher-kva'); # bücher $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文 Takes a Punycode encoding and returns original Unicode string. =head1 AUTHOR Tatsuhiko Miyagawa > is the author of L which was the basis for this module. =head1 SEE ALSO L, L, L =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-5.28/lib/URI/gopher.pm0000644000175000017500000000457414600675475013612 0ustar olafolafpackage URI::gopher; # , Dec 4, 1996 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_server'; use URI::Escape qw(uri_unescape); # A Gopher URL follows the common internet scheme syntax as defined in # section 4.3 of [RFC-URL-SYNTAX]: # # gopher://[:]/ # # where # # := | # %09 | # %09%09 # # := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' # '8' | '9' | '+' | 'I' | 'g' | 'T' # # := *pchar Refer to RFC 1808 [4] # := *pchar # := *uchar Refer to RFC 1738 [3] # # If the optional port is omitted, the port defaults to 70. sub default_port { 70 } sub _gopher_type { my $self = shift; my $path = $self->path_query; $path =~ s,^/,,; my $gtype = $1 if $path =~ s/^(.)//s; if (@_) { my $new_type = shift; if (defined($new_type)) { Carp::croak("Bad gopher type '$new_type'") unless length($new_type) == 1; substr($path, 0, 0) = $new_type; $self->path_query($path); } else { Carp::croak("Can't delete gopher type when selector is present") if length($path); $self->path_query(undef); } } return $gtype; } sub gopher_type { my $self = shift; my $gtype = $self->_gopher_type(@_); $gtype = "1" unless defined $gtype; $gtype; } sub gtype { goto &gopher_type } # URI::URL compatibility sub selector { shift->_gfield(0, @_) } sub search { shift->_gfield(1, @_) } sub string { shift->_gfield(2, @_) } sub _gfield { my $self = shift; my $fno = shift; my $path = $self->path_query; # not according to spec., but many popular browsers accept # gopher URLs with a '?' before the search string. $path =~ s/\?/\t/; $path = uri_unescape($path); $path =~ s,^/,,; my $gtype = $1 if $path =~ s,^(.),,s; my @path = split(/\t/, $path, 3); if (@_) { # modify my $new = shift; $path[$fno] = $new; pop(@path) while @path && !defined($path[-1]); for (@path) { $_="" unless defined } $path = $gtype; $path = "1" unless defined $path; $path .= join("\t", @path); $self->path_query($path); } $path[$fno]; } 1; URI-5.28/lib/URI/rtsp.pm0000644000175000017500000000017514600675475013307 0ustar olafolafpackage URI::rtsp; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::http'; sub default_port { 554 } 1; URI-5.28/lib/URI/_segment.pm0000644000175000017500000000064014600675475014115 0ustar olafolafpackage URI::_segment; # Represents a generic path_segment so that it can be treated as # a string too. use strict; use warnings; use URI::Escape qw(uri_unescape); use overload '""' => sub { $_[0]->[0] }, fallback => 1; our $VERSION = '5.28'; sub new { my $class = shift; my @segment = split(';', shift, -1); $segment[0] = uri_unescape($segment[0]); bless \@segment, $class; } 1; URI-5.28/lib/URI/_login.pm0000644000175000017500000000034714600675475013567 0ustar olafolafpackage URI::_login; use strict; use warnings; use parent qw(URI::_server URI::_userpass); our $VERSION = '5.28'; # Generic terminal logins. This is used as a base class for 'telnet', # 'tn3270', and 'rlogin' URL schemes. 1; URI-5.28/lib/URI/rtspu.pm0000644000175000017500000000017614600675475013475 0ustar olafolafpackage URI::rtspu; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::rtsp'; sub default_port { 554 } 1; URI-5.28/lib/URI/QueryParam.pm0000644000175000017500000000121714600675475014403 0ustar olafolafpackage URI::QueryParam; use strict; use warnings; our $VERSION = '5.28'; 1; __END__ =head1 NAME URI::QueryParam - Additional query methods for URIs =head1 SYNOPSIS use URI; =head1 DESCRIPTION C used to provide the L<< query_form_hash|URI/$hashref = $u->query_form_hash >>, L<< query_param|URI/@keys = $u->query_param >> L<< query_param_append|URI/$u->query_param_append($key, $value,...) >>, and L<< query_param_delete|URI/ @values = $u->query_param_delete($key) >> methods on L objects. These methods have been merged into L itself, so this module is now a no-op. =head1 COPYRIGHT Copyright 2002 Gisle Aas. =cut URI-5.28/lib/URI/http.pm0000644000175000017500000000065114600675475013275 0ustar olafolafpackage URI::http; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::_server'; sub default_port { 80 } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; my $slash_path = defined($other->authority) && !length($other->path) && !defined($other->query); if ($slash_path) { $other = $other->clone if $other == $self; $other->path("/"); } $other; } 1; URI-5.28/lib/URI/file/0000775000175000017500000000000014600675475012677 5ustar olafolafURI-5.28/lib/URI/file/Base.pm0000644000175000017500000000271514600675475014112 0ustar olafolafpackage URI::file::Base; use strict; use warnings; use URI::Escape (); our $VERSION = '5.28'; sub new { my $class = shift; my $path = shift; $path = "" unless defined $path; my($auth, $escaped_auth, $escaped_path); ($auth, $escaped_auth) = $class->_file_extract_authority($path); ($path, $escaped_path) = $class->_file_extract_path($path); if (defined $auth) { $auth =~ s,%,%25,g unless $escaped_auth; $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg; $auth = "//$auth"; if (defined $path) { $path = "/$path" unless substr($path, 0, 1) eq "/"; } else { $path = ""; } } else { return undef unless defined $path; $auth = ""; } $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path; $path =~ s/\#/%23/g; my $uri = $auth . $path; $uri = "file:$uri" if substr($uri, 0, 1) eq "/"; URI->new($uri, "file"); } sub _file_extract_authority { my($class, $path) = @_; return undef unless $class->_file_is_absolute($path); return $URI::file::DEFAULT_AUTHORITY; } sub _file_extract_path { return undef; } sub _file_is_absolute { return 0; } sub _file_is_localhost { shift; # class my $host = lc(shift); return 1 if $host eq "localhost"; eval { require Net::Domain; lc(Net::Domain::hostfqdn() || '') eq $host || lc(Net::Domain::hostname() || '') eq $host; }; } sub file { undef; } sub dir { my $self = shift; $self->file(@_); } 1; URI-5.28/lib/URI/file/OS2.pm0000644000175000017500000000106114600675475013634 0ustar olafolafpackage URI::file::OS2; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.28'; # The Win32 version translates k:/foo to file://k:/foo (?!) # We add an empty host sub _file_extract_authority { my $class = shift; return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives return ""; } return; } sub file { my $p = &URI::file::Win32::file; return unless defined $p; $p =~ s,\\,/,g; $p; } 1; URI-5.28/lib/URI/file/FAT.pm0000644000175000017500000000076114600675475013651 0ustar olafolafpackage URI::file::FAT; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.28'; sub fix_path { shift; # class for (@_) { # turn it into 8.3 names my @p = map uc, split(/\./, $_, -1); return if @p > 2; # more than 1 dot is not allowed @p = ("") unless @p; # split bug? (returns nothing when splitting "") $_ = substr($p[0], 0, 8); if (@p > 1) { my $ext = substr($p[1], 0, 3); $_ .= ".$ext" if length $ext; } } 1; # ok } 1; URI-5.28/lib/URI/file/QNX.pm0000644000175000017500000000052114600675475013677 0ustar olafolafpackage URI::file::QNX; use strict; use warnings; use parent 'URI::file::Unix'; our $VERSION = '5.28'; sub _file_extract_path { my($class, $path) = @_; # tidy path $path =~ s,(.)//+,$1/,g; # ^// is correct $path =~ s,(/\.)+/,/,g; $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" $path; } 1; URI-5.28/lib/URI/file/Mac.pm0000644000175000017500000000466514600675475013746 0ustar olafolafpackage URI::file::Mac; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.28'; sub _file_extract_path { my $class = shift; my $path = shift; my @pre; if ($path =~ s/^(:+)//) { if (length($1) == 1) { @pre = (".") unless length($path); } else { @pre = ("..") x (length($1) - 1); } } else { #absolute $pre[0] = ""; } my $isdir = ($path =~ s/:$//); $path =~ s,([%/;]), URI::Escape::escape_char($1),eg; my @path = split(/:/, $path, -1); for (@path) { if ($_ eq "." || $_ eq "..") { $_ = "%2E" x length($_); } $_ = ".." unless length($_); } push (@path,"") if $isdir; (join("/", @pre, @path), 1); } sub file { my $class = shift; my $uri = shift; my @path; my $auth = $uri->authority; if (defined $auth) { if (lc($auth) ne "localhost" && $auth ne "") { my $u_auth = uri_unescape($auth); if (!$class->_file_is_localhost($u_auth)) { # some other host (use it as volume name) @path = ("", $auth); # XXX or just return to make it illegal; } } } my @ps = split("/", $uri->path, -1); shift @ps if @path; push(@path, @ps); my $pre = ""; if (!@path) { return; # empty path; XXX return ":" instead? } elsif ($path[0] eq "") { # absolute shift(@path); if (@path == 1) { return if $path[0] eq ""; # not root directory push(@path, ""); # volume only, effectively append ":" } @ps = @path; @path = (); my $part; for (@ps) { #fix up "." and "..", including interior, in relatives next if $_ eq "."; $part = $_ eq ".." ? "" : $_; push(@path,$part); } if ($ps[-1] eq "..") { #if this happens, we need another : push(@path,""); } } else { $pre = ":"; @ps = @path; @path = (); my $part; for (@ps) { #fix up "." and "..", including interior, in relatives next if $_ eq "."; $part = $_ eq ".." ? "" : $_; push(@path,$part); } if ($ps[-1] eq "..") { #if this happens, we need another : push(@path,""); } } return unless $pre || @path; for (@path) { s/;.*//; # get rid of parameters #return unless length; # XXX $_ = uri_unescape($_); return if /\0/; return if /:/; # Should we? } $pre . join(":", @path); } sub dir { my $class = shift; my $path = $class->file(@_); return unless defined $path; $path .= ":" unless $path =~ /:$/; $path; } 1; URI-5.28/lib/URI/file/Unix.pm0000644000175000017500000000177614600675475014171 0ustar olafolafpackage URI::file::Unix; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.28'; sub _file_extract_path { my($class, $path) = @_; # tidy path $path =~ s,//+,/,g; $path =~ s,(/\.)+/,/,g; $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" return $path; } sub _file_is_absolute { my($class, $path) = @_; return $path =~ m,^/,; } sub file { my $class = shift; my $uri = shift; my @path; my $auth = $uri->authority; if (defined($auth)) { if (lc($auth) ne "localhost" && $auth ne "") { $auth = uri_unescape($auth); unless ($class->_file_is_localhost($auth)) { push(@path, "", "", $auth); } } } my @ps = $uri->path_segments; shift @ps if @path; push(@path, @ps); for (@path) { # Unix file/directory names are not allowed to contain '\0' or '/' return undef if /\0/; return undef if /\//; # should we really? } return join("/", @path); } 1; URI-5.28/lib/URI/file/Win32.pm0000644000175000017500000000333514600675475014141 0ustar olafolafpackage URI::file::Win32; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.28'; sub _file_extract_authority { my $class = shift; return $class->SUPER::_file_extract_authority($_[0]) if defined $URI::file::DEFAULT_AUTHORITY; return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? if ($_[0] =~ s,^([a-zA-Z]:),,) { my $auth = $1; $auth .= "relative" if $_[0] !~ m,^[\\/],; return $auth; } return undef; } sub _file_extract_path { my($class, $path) = @_; $path =~ s,\\,/,g; #$path =~ s,//+,/,g; $path =~ s,(/\.)+/,/,g; if (defined $URI::file::DEFAULT_AUTHORITY) { $path =~ s,^([a-zA-Z]:),/$1,; } return $path; } sub _file_is_absolute { my($class, $path) = @_; return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],; } sub file { my $class = shift; my $uri = shift; my $auth = $uri->authority; my $rel; # is filename relative to drive specified in authority if (defined $auth) { $auth = uri_unescape($auth); if ($auth =~ /^([a-zA-Z])[:|](relative)?/) { $auth = uc($1) . ":"; $rel++ if $2; } elsif (lc($auth) eq "localhost") { $auth = ""; } elsif (length $auth) { $auth = "\\\\" . $auth; # UNC } } else { $auth = ""; } my @path = $uri->path_segments; for (@path) { return undef if /\0/; return undef if /\//; #return undef if /\\/; # URLs with "\" is not uncommon } return undef unless $class->fix_path(@path); my $path = join("\\", @path); $path =~ s/^\\// if $rel; $path = $auth . $path; $path =~ s,^\\([a-zA-Z])[:|],\u$1:,; return $path; } sub fix_path { 1; } 1; URI-5.28/lib/URI/sip.pm0000644000175000017500000000320614600675475013110 0ustar olafolaf# # Written by Ryan Kereliuk . This file may be # distributed under the same terms as Perl itself. # # The RFC 3261 sip URI is :;?. # package URI::sip; use strict; use warnings; use parent qw(URI::_server URI::_userpass); use URI::Escape (); our $VERSION = '5.28'; sub default_port { 5060 } sub authority { my $self = shift; $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die; my $start = $1; my $authoritystr = $2; my $rest = $3; if (@_) { $authoritystr = shift; $authoritystr =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego; $$self = $start . $authoritystr . $rest; } return $authoritystr; } sub params_form { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; my $start = $1 . $2; my $paramstr = $3; my $rest = $4; if (@_) { my @paramarr; for (my $i = 0; $i < @_; $i += 2) { push(@paramarr, "$_[$i]=$_[$i+1]"); } $paramstr = join(";", @paramarr); $$self = $start . ";" . $paramstr . $rest; } $paramstr =~ s/^;//o; return split(/[;=]/, $paramstr); } sub params { my $self = shift; $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; my $start = $1 . $2; my $paramstr = $3; my $rest = $4; if (@_) { $paramstr = shift; $$self = $start . ";" . $paramstr . $rest; } $paramstr =~ s/^;//o; return $paramstr; } # Inherited methods that make no sense for a SIP URI. sub path {} sub path_query {} sub path_segments {} sub abs { shift } sub rel { shift } sub query_keywords {} 1; URI-5.28/lib/URI/nntps.pm0000644000175000017500000000022014600675475013450 0ustar olafolafpackage URI::nntps; use strict; use warnings; our $VERSION = '5.28'; use parent 'URI::nntp'; sub default_port { 563 } sub secure { 1 } 1; URI-5.28/lib/URI/urn.pm0000644000175000017500000000403514600675475013122 0ustar olafolafpackage URI::urn; # RFC 2141 use strict; use warnings; our $VERSION = '5.28'; use parent 'URI'; use Carp qw(carp); my %implementor; sub _init { my $class = shift; my $self = $class->SUPER::_init(@_); my $nid = $self->nid; my $impclass = $implementor{$nid}; return $impclass->_urn_init($self, $nid) if $impclass; $impclass = "URI::urn"; if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { my $id = $nid; # make it a legal perl identifier $id =~ s/-/_/g; $id = "_$id" if $id =~ /^\d/; $impclass = "URI::urn::$id"; no strict 'refs'; unless (@{"${impclass}::ISA"}) { # Try to load it my $_old_error = $@; eval "require $impclass"; die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; $@ = $_old_error; $impclass = "URI::urn" unless @{"${impclass}::ISA"}; } } else { carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; } $implementor{$nid} = $impclass; return $impclass->_urn_init($self, $nid); } sub _urn_init { my($class, $self, $nid) = @_; bless $self, $class; } sub _nid { my $self = shift; my $opaque = $self->opaque; if (@_) { my $v = $opaque; my $new = shift; $v =~ s/[^:]*/$new/; $self->opaque($v); # XXX possible rebless } $opaque =~ s/:.*//s; return $opaque; } sub nid { # namespace identifier my $self = shift; my $nid = $self->_nid(@_); $nid = lc($nid) if defined($nid); return $nid; } sub nss { # namespace specific string my $self = shift; my $opaque = $self->opaque; if (@_) { my $v = $opaque; my $new = shift; if (defined $new) { $v =~ s/(:|\z).*/:$new/; } else { $v =~ s/:.*//s; } $self->opaque($v); } return undef unless $opaque =~ s/^[^:]*://; return $opaque; } sub canonical { my $self = shift; my $nid = $self->_nid; my $new = $self->SUPER::canonical; return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; $new = $new->clone if $new == $self; $new->nid(lc($nid)); return $new; } 1; URI-5.28/lib/URI/ftp.pm0000644000175000017500000000204014600675475013101 0ustar olafolafpackage URI::ftp; use strict; use warnings; our $VERSION = '5.28'; use parent qw(URI::_server URI::_userpass); sub default_port { 21 } sub path { shift->path_query(@_) } # XXX sub _user { shift->SUPER::user(@_); } sub _password { shift->SUPER::password(@_); } sub user { my $self = shift; my $user = $self->_user(@_); $user = "anonymous" unless defined $user; $user; } sub password { my $self = shift; my $pass = $self->_password(@_); unless (defined $pass) { my $user = $self->user; if ($user eq 'anonymous' || $user eq 'ftp') { # anonymous ftp login password # If there is no ftp anonymous password specified # then we'll just use 'anonymous@' # We don't try to send the read e-mail address because: # - We want to remain anonymous # - We want to stop SPAM # - We don't want to let ftp sites to discriminate by the user, # host, country or ftp client being used. $pass = 'anonymous@'; } } $pass; } 1; URI-5.28/Changes0000644000175000017500000007107714600675475012060 0ustar olafolafRevision history for URI 5.28 2024-03-27 01:49:44Z - Using Scalar::Util::reftype instead of just ref(), but mindful this time about definedness to avoid warnings (GH#140) (Jacques Deguest) 5.27 2024-02-09 15:01:24Z - Add missing NAME section to POD of URI::geo (GH#142) (gregor herrmann) 5.26 2024-02-02 19:04:40Z - Add URI::geo (GH#141) (david-dick) 5.25 2024-01-27 16:11:41Z - cache scheme so it never attempt to load it again (GH#55) (mschae94) 5.24 2024-01-26 04:36:32Z - Really revert "use Scalar::Util::reftype instead of ref to check for ARRAY" (GH#136) (Olaf Alders) 5.23 2024-01-25 21:02:18Z - Revert the reftype change introduced in 5.22 as it causes warnings. (GH#134) (Olaf Alders) 5.22 2024-01-25 15:22:54Z - Use Scalar::Util::reftype instead of ref to check for ARRAY (GH#132) (Jacques Deguest) 5.21 2023-08-23 16:02:14Z - Fix version declarations in icap.pm and icaps.pm (GH#131) (Olaf Alders) 5.20 2023-08-23 14:13:23Z - Remove Shebang and Taint from all tests. - Fix t/query.t to get rid of a warning about join() on array with undef - Add icap and icaps URIs (GH#130) (david-dick) 5.19 2023-04-30 16:15:58Z - Form parameters without values are now represented by undef (GH#65) (Gianni Ceccarelli) 5.18 2023-04-29 16:08:14Z - Add a GH workflow to test LWP::Curl (GH#116) (Olaf Alders) - Add documentation examples for the host() and ihost() methods (GH#28) (Sebastian Willing) - Remove colon from username:password if there is no password (GH#31) (David E. Wheeler, Joenio Marques da Costa, Julien Fiegehenn) - Prefix private methods with _ in URI::_punycode (GH#47) (David E Wheeler) 5.17 2022-11-02 17:03:48Z - Updated RFC references in the pod documentation for URI::file (GH#117) (Håkon Hgland) - Fix SIP URI encoder/decoder (GH#118) (ryankereliuk) 5.16 2022-10-12 13:10:40Z - Merge the methods from URI::QueryParam into URI, so they are always available (GH#114) (Graham Knop) 5.15 2022-10-11 14:48:28Z - Teach uri_escape to accept a Regexp object as the characters to escape as an alternative to a character class. (GH#113) (Graham Knop) 5.14 2022-10-10 20:37:57Z - Fix uri_escape allowing \w style character classes in its character set parameter (GH#112) (Graham Knop) 5.13 2022-10-06 16:46:32Z - Regression test added for a previous bug (5.11) in URI::file (Perlbotics). file() method of URI::file can return the current working directory instead of the properly unescaped path. (GH#106) (Perlbotics) - Replace "Test" with "Test::More" (GH#107) (James Raspass) - Replace raw TAP printing with "Test::More" (GH#108) (James Raspass) - Apply perlimports to tests (GH#110) (Olaf Alders) - Improve escaping of unwanted characters (GH#78) (Branislav Zahradnk) 5.12 2022-07-10 23:48:50Z - Fix an issue where i.e. 'file:///tmp/###' was not properly escaped. A non-existing authority part was accidentally processed. Details: https://github.com/libwww-perl/URI/issues/102 (GH#102) (Perlbotics) - Reverts to previous behavior (5.10) for 'mailto:' scheme for escaping square brackets. 5.11 2022-07-04 20:53:38Z - Fix some typos in URI::file (GH#94) (Olaf Alders) - Escape square brackets in path (GH#100) (Perlbotics) - Fix storable.t (GH#97) (Shoichi Kaji) 5.10 2021-10-25 20:58:42Z - Remove Authority section from dist.ini (GH#86) (Olaf Alders) - Make URI::mailto parse subaddresses with + sign correctly (GH#89) (Julien Fiegehenn) 5.09 2021-03-03 15:16:47Z - Update Business::ISBN version requirements (GH#85) (brian d foy and Olaf Alders) 5.08 2021-02-28 18:08:32Z - added URI::nntps (GH#82) 5.07 2021-01-29 22:52:20Z - s/perl.com/example.com/ in examples and tests (GH#81) (Olaf Alders) 5.06 2021-01-14 16:01:13Z - Tidy import statements (GH#80) (Olaf Alders) 5.05 2020-10-21 13:00:44Z - Bump all versions to 5.05 in order to remove various version mismatches. (GH #77) (Olaf Alders) - Add a simple test case for an ipv6 host (GH#66) (Olaf Alders) 1.76 2019-01-09 16:59:54Z - Revert changes introduced in 1.75 1.75 2019-01-08 19:45:38Z - $uri->canonical unconditionally returns a clone (GH#58) (Dorian Taylor) 1.74 2018-04-22 12:30:44Z - avoid 'uninitialized' warning in URI::File when host has no domain name set (PR#53, thanks Shoichi Kaji!) 1.73 2018-01-09 06:42:51Z - Update documentation for URI::_punycode (GH Issue #45) 1.72 2017-07-25 - Convert the dist to Dist::Zilla for authoring. - Remove recommendation of Business::ISBN as urn/isbn.pm is deprecated - Use Test::Needs instead of raw eval in urn-isbn.t 2016-01-08 Karen Etheridge Release 1.71 No changes since 1.70_001 2015-12-29 Karen Etheridge Release 1.70_001 Kaitlyn Parkhurst: - Localize $@ when attempting to load URI subclasses (PR#30) Karen Etheridge: - speed up construction time by not attempting to load the same non-existent URI subclass twice 2015-07-25 Karen Etheridge Release 1.69 Karen Etheridge: - add $VERSIONs for all modules that lack them Olaf Alders: - add missing documentation for URI::sftp - Clarify use of query_param() method 2015-06-25 Karen Etheridge Release 1.68 Kent Fredric: - Sort hash keys to make generated query predictable Slaven Rezic: - Add new tests for path segments Brendan Byrd: - Add sftp scheme 2015-02-24 Karen Etheridge Release 1.67 Karen Etheridge: - properly skip author test for normal user installs 2015-02-24 Karen Etheridge Release 1.66 Adam Herzog: - reorganize .pm files under lib/ (github #20) 2014-11-05 Karen Etheridge Release 1.65 Karen Etheridge: - add a TO_JSON method, to assist JSON serialization 2014-07-13 Karen Etheridge Release 1.64 Eric Brine: - better fix for RT#96941, that also works around utf8 bugs on older perls 2014-07-13 Karen Etheridge Release 1.63 Karen Etheridge: - mark utf8-related test failures on older perls caused by recent string parsing changes as TODO (RT#97177, RT#96941) 2014-07-12 Karen Etheridge Release 1.62 Karen Etheridge (2): - use strict and warnings in all modules, tests and scripts - remove all remaining uses of "use vars" Eric Brine: - fixed new "\C is deprecated in regex" warning in 5.21.2 (RT#96941) 2014-07-01 Karen Etheridge Release 1.61 David Schmidt: Fix test failure if local hostname is 'foo' [RT#75519] Gisle Aas (2): New 'has_recognized_scheme' interface [RT#71204] Interfaces that return a single value now return undef rather than an empty list in list context Slaven Rezic: Fix bad regex when parsing hostnames Piotr Roszatycki: Preferentially use $ENV{TMPDIR} for temporary test files over /tmp (fixes tests on Android) 2012-03-25 Gisle Aas Release 1.60 Gisle Aas (3): Merge pull request #4 from hiratara/fix-repourl Updated repository URL Avoid failure if the local hostname is 'foo' [RT#75519] Masahiro Honma (1): Fix the URL of the repository. Matt Lawrence (1): Do not reverse the order of new parameters Peter Rabbitson (1): Fix RT#59274 - courtesy of a stupid 5.8.[12] join bug 2011-08-15 Gisle Aas Release 1.59 Make sure accessor methods don't return utf8::upgraded() bytes for URLs initialized from Unicode strings. Version number increments. Documentation tweaks. 2011-01-23 Gisle Aas Release 1.58 This release reverts the patch in 1.57 that made query_form distingush between empty and undef values. It broke stuff. [RT#62708] 2011-01-22 Gisle Aas Release 1.57 Perl 5.6 is no longer supported; use backpan.cpan.org to obtain obsolete versions of URI. Mark Stosberg (8): typo fix: s/do deal/to deal/ best practice: s/foreach /for / Whitespace: fix inconsistent use of tabs vs spaces Code style: fix inconsistency with subroutine braces at the end of the line vs below it. Modernize: s/use vars/our/ ... since we require 5.6 as a minimum version now Whitespace: fix indentation so blocks are consistently indented Add formal terms "Percent-encode" and "Percent-decode" to the NAME and description to match the RFC Drop support for Perl < 5.8.1 Perl 5.8 was released almost 10 years ago. It's time. Gisle Aas (6): Convert test to use Test::More Adjust tests for query_form Avoid "Use of uninitialized value"-noise from query_form State test dependencies [RT#61538] We also depend on ExtUtils::MakeMaker State 5.8 dependency in the META.yml file Ville Skyttä (2): Guess HTTPS and FTP from URI::Heuristic input with port but no scheme. Try harder to guess scheme from hostnames besides just "$scheme.*" ones. John Miller (1): Distingush between empty and undef values in query_form [RT#62708] 2010-10-06 Gisle Aas Release 1.56 Don't depend on DNS for the heuristics test 2010-09-01 Gisle Aas Release 1.55 Gisle Aas (2): Treat ? as a reserved character in file: URIs " is not a URI character [RT#56421] Torsten Frtsch (1): Avoid test failure unless defined $Config{useperlio} 2010-03-31 Gisle Aas Release 1.54 Alex Kapranoff (1): Fix heuristic test fails on hosts in .su (or .uk) domains [RT#56135] 2010-03-14 Gisle Aas Release 1.53 Ville Skyttä (6): Remove unneeded execute permissions. Add $uri->secure() method. Documentation and comment spelling fixes. Fix heuristics when COUNTRY is set to "gb". Use HTTP_ACCEPT_LANGUAGE, LC_ALL, and LANG in country heuristics. POD linking improvements. Michael G. Schwern (2): Rewrite the URI::Escape tests with Test::More Update URI::Escape for RFC 3986 Gisle Aas (1): Bump MIN_PERL_VERSION to 5.6.1 [RT#54078] Salvatore Bonaccorso (1): Suppress wide caracters warnings in iri.t [RT#53737] 2009-12-30 Gisle Aas Release 1.52 Gisle Aas (7): Encode::decode('UTF-8',...) with callback implemented in 2.39 %%host%% hack can be removed when URI::_server::as_iri works Don't croak on IRIs that can't be IDNA encoded IDNA roundtrip test on wrong variable Check behaviour when feeded URI constructor Latin-1 chars Add some test examples from draft-duerst-iri-bis.txt Need to recognize lower case hex digits as well 2009-11-23 Gisle Aas Release 1.51 Fixup a test that was broken on Windows 2009-11-21 Gisle Aas Release 1.50 The main news in this release is the initial attempt at providing support to IRIs. URI objects now support the 'as_iri' and 'ihost' methods. Gisle Aas (28): Added more tests for setting IPv6 addresses using the host method Document how the host methods deal with IPv6 addresses A "test case" to start IDNA prototype from Escape IDNA hostnames Introduce the as_unicode method Make as_unicode undo punycode for server URLs An IRI class might be helpful (RFC 3987) Must punycode each part of the domain name separately Include initial private Punycode module Get URI::_punycode working punycode of plain ascii should not edit with "-" Some more tests from RFC 3492 Add private URI::_idna module based on encodings/idna.py Start using URI::_idna for encoding of URIs Avoid various use of undef warnings Fix test affected by IDNA Keep reference to IDNA::Punycode in the URI::_punycode docs Ensure upgraded strings as input Update manifest with the new idna/punycode files Rename as_unicde to as_iri draft-duerst-iri-bis-07: The proposed RFC 3987 update Load Encode when its used Rename host_unicode as ihost Add basic iri test Hack to make as_iri turn A-labels into U-labels Make as_iri leave escapes not forming valid UTF-8 sequences Merge branch 'iri' Don't include RFCs in the cpan tarball Michael G. Schwern (3): Fix != overloading to match == Note that mailto does not contain a host() and this is not a bug. Strip brackets off IPv6 hosts [RT#34309] 2009-08-14 Gisle Aas Release 1.40 Even stricter test for working DNS, 2nd try. 2009-08-13 Gisle Aas Release 1.39 Even stricter test for working DNS, hopefully this gets rid of the rest of the heuristics.t failures. 2009-05-27 Gisle Aas Release 1.38 Ville Skyttä (3): Spelling fixes. Tatsuhiko Miyagawa (1): skip DNS test if wildcard domain catcher (e.g. OpenDNS) is there Gisle Aas (1): Avoid "Insecure $ENV{PATH} while running with -T switch" error with perl-5.6. 2008-06-16 Gisle Aas Release 1.37 Gisle Aas (1): Support ";" delimiter in $u->query_form Jan Dubois (1): We get different test result when www.perl.com doesn't resolve. Kenichi Ishigaki (1): URI::Heuristic didn't work for generic country code [RT#35156] 2008-04-03 Gisle Aas Release 1.36 : Escape Unicode strings as UTF-8. Bjoern Hoehrmann : fixed URL encoded data: URLs GAAS: uri_escape_utf8() now exported by default as documented. BDFOY: Test fails with Business::ISBN installed [RT#33220] JDHEDDEN: lc(undef) reports warning in blead [RT#32742] GEOFFR: add some tests for gopher URIs [RT#29211] 2004-11-05 Gisle Aas Release 1.35 Documentation update. Simplified uri_escape_utf8 implementation. No need to load the Encode module. Contributed by Alexey Tourbin. Work around bug in perl-5.6.0 that made t/query.t fail. 2004-10-05 Gisle Aas Release 1.34 URI->canonical will now always unescape any escaped unreserved chars. Previously this only happened for the http and https scheme. Patch contributed by Eric Promislow . 2004-09-19 Gisle Aas Release 1.33 URI::file->canonical will now try to change the 'authority' to the default one. Fix heuristic test. Apparently www.perl.co.uk is no more. 2004-09-07 Gisle Aas Release 1.32 Introduce $URI::file::DEFAULT_AUTHORITY which control what authority string to use for absolute file URIs. Its value default to "" which produce file URIs that better interoperates with other implementations. The old mapping behaviour can be requested by setting this variable to undef. 2004-06-08 Gisle Aas Release 1.31 Added uri_escape_utf8() function to URI::Escape module. Fixed abs/rel behaviour for sip: URIs. Fixed by Ville Skyttä . Avoid croaking on code like $u->query_form(a => { foo => 1 }). It will still not really do anything useful. 2004-01-14 Gisle Aas Release 1.30 Documentation fixes by Paul Croome . 2004-01-02 Gisle Aas Release 1.29 Added support for the ldapi: and ldaps: schemes. The ldaps: implementation was contributed by Graham Barr. Added support for mms: scheme. Contributed by Dan Sully . 2003-11-30 Gisle Aas Release 1.28 The query_param_delete() method was not able to delete the last parameter from a form. Similar problem existing when deleting via query_param(). Patch by . The query_form() method now allow an array or hash reference to be passed to set the value. This makes it possible to set the value to an empty form, something that the old API did not allow. The query_keywords() method now allow an array reference to be passed to set the value. 2003-10-06 Gisle Aas Release 1.27 The URI module is now less strict about the values accepted for gopher_type attribute of gopher:-URLs. Patch suggested by the Net::Gopher author; William G. Davis. 2003-10-03 Gisle Aas Release 1.26 Help Storable deal with URI objects. Patch contributed by . Fix failure under OS/2. Patch contributed by Ilya Zakharevich. 2003-08-18 Gisle Aas Release 1.25 Allow literal '@' in userinfo. If there are multiple '@' chars in the 'authority' component use the last (instead of first) as the 'userinfo' delimiter. Make URI->query_form escape '[' and ']'. These chars where added to the reserved set in RFC 2732. This also matches MSIE behaviour. Silence warning from 'sip' support class. 2003-07-24 Gisle Aas Release 1.24 Relative URIs that start with the query string directly (i.e. "?q") are now absolutized as specified in rfc2396bis. See: http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query Added URI::Split module. It's a lightweight module that can be used to parse and compose URI string to/from its component parts. The rel() method will now work from canonical URIs. That allow it to extract a relative URI in more cases. 2003-01-01 Gisle Aas Release 1.23 Support for tn3270 URIs. Use anchored DNS lookups in URI::Heuristic as suggested by Malcolm Weir . Delay calculation of MY_COUNTRY() in URI::Heuristic. Patch by Ed Avis . Make test suite work for UNC paths. Patch by Warren Jones . 2002-09-02 Gisle Aas Release 1.22 Added URI::QueryParam module. It contains some extra methods to manipulate the query form key/value pairs. Added support for the sip: and sips: URI scheme. Contributed by Ryan Kereliuk . 2002-08-04 Gisle Aas Release 1.21 Restore perl-5.004 and perl-5.005 compatibility. 2002-07-18 Gisle Aas Release 1.20 Direct support for some new schemes urn:, urn:isbn:, urn:oid:, rtsp:, and rtspu:. The rtsp support was contributed by Matt Selsky . Documentation fix for $URI::ABS_REMOTE_LEADING_DOTS. CPAN-RT-Bug #1224. The host for URI::file was not unescaped. Patch by Ville Skyttä . 2002-05-09 Gisle Aas Release 1.19 URI::Heuristic will guess better on strings like "123.3.3.3:8080/foo". It used to think that the numbers before ":" was a scheme. URI::WithBase will not keep the full history of any base URI's base URI etc. This used to make these objects grow into to monsters for some web spiders. URI::URL->new("foo", "bar")->base used to return a "URI" object. Now an URI::URL object is returned instead. Deal properly with file:///-URIs. 2001-12-30 Gisle Aas Release 1.18 Added support for ssh: URIs. Contributed by Jean-Philippe Bouchard URI::Escape: Make sure cache is not set when the RE wouldn't compile. Fix suggested by . Applied patch as suggested by Randal L. Schwartz. Don't try to come up with the e-mail address of the user as the anonymous password. Patch by Eduardo Pérez . 2001-09-14 Gisle Aas Release 1.17 Fixed unescape of %30 in $http_uri->canonical. Fixed test failure for t/heuristic.t on cygwin. Fixed warning noise from t/old-base.t on bleadperl. Perl now warns for pack("c*", $i) when $i > 127. 2001-08-27 Gisle Aas Release 1.16 URI::Escape::uri_escape default has changed. Reserved characters are now escaped when no second argument is provided. The perl5.004 backwards compatibility patching taking place in the Makefile.PL should now work for MacPerl. Patch by KIMURA Takeshi . URI::WithBase now overrides the can() method and delegate it to the URI member. This also affects the URI::URL behaviour. Patch by Sean M. Burke . 2001-07-19 Gisle Aas Release 1.15 [This release was made just to document the changes that went into the (unreleased) URI-1.13 but never made it into this change-log. There is no functional difference between the 1.14 and 1.15 release.] 2001-07-18 Gisle Aas Release 1.14 The module failed on perl5.004 because \z is not supported in regexps. The Makefile.PL will now try to patch the module to be compatible. 2001-05-15 Gisle Aas Release 1.13 (never made it to CPAN) URI.pm now conforms to RFC 2732 which specify how literal IPv6 addresses are to be included in URLs. URI/Escape now allows "/" in the $unsafe pattern argument. 2001-04-23 Gisle Aas Release 1.12 URI->new($u, $scheme) does no longer fail if given a badly formatted scheme string. URI::WithBase's clone and base method was basically just broken. This also affected the URI::URL subclass. The clone() method did not copy the base, and updating the base with the base method always set it to "1". 2001-02-27 Gisle Aas Release 1.11 The t/heuristic.t test relied on the fact that 'www.perl.no' was not registered in DNS. This is no longer true. The penguins at Bouvet Island will hopefully be ignorant of Perl forever. 2001-01-10 Gisle Aas Release 1.10 The $u->query_form method will now escape spaces in form keys or values as '+' (instead of '%20'). This also affect the $mailto_uri->header() method. This is actually the wrong thing to do, but this practise is now even documented in official places like http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 so we might as well follow the stream. URI::Heuristic did not work for domain-names with dashes '-' in them. Fixed. Documented that $uri->xxx($1) might not work. 2000-08-16 Gisle Aas Release 1.09 uri_unescape() did not work when given multiple strings to decode. Patch by Nicholas Clark . 2000-08-02 Gisle Aas Release 1.08 ldap URIs now support _scope() and _filter() methods that don't have default values. Suggested by Graham Barr. Incorporated old rejected MSWin32 patch to t/old-base.t. Hope it works. 2000-06-13 Gisle Aas Release 1.07 URI::WithBase (and URI::URL) now support $u->new_abs constructor. URI::WithBase->new("foo", "URI::URL") bug fixed. 2000-04-09 Gisle Aas Release 1.06 Clean test/install on VMS. Patch by Charles Lane 2000-02-14 Gisle Aas Release 1.05 QNX file support by Norton Allen . Support for rsync:-URI by Dave Beckett 1999-08-03 Gisle Aas Release 1.04 Avoid testing for defined(@ISA) and defined(%class::). Patch by Nathan Torkington . $uri->abs() did wrong when the fragment contained a "?" character. Typo in URI::ldap spotted by Graham Barr. 1999-06-24 Gisle Aas Release 1.03 Escape all reserved query characters in the individual components of $uri->query_form and $uri->query_keywords. Make compatibility URI::URL->new("mailto:gisle@aas.no")->netloc work again. 1999-03-26 Gisle Aas Release 1.02 Added URI::ldap. Contributed by Graham Barr . Documentation update. 1999-03-20 Gisle Aas Release 1.01 MacOS patches from Paul J. Schinder Documentation patch from Michael A. Chase 1998-11-19 Gisle Aas Release 1.00 Added new URI->new_abs method Replaced a few die calls with croak. 1998-10-12 Gisle Aas Release 0.90_02 Implemented new $uri->host_port method. $uri->epath and $uri->equery aliases to make URI::URL compatibility easier. 1998-09-23 Gisle Aas Release 0.90_01 New README Makefile.PL list MIME::Base64 as PREREQ_PM Original $scheme argument not passed to _init() method. Automatically add scheme to empty URIs where the scheme is required: URI->new("", "data") Documentation update. New URI::URL::strict implementation. 1998-09-22 Gisle Aas Release 0.09_02 New internal URI::file::* interface. Implemented 8.3 mapping for "dos". Got rid of $URI::STRICT and $URI::DEFAULT_SCHEME More documentation. 1998-09-13 Gisle Aas Release 0.09_01 Use version number with underscore to avoid that the CPAN indexer hides the URI::URL from libwww-perl that contains all the documentation. Started to document the new modules. URI::file->new() escape fix which allow Mac file names like ::.. to be treated as they should (I think). 1998-09-12 Gisle Aas Release 0.09 Included URI::Escape and URI::Heuristic from LWP. URI::Escape updated with new default set of characters to escape (according to RFC 2396) and a faster uri_unescape() function. URI::Heuristic updated with a new function that returns an URI object. First argument to URI->new is always treated as a string now. URI->new("", URI::WithBase("foo:")) now works. It returns an URI::WithBase object. Included Roy T. Fielding's URI parsing/abs tests from . We did in fact agree with RFC 2396 on all tests. Allow authority "A|" in Win32 file:-URIs to denote A:. Treat escaped chars. 1998-09-10 Gisle Aas Release 0.08 Implemented transformations between various file: URIs and actual file names. New URI::file methods: new new_abs cwd file dir 1998-09-09 Gisle Aas Release 0.07 Implemented rlogin, telnet and file URLs. Implemented URI::WithBase Implemented URI::URL emulator (ported old URI::URL test suite) Can now use schemes with "-", "+" or "." characters in them. $u->scheme will downcase. $u->_scheme will keep it as it is. Configuration variables for $u->abs $u->query_form and $u->query_keyword is more careful about escaping "+" and "=". $u->host unescaped $u->_port if you want to bypass $u->default_port Can handle news message-ids with embedded "/" now 1998-09-08 Gisle Aas Release 0.06 Implemented gopher URLs Implemented ftp URLs Second ctor argument can be a plain scheme name. If it is an object, then we use the class of the object as implementor. Protect literal % in various places by escaping Path segments with parameters are not arrays of class URI::_segment, which overloads the stringify operator. URI::http->canonical will now unescape unreserved characters. 1998-09-08 Gisle Aas Release 0.05 Implemented news URLs (together with snews/nntp) Implemented pop URLs (RFC 2384) Can now use '==' to compare if two URI objects are the same or not. $u->opaque_part renamed as $u->opaque Better canonicalization Faster $u->abs (especially for URI that already are absolute) $u->query_form will keep more chars unescaped 1998-09-06 Gisle Aas Release 0.04 Implemented mailto:-URLs (specified in RFC 2368) Moved query() methods to internal URI::_query mixin class. Escape stuff in the media_type field of data:-URLs. 1998-09-06 Gisle Aas Release 0.03 based on simplified scalar object. 1998-09-02 Gisle Aas Release 0.02 based on perl5.005 and fields.pm 1998-04-10 Gisle Aas Release 0.01