URI-5.30/0000775000175000017500000000000014701320657010533 5ustar olafolafURI-5.30/t/0000775000175000017500000000000014701320657010776 5ustar olafolafURI-5.30/t/mix.t0000644000175000017500000000270014701320657011755 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.30/t/abs.t0000644000175000017500000001270414701320657011732 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.30/t/old-file.t0000644000175000017500000000533314701320657012660 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.30/t/ftp.t0000644000175000017500000000144314701320657011754 0ustar olafolafuse strict; use warnings; use Test::More tests => 15; 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->secure, 0); is($uri->encrypt_mode, undef); 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.30/t/generic.t0000644000175000017500000000732314701320657012602 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.30/t/rsync.t0000644000175000017500000000040714701320657012320 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.30/t/split.t0000644000175000017500000000174214701320657012320 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.30/t/num_eq.t0000644000175000017500000000060514701320657012446 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.30/t/query-param.t0000644000175000017500000000372714701320657013435 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.30/t/sftp.t0000644000175000017500000000043514701320657012137 0ustar olafolafuse strict; use warnings; use Test::More tests => 6; use URI (); my $uri; $uri = URI->new("sftp://user\@ssh.example.com/path"); is($uri->scheme, 'sftp'); is($uri->host, 'ssh.example.com'); is($uri->port, 22); is($uri->secure, 1); is($uri->user, 'user'); is($uri->password, undef); URI-5.30/t/old-absconf.t0000644000175000017500000000133214701320657013347 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.30/t/roytest2.html0000644000175000017500000000707414701320657013465 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.30/t/urn-scheme-exceptions.t0000644000175000017500000000101514701320657015403 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.30/t/scp.t0000644000175000017500000000043314701320657011746 0ustar olafolafuse strict; use warnings; use Test::More tests => 6; use URI (); my $uri; $uri = URI->new("scp://user\@ssh.example.com/path"); is($uri->scheme, 'scp'); is($uri->host, 'ssh.example.com'); is($uri->port, 22); is($uri->secure, 1); is($uri->user, 'user'); is($uri->password, undef); URI-5.30/t/icap.t0000644000175000017500000000212114701320657012071 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", "fôo"]); $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.30/t/storable.t0000644000175000017500000000035214701320657012774 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.30/t/iri.t0000644000175000017500000000532214701320657011746 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.30/t/sq-brackets.t0000644000175000017500000002001514701320657013376 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.30/t/storable-test.pl0000644000175000017500000000110114701320657014112 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.30/t/mms.t0000644000175000017500000000105314701320657011754 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.30/t/00-report-prereqs.dd0000644000175000017500000000732014701320657014516 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::Base32' => '0', '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.30/t/rtsp.t0000644000175000017500000000121314701320657012146 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.30/t/gopher.t0000644000175000017500000000177414701320657012456 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.30/t/sip.t0000644000175000017500000000435314701320657011761 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.30/t/file.t0000644000175000017500000000716114701320657012105 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.30/t/old-relbase.t0000644000175000017500000000135414701320657013355 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.30/t/news.t0000644000175000017500000000201714701320657012135 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.30/t/mailto.t0000644000175000017500000000453414701320657012454 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.30/t/ftpes.t0000644000175000017500000000034714701320657012306 0ustar olafolafuse strict; use warnings; use Test::More tests => 4; use URI (); my $uri; $uri = URI->new("ftpes://ftp.example.com/path"); is($uri->scheme, 'ftpes'); is($uri->port, 21); is($uri->secure, 1); is($uri->encrypt_mode, 'explicit'); URI-5.30/t/http.t0000644000175000017500000000212314701320657012136 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", "fôo"]); $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.30/t/urn-oid.t0000644000175000017500000000042614701320657012540 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.30/t/otpauth.t0000644000175000017500000002045514701320657012653 0ustar olafolaf#!perl use strict; use warnings; use URI; use Test::More tests => 86; { my $uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=JBSWY3DPEHPK3PXP&issuer=Example' ); ok $uri, "created $uri"; isa_ok $uri, 'URI::otpauth'; is $uri->type(), 'totp', 'type'; is $uri->label(), 'Example:alice@google.com', 'label'; is $uri->issuer(), 'Example', 'issuer'; is $uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $uri->counter(), undef, 'counter'; is $uri->algorithm(), 'SHA1', 'algorithm'; is $uri->digits(), 6, 'digits'; is $uri->period(), 30, 'period'; is $uri->fragment(), undef, 'fragment'; my $new_secret = 'this_is_really secret!'; $uri->secret($new_secret); my $new_uri = URI->new( "$uri" ); ok $new_uri, "created $new_uri"; isa_ok $new_uri, 'URI::otpauth'; unlike $new_uri, qr/secret=$new_secret/, 'no clear text secret'; is $new_uri->type(), 'totp', 'type'; is $new_uri->label(), 'Example:alice@google.com', 'label'; is $new_uri->account_name(), 'alice@google.com', 'account_name'; is $new_uri->issuer(), 'Example', 'issuer'; is $new_uri->secret(), $new_secret, 'secret'; is $new_uri->counter(), undef, 'counter'; is $new_uri->algorithm(), 'SHA1', 'algorithm'; is $new_uri->digits(), 6, 'digits'; is $new_uri->period(), 30, 'period'; is $new_uri->fragment(), undef, 'fragment'; my $next_uri = URI->new( 'otpauth://totp/alice@google.com?secret=JBSWY3DPEHPK3PXP&issuer=Example&digits=8&algorithm=SHA256' ); ok $next_uri, "created $next_uri"; isa_ok $next_uri, 'URI::otpauth'; is $next_uri->type(), 'totp', 'type'; is $next_uri->label(), 'Example:alice@google.com', 'label'; is $next_uri->account_name(), 'alice@google.com', 'account_name'; is $next_uri->issuer(), 'Example', 'issuer'; is $next_uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $next_uri->counter(), undef, 'counter'; is $next_uri->algorithm(), 'SHA256', 'algorithm'; is $next_uri->digits(), 8, 'digits'; is $next_uri->period(), 30, 'period'; is $next_uri->fragment(), undef, 'fragment'; my $issuer_uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=JBSWY3DPEHPK3PXP' ); ok $issuer_uri, "created $issuer_uri"; isa_ok $issuer_uri, 'URI::otpauth'; is $issuer_uri->type(), 'totp', 'type'; is $issuer_uri->label(), 'Example:alice@google.com', 'label'; is $issuer_uri->account_name(), 'alice@google.com', 'account_name'; is $issuer_uri->issuer(), 'Example', 'issuer'; is $issuer_uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $issuer_uri->counter(), undef, 'counter'; is $issuer_uri->algorithm(), 'SHA1', 'algorithm'; is $issuer_uri->digits(), 6, 'digits'; is $issuer_uri->period(), 30, 'period'; is $issuer_uri->fragment(), undef, 'fragment'; my $issuer2_uri = URI->new( 'otpauth://hotp/Example:alice@google.com?&issuer=Example2&counter=23&period=15' ); ok $issuer2_uri, "created $issuer2_uri"; isa_ok $issuer2_uri, 'URI::otpauth'; is $issuer2_uri->type(), 'hotp', 'type'; is $issuer2_uri->label(), 'Example2:alice@google.com', 'label'; is $issuer2_uri->issuer(), 'Example2', 'issuer'; is $issuer2_uri->secret(), undef, 'secret'; is $issuer2_uri->counter(), 23, 'counter'; is $issuer2_uri->algorithm(), 'SHA1', 'algorithm'; is $issuer2_uri->digits(), 6, 'digits'; is $issuer2_uri->period(), 15, 'period'; is $issuer2_uri->fragment(), undef, 'fragment'; } # vim:ts=2:sw=2:et:ft=perl my @case = ( { name => 'Hotp', args => { secret => "topsecret", type => 'hotp', issuer => 'Foo', counter => 6, account_name => 'bob@example.com' }, secret => "topsecret", type => 'hotp', issuer => 'Foo', account_name => 'bob@example.com', counter => 6, algorithm => 'SHA1', period => 30, }, { name => 'Only Account Name', args => { secret => "justabunchofstuff", account_name => 'alice@example.org', algorithm => 'SHA512', period => 7 }, secret => "justabunchofstuff", type => 'totp', issuer => undef, account_name => 'alice@example.org', counter => undef, algorithm => 'SHA512', period => 7, }, { name => 'Only mandatory', args => { secret => "justabunchofstuff" }, secret => "justabunchofstuff", type => 'totp', issuer => undef, account_name => undef, counter => undef, algorithm => 'SHA1', period => 30, }, ); for my $case ( @case ) { my ( $name, $args, $secret, $type, $issuer, $account_name, $counter, $algorithm, $period, $frag ) = @{$case}{ qw(name args secret type issuer account_name counter algorithm period frag) }; my $uri = URI::otpauth->new( %$args ); ok $uri, "created $uri"; is $uri->scheme(), 'otpauth', "$name: scheme"; is $uri->type(), $type, "$name: type"; is $uri->secret(), $secret, "$name: secret"; is $uri->issuer(), $issuer, "$name: issuer"; if (defined $issuer) { is $uri->label(), (join q[:], $issuer, $account_name), "$name: label"; } is $uri->algorithm(), $algorithm, "$name: algorithm"; is $uri->counter(), $counter, "$name: counter"; is $uri->period(), $period, "$name: period"; } eval { URI::otpauth->new( type => 'totp' ); }; like $@, qr/^secret is a mandatory parameter for URI::otpauth/, "missing secret"; my $doc1_uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=NFZS25DINFZV643VOAZXELLTGNRXEM3UH4&issuer=Example' ); my $doc2_uri = URI::otpauth->new( type => 'totp', issuer => 'Example', account_name => 'alice@google.com', secret => 'is-this_sup3r-s3cr3t?' ); diag "doc1_uri is $doc1_uri"; diag "doc2_uri is $doc2_uri"; is "$doc1_uri", "$doc2_uri", "$doc1_uri: matches"; # vim:ts=2:sw=2:et:ft=perl URI-5.30/t/roytest5.html0000644000175000017500000000644214701320657013466 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.30/t/sort-hash-query-form.t0000644000175000017500000000054214701320657015176 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.30/t/escape.t0000644000175000017500000000561214701320657012425 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.30/t/clone.t0000644000175000017500000000051314701320657012260 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.30/t/sq-brackets-legacy.t0000644000175000017500000000212514701320657014642 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.30/t/ipv6.t0000644000175000017500000000033414701320657012045 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.30/t/data.t0000644000175000017500000000443414701320657012077 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("Får-i-kål 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,båz"), "foo"); is($u->media_type, "bar,båz"); $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.30/t/geo_point.t0000644000175000017500000000065514701320657013152 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.30/t/escape-char.t0000644000175000017500000000114514701320657013335 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.30/t/query.t0000644000175000017500000000645514701320657012340 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.30/t/scheme-exceptions.t0000644000175000017500000000074014701320657014605 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.30/t/rfc2732.t0000644000175000017500000000355614701320657012262 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.30/t/roytest4.html0000644000175000017500000000721014701320657013457 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.30/t/ldap.t0000644000175000017500000000460714701320657012110 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.30/t/userpass.t0000644000175000017500000000065514701320657013034 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.30/t/geo_basic.t0000644000175000017500000000334614701320657013102 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.30/t/old-base.t0000644000175000017500000010404414701320657012652 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@håst:12345'; is($url->user, 'anonymous', ref($url) . '->as_string'); is($url->password, 'pass', ref($url) . '->as_string'); is($url->host, 'xn--hst-ula', ref($url) . '->as_string'); is($url->port, 12345, ref($url) . '->as_string'); # Can't really know how netloc is represented since it is partially escaped #is($url->netloc, 'anonymous:pass@hst:12345', ref($url) . '->as_string'); is($url->as_string, 'ftp://anonymous:pass@xn--hst-ula:12345', ref($url) . '->as_string'); # The '0' is sometimes tricky to get right $url->user(0); $url->password(0); $url->host(0); $url->port(0); is($url->netloc, '0:0@0:0', ref($url) . '->as_string'); $url->host(undef); is($url->netloc, '0:0@:0', ref($url) . '->as_string'); $url->host('h'); $url->user(undef); is($url->netloc, ':0@h:0', ref($url) . '->as_string'); $url->user(''); is($url->netloc, ':0@h:0', ref($url) . '->as_string'); $url->password(''); is($url->netloc, ':@h:0', ref($url) . '->as_string'); $url->user('foo'); is($url->netloc, 'foo:@h:0', ref($url) . '->as_string'); # Let's try a simple one $url->user('nemo'); $url->password('p2'); $url->host('hst2'); $url->port(2); is($url->netloc, 'nemo:p2@hst2:2', ref($url) . '->as_string'); $url->user(undef); $url->password(undef); $url->port(undef); is($url->netloc, 'hst2', ref($url) . '->as_string'); is($url->port, '21', ref($url) . '->as_string'); # the default ftp port $url->port(21); is($url->netloc, 'hst2:21', ref($url) . '->as_string'); # Let's try some reserved chars $url->user("@"); $url->password(":-#-;-/-?"); is($url->as_string, 'ftp://%40::-%23-;-%2F-%3F@hst2:21', ref($url) . '->as_string'); } # # port_test() # # Test port behaviour # sub port_test { $url = URI::URL->new('http://foo/root/dir/'); my $port = $url->port; is($port, 80, 'port'); is($url->as_string, 'http://foo/root/dir/', 'string'); $url->port(8001); $port = $url->port; is($port, 8001, 'port'); is($url->as_string, 'http://foo:8001/root/dir/', 'string'); $url->port(80); $port = $url->port; is($port, 80, 'port'); is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); $url->port(8001); $url->port(undef); $port = $url->port; is($port, 80, 'port'); is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); } ##################################################################### # # escape_test() # # escaping functions sub escape_test { # supply escaped URL $url = new URI::URL 'http://web/this%20has%20spaces'; # check component is unescaped is($url->path, '/this has spaces', ref($url) . '->as_string'); # modify the unescaped form $url->path('this ALSO has spaces'); # check whole url is escaped is($url->as_string, 'http://web/this%20ALSO%20has%20spaces', ref($url) . '->as_string'); $url = new URI::URL uri_escape('http://web/try %?#" those'); is($url->as_string, 'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those', ref($url) . '->as_string'); my $all = pack('C*',0..255); my $esc = uri_escape($all); my $new = uri_unescape($esc); is($all, $new, "uri_escape->uri_unescape"), $url->path($all); 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.30/t/roytest1.html0000644000175000017500000001650514701320657013463 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.30/t/path-segments.t0000644000175000017500000000175014701320657013743 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.30/t/rel.t0000644000175000017500000000103514701320657011742 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.30/t/roytest3.html0000644000175000017500000000601714701320657013462 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.30/t/punycode.t0000644000175000017500000000434314701320657013013 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.30/t/roy-test.t0000644000175000017500000000165014701320657012751 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.30/t/urn-isbn.t0000644000175000017500000000135214701320657012717 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.30/t/heuristic.t0000644000175000017500000000632714701320657013170 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.30/t/geo_construct.t0000644000175000017500000000415014701320657014037 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.30/t/ircs.t0000644000175000017500000000035714701320657012126 0ustar olafolafuse strict; use warnings; use Test::More tests => 4; use URI (); my $uri; $uri = URI->new("ircs://PerlUser\@irc.perl.org"); is($uri, "ircs://PerlUser\@irc.perl.org"); is($uri->scheme, 'ircs'); is($uri->port, 994); is($uri->secure, 1); URI-5.30/t/utf8.t0000644000175000017500000000103714701320657012050 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.30/t/irc.t0000644000175000017500000000157214701320657011743 0ustar olafolafuse strict; use warnings; use Test::More tests => 10; use URI (); my $uri; $uri = URI->new("irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux"); is($uri, "irc://PerlUser\@irc.perl.org:6669/#libwww-perl,ischannel,isnetwork?key=bazqux"); is($uri->port, 6669); # add a password $uri->password('foobar'); is($uri->userinfo, "PerlUser:foobar"); my @opts = $uri->options; is_deeply(\@opts, [qw< key bazqux >]); $uri->options(foo => "bar", bar => "baz"); is($uri->query, "foo=bar&bar=baz"); is($uri->host, "irc.perl.org"); is($uri->path, "/#libwww-perl,ischannel,isnetwork"); # add a bunch of flags to clean up $uri->path("/SineSwiper,isnick,isnetwork,isserver,needpass,needkey"); $uri = $uri->canonical; is($uri->path, "/SineSwiper,isuser,isnetwork,needpass,needkey"); # ports and secure-ness is($uri->secure, 0); $uri->port(undef); is($uri->port, 6667); URI-5.30/t/00-report-prereqs.t0000644000175000017500000001360114701320657014371 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.30/t/ssh.t0000644000175000017500000000043314701320657011756 0ustar olafolafuse strict; use warnings; use Test::More tests => 6; use URI (); my $uri; $uri = URI->new("ssh://user\@ssh.example.com/path"); is($uri->scheme, 'ssh'); is($uri->host, 'ssh.example.com'); is($uri->port, 22); is($uri->secure, 1); is($uri->user, 'user'); is($uri->password, undef); URI-5.30/t/idna.t0000644000175000017500000000076714701320657012106 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.30/t/ftps.t0000644000175000017500000000034614701320657012140 0ustar olafolafuse strict; use warnings; use Test::More tests => 4; use URI (); my $uri; $uri = URI->new("ftps://ftp.example.com/path"); is($uri->scheme, 'ftps'); is($uri->port, 990); is($uri->secure, 1); is($uri->encrypt_mode, 'implicit'); URI-5.30/t/cwd.t0000644000175000017500000000026014701320657011734 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.30/t/pop.t0000644000175000017500000000147414701320657011765 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('får;k@l'); ok($u->user eq 'får;k@l' && $u eq 'pop://f%E5r%3Bk%40l@pop.sn.no'); URI-5.30/LICENSE0000644000175000017500000004641614701320657011551 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.30/MANIFEST0000644000175000017500000000452114701320657011664 0ustar olafolaf# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.032. 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/ftpes.pm lib/URI/ftps.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/irc.pm lib/URI/ircs.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/otpauth.pm lib/URI/pop.pm lib/URI/rlogin.pm lib/URI/rsync.pm lib/URI/rtsp.pm lib/URI/rtspu.pm lib/URI/scp.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/ftpes.t t/ftps.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/irc.t t/ircs.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/otpauth.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/scp.t t/sftp.t t/sip.t t/sort-hash-query-form.t t/split.t t/sq-brackets-legacy.t t/sq-brackets.t t/ssh.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.30/Makefile.PL0000644000175000017500000000376014701320657012511 0ustar olafolaf# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.032. 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::Base32" => 0, "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.30", "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::Base32" => 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.30/dist.ini0000644000175000017500000001170414701320657012200 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/otpauth.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::ftpes skip = URI::ftps skip = URI::irc skip = URI::nntp skip = URI::urn::isbn skip = URI::urn::oid skip = URI::scp 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|encrypt_mode)$/ 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 stopword = totp stopword = hotp stopword = TOTP stopword = HOTP stopword = OTP stopword = cryptographic ;;; 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.30/README0000644000175000017500000000056514701320657011417 0ustar olafolafThis archive contains the distribution URI, version 5.30: 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.032. URI-5.30/CONTRIBUTING.md0000644000175000017500000001020414701320657012757 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.30/uri-test0000755000175000017500000000222414701320657012233 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.30/perlimports.toml0000644000175000017500000000211214701320657014002 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.30/cpanfile0000644000175000017500000000325414701320657012241 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::Base32" => "0"; 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.30/META.json0000644000175000017500000007106314701320657012161 0ustar olafolaf{ "abstract" : "Uniform Resource Identifiers (absolute and relative)", "author" : [ "Gisle Aas " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.032, 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::Base32" : "0", "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.30" }, "URI::Escape" : { "file" : "lib/URI/Escape.pm", "version" : "5.30" }, "URI::Heuristic" : { "file" : "lib/URI/Heuristic.pm", "version" : "5.30" }, "URI::IRI" : { "file" : "lib/URI/IRI.pm", "version" : "5.30" }, "URI::QueryParam" : { "file" : "lib/URI/QueryParam.pm", "version" : "5.30" }, "URI::Split" : { "file" : "lib/URI/Split.pm", "version" : "5.30" }, "URI::URL" : { "file" : "lib/URI/URL.pm", "version" : "5.30" }, "URI::WithBase" : { "file" : "lib/URI/WithBase.pm", "version" : "5.30" }, "URI::data" : { "file" : "lib/URI/data.pm", "version" : "5.30" }, "URI::file" : { "file" : "lib/URI/file.pm", "version" : "5.30" }, "URI::file::Base" : { "file" : "lib/URI/file/Base.pm", "version" : "5.30" }, "URI::file::FAT" : { "file" : "lib/URI/file/FAT.pm", "version" : "5.30" }, "URI::file::Mac" : { "file" : "lib/URI/file/Mac.pm", "version" : "5.30" }, "URI::file::OS2" : { "file" : "lib/URI/file/OS2.pm", "version" : "5.30" }, "URI::file::QNX" : { "file" : "lib/URI/file/QNX.pm", "version" : "5.30" }, "URI::file::Unix" : { "file" : "lib/URI/file/Unix.pm", "version" : "5.30" }, "URI::file::Win32" : { "file" : "lib/URI/file/Win32.pm", "version" : "5.30" }, "URI::ftp" : { "file" : "lib/URI/ftp.pm", "version" : "5.30" }, "URI::ftpes" : { "file" : "lib/URI/ftpes.pm", "version" : "5.30" }, "URI::ftps" : { "file" : "lib/URI/ftps.pm", "version" : "5.30" }, "URI::geo" : { "file" : "lib/URI/geo.pm", "version" : "5.30" }, "URI::gopher" : { "file" : "lib/URI/gopher.pm", "version" : "5.30" }, "URI::http" : { "file" : "lib/URI/http.pm", "version" : "5.30" }, "URI::https" : { "file" : "lib/URI/https.pm", "version" : "5.30" }, "URI::icap" : { "file" : "lib/URI/icap.pm", "version" : "5.30" }, "URI::icaps" : { "file" : "lib/URI/icaps.pm", "version" : "5.30" }, "URI::irc" : { "file" : "lib/URI/irc.pm", "version" : "5.30" }, "URI::ircs" : { "file" : "lib/URI/ircs.pm", "version" : "5.30" }, "URI::ldap" : { "file" : "lib/URI/ldap.pm", "version" : "5.30" }, "URI::ldapi" : { "file" : "lib/URI/ldapi.pm", "version" : "5.30" }, "URI::ldaps" : { "file" : "lib/URI/ldaps.pm", "version" : "5.30" }, "URI::mailto" : { "file" : "lib/URI/mailto.pm", "version" : "5.30" }, "URI::mms" : { "file" : "lib/URI/mms.pm", "version" : "5.30" }, "URI::news" : { "file" : "lib/URI/news.pm", "version" : "5.30" }, "URI::nntp" : { "file" : "lib/URI/nntp.pm", "version" : "5.30" }, "URI::nntps" : { "file" : "lib/URI/nntps.pm", "version" : "5.30" }, "URI::otpauth" : { "file" : "lib/URI/otpauth.pm", "version" : "5.30" }, "URI::pop" : { "file" : "lib/URI/pop.pm", "version" : "5.30" }, "URI::rlogin" : { "file" : "lib/URI/rlogin.pm", "version" : "5.30" }, "URI::rsync" : { "file" : "lib/URI/rsync.pm", "version" : "5.30" }, "URI::rtsp" : { "file" : "lib/URI/rtsp.pm", "version" : "5.30" }, "URI::rtspu" : { "file" : "lib/URI/rtspu.pm", "version" : "5.30" }, "URI::scp" : { "file" : "lib/URI/scp.pm", "version" : "5.30" }, "URI::sftp" : { "file" : "lib/URI/sftp.pm", "version" : "5.30" }, "URI::sip" : { "file" : "lib/URI/sip.pm", "version" : "5.30" }, "URI::sips" : { "file" : "lib/URI/sips.pm", "version" : "5.30" }, "URI::snews" : { "file" : "lib/URI/snews.pm", "version" : "5.30" }, "URI::ssh" : { "file" : "lib/URI/ssh.pm", "version" : "5.30" }, "URI::telnet" : { "file" : "lib/URI/telnet.pm", "version" : "5.30" }, "URI::tn3270" : { "file" : "lib/URI/tn3270.pm", "version" : "5.30" }, "URI::urn" : { "file" : "lib/URI/urn.pm", "version" : "5.30" }, "URI::urn::isbn" : { "file" : "lib/URI/urn/isbn.pm", "version" : "5.30" }, "URI::urn::oid" : { "file" : "lib/URI/urn/oid.pm", "version" : "5.30" } }, "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.30", "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.051" }, { "class" : "Dist::Zilla::Plugin::Encoding", "name" : "Encoding", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "MetaConfig", "version" : "6.032" }, { "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.032" } ], "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.032" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "MetaYAML", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "MetaJSON", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "MetaResources", "version" : "6.032" }, { "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.037" }, { "class" : "Dist::Zilla::Plugin::GithubMeta", "name" : "GithubMeta", "version" : "0.58" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "Manifest", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "License", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "ExecDir", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::Prereqs::FromCPANfile", "name" : "Prereqs::FromCPANfile", "version" : "0.08" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "Readme", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::MakeMaker", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : "8" } }, "name" : "MakeMaker", "version" : "6.032" }, { "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.032" }, { "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.032" }, { "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", "HOTP", "IDNA", "ISBNs", "Koster", "Martijn", "Masinter", "Miyagawa", "OIDs", "OTP", "OpenLDAP", "Punycode", "TCP", "TLS", "TOTP", "Tatsuhiko", "UDP", "UNC", "cryptographic", "etype", "evalue", "hotp", "lon", "lowercasing", "relativize", "totp", "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.051" }, { "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.032" }, { "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.032" }, { "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.032" }, { "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.051" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "config" : { "Dist::Zilla::Plugin::Git::Tag" : { "branch" : null, "changelog" : "Changes", "signed" : 0, "tag" : "v5.30", "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.051" }, { "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.032" }, { "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.051" }, { "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.051" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "ConfirmRelease", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.032" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.032" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.032" } }, "x_contributors" : [ "Gisle Aas ", "Karen Etheridge ", "Olaf Alders ", "Chase Whitener ", "Julien Fiegehenn ", "Ville Skytt\u00e4 ", "Brendan Byrd ", "David Dick ", "Mark Stosberg ", "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 ", "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.38", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } URI-5.30/xt/0000775000175000017500000000000014701320657011166 5ustar olafolafURI-5.30/xt/author/0000775000175000017500000000000014701320657012470 5ustar olafolafURI-5.30/xt/author/portability.t0000644000175000017500000000013014701320657015207 0ustar olafolafuse strict; use warnings; use Test::More; use Test::Portability::Files; run_tests(); URI-5.30/xt/author/minimum-version.t0000644000175000017500000000015414701320657016011 0ustar olafolafuse strict; use warnings; use Test::More; use Test::MinimumVersion; all_minimum_version_from_metayml_ok(); URI-5.30/xt/author/distmeta.t0000644000175000017500000000022314701320657014462 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.30/xt/author/00-compile.t0000644000175000017500000000513214701320657014521 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 => 64; 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/ftpes.pm', 'URI/ftps.pm', 'URI/geo.pm', 'URI/gopher.pm', 'URI/http.pm', 'URI/https.pm', 'URI/icap.pm', 'URI/icaps.pm', 'URI/irc.pm', 'URI/ircs.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/otpauth.pm', 'URI/pop.pm', 'URI/rlogin.pm', 'URI/rsync.pm', 'URI/rtsp.pm', 'URI/rtspu.pm', 'URI/scp.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.30/xt/author/pod-coverage.t0000644000175000017500000001031114701320657015222 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::ftpes URI::ftps URI::irc URI::nntp URI::urn::isbn URI::urn::oid URI::scp 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|encrypt_mode)$/ ], '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.30/xt/author/pod-spell.t0000644000175000017500000000332514701320657014555 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 HOTP 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 OTP 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 TOTP 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 cryptographic data davewood ddick dependabot dorian ether etype evalue file foy ftp ftpes ftps geo gerard gianni gisle gopher gregoa gregor haarg hakon happy herrmann hiratara hotp http https icap icaps irc ircs 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 otpauth perlbotix piotr pop relativize ribasushi rlogin rsync rtsp rtspu ryker schwern scp sewi sftp simbabque sip sips skaji slaven snews ssh symkat telnet tn3270 torsten totp unicode uppercasing urn ville xn URI-5.30/xt/author/pod-syntax.t0000644000175000017500000000025214701320657014760 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.30/xt/author/mojibake.t0000644000175000017500000000015114701320657014431 0ustar olafolaf#!perl use strict; use warnings qw(all); use Test::More; use Test::Mojibake; all_files_encoding_ok(); URI-5.30/xt/author/test-version.t0000644000175000017500000000063714701320657015323 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.30/xt/dependent-modules.t0000644000175000017500000000050214701320657014762 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.30/META.yml0000644000175000017500000004427514701320657012016 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.032, 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.30' URI::Escape: file: lib/URI/Escape.pm version: '5.30' URI::Heuristic: file: lib/URI/Heuristic.pm version: '5.30' URI::IRI: file: lib/URI/IRI.pm version: '5.30' URI::QueryParam: file: lib/URI/QueryParam.pm version: '5.30' URI::Split: file: lib/URI/Split.pm version: '5.30' URI::URL: file: lib/URI/URL.pm version: '5.30' URI::WithBase: file: lib/URI/WithBase.pm version: '5.30' URI::data: file: lib/URI/data.pm version: '5.30' URI::file: file: lib/URI/file.pm version: '5.30' URI::file::Base: file: lib/URI/file/Base.pm version: '5.30' URI::file::FAT: file: lib/URI/file/FAT.pm version: '5.30' URI::file::Mac: file: lib/URI/file/Mac.pm version: '5.30' URI::file::OS2: file: lib/URI/file/OS2.pm version: '5.30' URI::file::QNX: file: lib/URI/file/QNX.pm version: '5.30' URI::file::Unix: file: lib/URI/file/Unix.pm version: '5.30' URI::file::Win32: file: lib/URI/file/Win32.pm version: '5.30' URI::ftp: file: lib/URI/ftp.pm version: '5.30' URI::ftpes: file: lib/URI/ftpes.pm version: '5.30' URI::ftps: file: lib/URI/ftps.pm version: '5.30' URI::geo: file: lib/URI/geo.pm version: '5.30' URI::gopher: file: lib/URI/gopher.pm version: '5.30' URI::http: file: lib/URI/http.pm version: '5.30' URI::https: file: lib/URI/https.pm version: '5.30' URI::icap: file: lib/URI/icap.pm version: '5.30' URI::icaps: file: lib/URI/icaps.pm version: '5.30' URI::irc: file: lib/URI/irc.pm version: '5.30' URI::ircs: file: lib/URI/ircs.pm version: '5.30' URI::ldap: file: lib/URI/ldap.pm version: '5.30' URI::ldapi: file: lib/URI/ldapi.pm version: '5.30' URI::ldaps: file: lib/URI/ldaps.pm version: '5.30' URI::mailto: file: lib/URI/mailto.pm version: '5.30' URI::mms: file: lib/URI/mms.pm version: '5.30' URI::news: file: lib/URI/news.pm version: '5.30' URI::nntp: file: lib/URI/nntp.pm version: '5.30' URI::nntps: file: lib/URI/nntps.pm version: '5.30' URI::otpauth: file: lib/URI/otpauth.pm version: '5.30' URI::pop: file: lib/URI/pop.pm version: '5.30' URI::rlogin: file: lib/URI/rlogin.pm version: '5.30' URI::rsync: file: lib/URI/rsync.pm version: '5.30' URI::rtsp: file: lib/URI/rtsp.pm version: '5.30' URI::rtspu: file: lib/URI/rtspu.pm version: '5.30' URI::scp: file: lib/URI/scp.pm version: '5.30' URI::sftp: file: lib/URI/sftp.pm version: '5.30' URI::sip: file: lib/URI/sip.pm version: '5.30' URI::sips: file: lib/URI/sips.pm version: '5.30' URI::snews: file: lib/URI/snews.pm version: '5.30' URI::ssh: file: lib/URI/ssh.pm version: '5.30' URI::telnet: file: lib/URI/telnet.pm version: '5.30' URI::tn3270: file: lib/URI/tn3270.pm version: '5.30' URI::urn: file: lib/URI/urn.pm version: '5.30' URI::urn::isbn: file: lib/URI/urn/isbn.pm version: '5.30' URI::urn::oid: file: lib/URI/urn/oid.pm version: '5.30' requires: Carp: '0' Cwd: '0' Data::Dumper: '0' Encode: '0' Exporter: '5.57' MIME::Base32: '0' 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.30' 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.051' - class: Dist::Zilla::Plugin::Encoding name: Encoding version: '6.032' - class: Dist::Zilla::Plugin::MetaConfig name: MetaConfig version: '6.032' - 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.032' 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.032' - class: Dist::Zilla::Plugin::MetaYAML name: MetaYAML version: '6.032' - class: Dist::Zilla::Plugin::MetaJSON name: MetaJSON version: '6.032' - class: Dist::Zilla::Plugin::MetaResources name: MetaResources version: '6.032' - 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.037' - class: Dist::Zilla::Plugin::GithubMeta name: GithubMeta version: '0.58' - class: Dist::Zilla::Plugin::Manifest name: Manifest version: '6.032' - class: Dist::Zilla::Plugin::License name: License version: '6.032' - class: Dist::Zilla::Plugin::ExecDir name: ExecDir version: '6.032' - class: Dist::Zilla::Plugin::Prereqs::FromCPANfile name: Prereqs::FromCPANfile version: '0.08' - class: Dist::Zilla::Plugin::Readme name: Readme version: '6.032' - class: Dist::Zilla::Plugin::MakeMaker config: Dist::Zilla::Role::TestRunner: default_jobs: '8' name: MakeMaker version: '6.032' - 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.032' - 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.032' - 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 - HOTP - IDNA - ISBNs - Koster - Martijn - Masinter - Miyagawa - OIDs - OTP - OpenLDAP - Punycode - TCP - TLS - TOTP - Tatsuhiko - UDP - UNC - cryptographic - etype - evalue - hotp - lon - lowercasing - relativize - totp - 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.051' - 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.032' - 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.032' - 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.032' - 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.051' - class: Dist::Zilla::Plugin::Git::Tag config: Dist::Zilla::Plugin::Git::Tag: branch: ~ changelog: Changes signed: 0 tag: v5.30 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.051' - 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.032' - 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.051' - 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.051' - class: Dist::Zilla::Plugin::ConfirmRelease name: ConfirmRelease version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':ExtraTestFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':PerlExecFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':AllFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: ':NoFiles' version: '6.032' - class: Dist::Zilla::Plugin::FinderCode name: MetaProvides::Package/AUTOVIV/:InstallModulesPM version: '6.032' zilla: class: Dist::Zilla::Dist::Builder config: is_trial: '0' version: '6.032' x_contributors: - 'Gisle Aas ' - 'Karen Etheridge ' - 'Olaf Alders ' - 'Chase Whitener ' - 'Julien Fiegehenn ' - 'Ville Skyttä ' - 'Brendan Byrd ' - 'David Dick ' - 'Mark Stosberg ' - '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 ' - '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.30/lib/0000775000175000017500000000000014701320657011301 5ustar olafolafURI-5.30/lib/URI.pm0000644000175000017500000012266214701320657012305 0ustar olafolafpackage URI; use strict; use warnings; our $VERSION = '5.30'; # 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. It also supports accessing to the encryption mode ($uri->encrypt_mode), which has its own defaults for I and I URI schemes. =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 L. The scheme is used to reference IRC servers and their resources. C objects belonging to the irc or ircs scheme support login methods, and the following IRC-specific ones: $uri->entity, $uri->flags, $uri->options. =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 L. The scheme is used to encode secret keys for use in TOTP or HOTP schemes. C objects belonging to the otpauth scheme support the common methods. =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.30/lib/URI/0000775000175000017500000000000014701320657011740 5ustar olafolafURI-5.30/lib/URI/_server.pm0000644000175000017500000000745614701320657013755 0ustar olafolafpackage URI::_server; use strict; use warnings; use parent 'URI::_generic'; use URI::Escape qw(uri_unescape); our $VERSION = '5.30'; 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.30/lib/URI/Escape.pm0000644000175000017500000001735314701320657013505 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.30'; 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.30/lib/URI/snews.pm0000644000175000017500000000025414701320657013434 0ustar olafolafpackage URI::snews; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::news'; sub default_port { 563 } sub secure { 1 } 1; URI-5.30/lib/URI/URL.pm0000644000175000017500000001255714701320657012750 0ustar olafolafpackage URI::URL; use strict; use warnings; use parent 'URI::WithBase'; our $VERSION = '5.30'; # 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.30/lib/URI/ldaps.pm0000644000175000017500000000022014701320657013371 0ustar olafolafpackage URI::ldaps; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::ldap'; sub default_port { 636 } sub secure { 1 } 1; URI-5.30/lib/URI/rlogin.pm0000644000175000017500000000020114701320657013557 0ustar olafolafpackage URI::rlogin; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::_login'; sub default_port { 513 } 1; URI-5.30/lib/URI/_generic.pm0000644000175000017500000001524514701320657014056 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.30'; 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.30/lib/URI/IRI.pm0000644000175000017500000000143214701320657012717 0ustar olafolafpackage URI::IRI; # Experimental use strict; use warnings; use URI (); use overload '""' => sub { shift->as_string }; our $VERSION = '5.30'; 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.30/lib/URI/ldap.pm0000644000175000017500000000555414701320657013225 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.30'; 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.30/lib/URI/scp.pm0000644000175000017500000000014114701320657013055 0ustar olafolafpackage URI::scp; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::ssh'; 1; URI-5.30/lib/URI/_query.pm0000644000175000017500000001136714701320657013610 0ustar olafolafpackage URI::_query; use strict; use warnings; use URI (); use URI::Escape qw(uri_unescape); use Scalar::Util (); our $VERSION = '5.30'; 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.30/lib/URI/urn/0000775000175000017500000000000014701320657012544 5ustar olafolafURI-5.30/lib/URI/urn/isbn.pm0000644000175000017500000000474414701320657014044 0ustar olafolafpackage URI::urn::isbn; # RFC 3187 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/urn/oid.pm0000644000175000017500000000043314701320657013653 0ustar olafolafpackage URI::urn::oid; # RFC 2061 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/Heuristic.pm0000644000175000017500000001457714701320657014251 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.30'; 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.30/lib/URI/news.pm0000644000175000017500000000265614701320657013261 0ustar olafolafpackage URI::news; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/https.pm0000644000175000017500000000022014701320657013430 0ustar olafolafpackage URI::https; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::http'; sub default_port { 443 } sub secure { 1 } 1; URI-5.30/lib/URI/_idna.pm0000644000175000017500000000403714701320657013352 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.30'; 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.30/lib/URI/ldapi.pm0000644000175000017500000000067014701320657013370 0ustar olafolafpackage URI::ldapi; use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/mailto.pm0000644000175000017500000000317114701320657013563 0ustar olafolafpackage URI::mailto; # RFC 2368 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/ssh.pm0000644000175000017500000000025714701320657013075 0ustar olafolafpackage URI::ssh; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::_login'; # ssh://[USER@]HOST[:PORT]/SRC sub default_port { 22 } sub secure { 1 } 1; URI-5.30/lib/URI/_foreign.pm0000644000175000017500000000015314701320657014063 0ustar olafolafpackage URI::_foreign; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.30'; 1; URI-5.30/lib/URI/Split.pm0000644000175000017500000000446114701320657013374 0ustar olafolafpackage URI::Split; use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/rsync.pm0000644000175000017500000000031714701320657013433 0ustar olafolafpackage URI::rsync; # http://rsync.samba.org/ # rsync://[USER@]HOST[:PORT]/SRC use strict; use warnings; our $VERSION = '5.30'; use parent qw(URI::_server URI::_userpass); sub default_port { 873 } 1; URI-5.30/lib/URI/file.pm0000644000175000017500000002273114701320657013220 0ustar olafolafpackage URI::file; use strict; use warnings; use parent 'URI::_generic'; our $VERSION = '5.30'; 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.30/lib/URI/icaps.pm0000644000175000017500000000264214701320657013377 0ustar olafolafpackage URI::icaps; use strict; use warnings; use base qw(URI::icap); our $VERSION = '5.30'; 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.30/lib/URI/geo.pm0000644000175000017500000002500214701320657013045 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.30'; 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.30/lib/URI/mms.pm0000644000175000017500000000017514701320657013073 0ustar olafolafpackage URI::mms; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::http'; sub default_port { 1755 } 1; URI-5.30/lib/URI/tn3270.pm0000644000175000017500000000020014701320657013221 0ustar olafolafpackage URI::tn3270; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::_login'; sub default_port { 23 } 1; URI-5.30/lib/URI/data.pm0000644000175000017500000000647614701320657013222 0ustar olafolafpackage URI::data; # RFC 2397 use strict; use warnings; use parent 'URI'; our $VERSION = '5.30'; 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.30/lib/URI/WithBase.pm0000644000175000017500000000742614701320657014013 0ustar olafolafpackage URI::WithBase; use strict; use warnings; use URI (); use Scalar::Util qw(blessed); our $VERSION = '5.30'; 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.30/lib/URI/sftp.pm0000644000175000017500000000014214701320657013245 0ustar olafolafpackage URI::sftp; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::ssh'; 1; URI-5.30/lib/URI/sips.pm0000644000175000017500000000021714701320657013252 0ustar olafolafpackage URI::sips; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::sip'; sub default_port { 5061 } sub secure { 1 } 1; URI-5.30/lib/URI/_userpass.pm0000644000175000017500000000201714701320657014300 0ustar olafolafpackage URI::_userpass; use strict; use warnings; use URI::Escape qw(uri_unescape); our $VERSION = '5.30'; 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.30/lib/URI/nntp.pm0000644000175000017500000000017714701320657013260 0ustar olafolafpackage URI::nntp; # draft-gilman-news-url-01 use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::news'; 1; URI-5.30/lib/URI/pop.pm0000644000175000017500000000226714701320657013101 0ustar olafolafpackage URI::pop; # RFC 2384 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/ftps.pm0000644000175000017500000000025714701320657013254 0ustar olafolafpackage URI::ftps; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::ftp'; sub default_port { 990 } sub secure { 1 } sub encrypt_mode { 'implicit' } 1; URI-5.30/lib/URI/ftpes.pm0000644000175000017500000000022614701320657013415 0ustar olafolafpackage URI::ftpes; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::ftp'; sub secure { 1 } sub encrypt_mode { 'explicit' } 1; URI-5.30/lib/URI/ircs.pm0000644000175000017500000000021614701320657013233 0ustar olafolafpackage URI::ircs; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::irc'; sub default_port { 994 } sub secure { 1 } 1; URI-5.30/lib/URI/icap.pm0000644000175000017500000000272714701320657013220 0ustar olafolafpackage URI::icap; use strict; use warnings; use base qw(URI::http); our $VERSION = '5.30'; 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.30/lib/URI/telnet.pm0000644000175000017500000000020014701320657013557 0ustar olafolafpackage URI::telnet; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::_login'; sub default_port { 23 } 1; URI-5.30/lib/URI/_ldap.pm0000644000175000017500000000626114701320657013360 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.30'; 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.30/lib/URI/_punycode.pm0000644000175000017500000001300014701320657014253 0ustar olafolafpackage URI::_punycode; use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/irc.pm0000644000175000017500000000722414701320657013056 0ustar olafolafpackage URI::irc; # draft-butcher-irc-url-04 use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::_login'; use overload ( '""' => sub { $_[0]->as_string }, '==' => sub { URI::_obj_eq(@_) }, '!=' => sub { !URI::_obj_eq(@_) }, fallback => 1, ); sub default_port { 6667 } # ircURL = ircURI "://" location "/" [ entity ] [ flags ] [ options ] # ircURI = "irc" / "ircs" # location = [ authinfo "@" ] hostport # authinfo = [ username ] [ ":" password ] # username = *( escaped / unreserved ) # password = *( escaped / unreserved ) [ ";" passtype ] # passtype = *( escaped / unreserved ) # entity = [ "#" ] *( escaped / unreserved ) # flags = ( [ "," enttype ] [ "," hosttype ] ) # /= ( [ "," hosttype ] [ "," enttype ] ) # enttype = "," ( "isuser" / "ischannel" ) # hosttype = "," ( "isserver" / "isnetwork" ) # options = "?" option *( "&" option ) # option = optname [ "=" optvalue ] # optname = *( ALPHA / "-" ) # optvalue = optparam *( "," optparam ) # optparam = *( escaped / unreserved ) # XXX: Technically, passtype is part of the protocol, but is rarely used and # not defined in the RFC beyond the URL ABNF. # Starting the entity with /# is okay per spec, but it needs to be encoded to # %23 for the URL::_generic::path operations to parse correctly. sub _init { my $class = shift; my $self = $class->SUPER::_init(@_); $$self =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/\#|$1/%23|s; $self; } # Return the /# form, since this is most common for channel names. sub path { my $self = shift; my ($new) = @_; $new =~ s|^/\#|/%23| if (@_ && defined $new); my $val = $self->SUPER::path(@_ ? $new : ()); $val =~ s|^/%23|/\#|; $val; } sub path_query { my $self = shift; my ($new) = @_; $new =~ s|^/\#|/%23| if (@_ && defined $new); my $val = $self->SUPER::path_query(@_ ? $new : ()); $val =~ s|^/%23|/\#|; $val; } sub as_string { my $self = shift; my $val = $self->SUPER::as_string; $val =~ s|^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)/%23|$1/\#|s; $val; } sub entity { my $self = shift; my $path = $self->path; $path =~ s|^/||; my ($entity, @flags) = split /,/, $path; if (@_) { my $new = shift; $new = '' unless defined $new; $self->path( '/'.join(',', $new, @flags) ); } return unless length $entity; $entity; } sub flags { my $self = shift; my $path = $self->path; $path =~ s|^/||; my ($entity, @flags) = split /,/, $path; if (@_) { $self->path( '/'.join(',', $entity, @_) ); } @flags; } sub options { shift->query_form(@_) } sub canonical { my $self = shift; my $other = $self->SUPER::canonical; # Clean up the flags my $path = $other->path; $path =~ s|^/||; my ($entity, @flags) = split /,/, $path; my @clean = map { $_ eq 'isnick' ? 'isuser' : $_ } # convert isnick->isuser map { lc } # NOTE: Allow flags from draft-mirashi-url-irc-01 as well grep { /^(?:is(?:user|channel|server|network|nick)|need(?:pass|key))$/i } @flags ; # Only allow the first type of each category, per the Butcher draft my ($enttype) = grep { /^is(?:user|channel)$/ } @clean; my ($hosttype) = grep { /^is(?:server|network)$/ } @clean; my @others = grep { /^need(?:pass|key)$/ } @clean; my @new = ( $enttype ? $enttype : (), $hosttype ? $hosttype : (), @others, ); unless (join(',', @new) eq join(',', @flags)) { $other = $other->clone if $other == $self; $other->path( '/'.join(',', $entity, @new) ); } $other; } 1; URI-5.30/lib/URI/gopher.pm0000644000175000017500000000457414701320657013572 0ustar olafolafpackage URI::gopher; # , Dec 4, 1996 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/rtsp.pm0000644000175000017500000000017514701320657013267 0ustar olafolafpackage URI::rtsp; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::http'; sub default_port { 554 } 1; URI-5.30/lib/URI/_segment.pm0000644000175000017500000000064014701320657014075 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.30'; sub new { my $class = shift; my @segment = split(';', shift, -1); $segment[0] = uri_unescape($segment[0]); bless \@segment, $class; } 1; URI-5.30/lib/URI/_login.pm0000644000175000017500000000034714701320657013547 0ustar olafolafpackage URI::_login; use strict; use warnings; use parent qw(URI::_server URI::_userpass); our $VERSION = '5.30'; # Generic terminal logins. This is used as a base class for 'telnet', # 'tn3270', and 'rlogin' URL schemes. 1; URI-5.30/lib/URI/rtspu.pm0000644000175000017500000000017614701320657013455 0ustar olafolafpackage URI::rtspu; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::rtsp'; sub default_port { 554 } 1; URI-5.30/lib/URI/QueryParam.pm0000644000175000017500000000121714701320657014363 0ustar olafolafpackage URI::QueryParam; use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/http.pm0000644000175000017500000000065114701320657013255 0ustar olafolafpackage URI::http; use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/file/0000775000175000017500000000000014701320657012657 5ustar olafolafURI-5.30/lib/URI/file/Base.pm0000644000175000017500000000271514701320657014072 0ustar olafolafpackage URI::file::Base; use strict; use warnings; use URI::Escape (); our $VERSION = '5.30'; 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.30/lib/URI/file/OS2.pm0000644000175000017500000000106114701320657013614 0ustar olafolafpackage URI::file::OS2; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.30'; # 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.30/lib/URI/file/FAT.pm0000644000175000017500000000076114701320657013631 0ustar olafolafpackage URI::file::FAT; use strict; use warnings; use parent 'URI::file::Win32'; our $VERSION = '5.30'; 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.30/lib/URI/file/QNX.pm0000644000175000017500000000052114701320657013657 0ustar olafolafpackage URI::file::QNX; use strict; use warnings; use parent 'URI::file::Unix'; our $VERSION = '5.30'; 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.30/lib/URI/file/Mac.pm0000644000175000017500000000466514701320657013726 0ustar olafolafpackage URI::file::Mac; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.30'; 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.30/lib/URI/file/Unix.pm0000644000175000017500000000177614701320657014151 0ustar olafolafpackage URI::file::Unix; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.30'; 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.30/lib/URI/file/Win32.pm0000644000175000017500000000333514701320657014121 0ustar olafolafpackage URI::file::Win32; use strict; use warnings; use parent 'URI::file::Base'; use URI::Escape qw(uri_unescape); our $VERSION = '5.30'; 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.30/lib/URI/sip.pm0000644000175000017500000000320614701320657013070 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.30'; 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.30/lib/URI/nntps.pm0000644000175000017500000000022014701320657013430 0ustar olafolafpackage URI::nntps; use strict; use warnings; our $VERSION = '5.30'; use parent 'URI::nntp'; sub default_port { 563 } sub secure { 1 } 1; URI-5.30/lib/URI/urn.pm0000644000175000017500000000403514701320657013102 0ustar olafolafpackage URI::urn; # RFC 2141 use strict; use warnings; our $VERSION = '5.30'; 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.30/lib/URI/otpauth.pm0000644000175000017500000002047514701320657013770 0ustar olafolafpackage URI::otpauth; use warnings; use strict; use MIME::Base32(); use URI::Split(); use URI::Escape(); use parent qw( URI URI::_query ); our $VERSION = '5.30'; sub new { my ($class, @parameters) = @_; my %fields = $class->_set(@parameters); my $uri = URI::Split::uri_join( 'otpauth', $fields{type}, $class->_path(%fields), $class->_query(%fields), ); return bless \$uri, $class; } sub _parse { my $self = shift; my ($scheme, $type, $path, $query, $frag) = URI::Split::uri_split(${$self}); $path =~ s/^\///smxg; my @path_parts = split /:/smx, $path; my ($issuer_prefix, $account_name); if (scalar @path_parts == 1) { $account_name = $path_parts[0]; } else { $issuer_prefix = $path_parts[0]; $account_name = $path_parts[1]; } my %fields = (label => $path, type => $type, account_name => $account_name); my $issuer_parameter = $self->query_param('issuer'); if (defined $issuer_parameter) { if ((defined $issuer_prefix) && ($issuer_prefix ne $issuer_parameter)) { Carp::carp( "Issuer prefix from label '$issuer_prefix' does not match issuer parameter '$issuer_parameter'" ); } $fields{issuer} = $issuer_parameter; } elsif (defined $issuer_prefix) { $fields{issuer} = URI::Escape::uri_unescape($issuer_prefix); } if (my $encoded_secret = $self->query_param('secret')) { $fields{secret} = MIME::Base32::decode_base32($encoded_secret); } foreach my $name (qw(algorithm digits counter period)) { if (my $value = $self->query_param($name)) { $fields{$name} = $value; } } %fields = $self->_set(%fields); return ($scheme, $fields{type}, \%fields, $query, $frag); } my $label_escape_regex = qr/[^[:alnum:]@.]/smx; sub _set { my ($self, %fields) = @_; delete $fields{label}; if (defined $fields{account_name}) { if (defined $fields{issuer}) { $fields{label} = $fields{issuer} . q[:] . $fields{account_name}; } else { $fields{label} = $fields{account_name}; } } if (!length $fields{type}) { $fields{type} = 'totp'; } return %fields; } my %field_names = map { $_ => 1 } qw(secret label counter algorithm period digits issuer type account_name); my @query_names = qw(secret issuer algorithm digits counter period); my %defaults = (algorithm => 'SHA1', digits => 6, type => 'totp', period => 30); sub _field { my ($self, $name, @remainder) = @_; my ($scheme, $type, $fields, $query, $frag) = $self->_parse(); if (!@remainder) { if (defined $fields->{$name}) { return $fields->{$name}; } else { return $defaults{$name}; } } $fields->{$name} = shift @remainder; ${$self} = URI::Split::uri_join( $scheme, $fields->{type}, $self->_path(%{$fields}), $self->_query(%{$fields}), $frag ); return $self; } sub _query { my ($class, %fields) = @_; if (defined $fields{secret}) { $fields{secret} = MIME::Base32::encode_base32($fields{secret}); } else { Carp::croak('secret is a mandatory parameter for ' . __PACKAGE__); } return join q[&], map { join q[=], $_ => $fields{$_} } grep { exists $fields{$_} } @query_names; } sub _path { my ($class, %fields) = @_; my $path = $fields{label}; return $path; } sub type { my ($self, @parameters) = @_; return $self->_field('type', @parameters); } sub label { my ($self, @parameters) = @_; return $self->_field('label', @parameters); } sub account_name { my ($self, @parameters) = @_; return $self->_field('account_name', @parameters); } sub issuer { my ($self, @parameters) = @_; return $self->_field('issuer', @parameters); } sub secret { my ($self, @parameters) = @_; return $self->_field('secret', @parameters); } sub algorithm { my ($self, @parameters) = @_; return $self->_field('algorithm', @parameters); } sub counter { my ($self, @parameters) = @_; return $self->_field('counter', @parameters); } sub digits { my ($self, @parameters) = @_; return $self->_field('digits', @parameters); } sub period { my ($self, @parameters) = @_; return $self->_field('period', @parameters); } 1; __END__ =head1 NAME URI::otpauth - URI scheme for secret keys for OTP secrets. Usually found in QR codes =head1 VERSION Version 5.29 =head1 SYNOPSIS use URI; # optauth URI from textual uri my $uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=NFZS25DINFZV643VOAZXELLTGNRXEM3UH4&issuer=Example' ); # same URI but created from arguments my $uri = URI::otpauth->new( type => 'totp', issuer => 'Example', account_name => 'alice@google.com', secret => 'is-this_sup3r-s3cr3t?' ); =head1 DESCRIPTION This URI scheme is defined in L: =head1 SUBROUTINES/METHODS =head2 C<< new >> Create a new URI::otpauth. The available arguments are listed below; =over =item * account_name - this can be the account name (probably an email address) used when authenticating with this secret. It is an optional field. =item * algorithm - this is the L that should be used. Current values are L, L or L. It is an optional field and will default to SHA1. =item * counter - this is only required when the type is HOTP. =item * digits - this determines the L of the code presented to the user. It is an optional field and will default to 6 digits. =item * issuer - this can be the L that this secret can be used to authenticate to. It is an optional field. =item * label - this is the L joined with a ":" character. It is an optional field. =item * period - this is the L. It is an optional field and will default to 30 seconds. =item * secret - this is the L that the L/L algorithm uses to derive the value. It is an arbitrary byte string and must remain private. This field is mandatory. =item * type - this can be 'L' or 'L'. This field will default to 'totp'. =back =head2 C Get or set the algorithm of this otpauth URI. =head2 C Get or set the account_name of this otpauth URI. =head2 C Get or set the counter of this otpauth URI. =head2 C Get or set the digits of this otpauth URI. =head2 C Get or set the issuer of this otpauth URI. =head2 C