pkg://perl-URI-1.30-4.src.rpm:97732/URI-1.30.tar.gz
info downloads
URI-1.30/ 0040755 0000764 0000764 00000000000 10001246221 011064 5 ustar gisle gisle URI-1.30/t/ 0040755 0000764 0000764 00000000000 10001246222 011330 5 ustar gisle gisle URI-1.30/t/ldap.t 0100644 0000764 0000764 00000006320 07775127664 012473 0 ustar gisle gisle #!perl -w
print "1..22\n";
use strict;
use URI;
my $uri;
$uri = URI->new("ldap://host/dn=base?cn,sn?sub?objectClass=*");
print "not " unless $uri->host eq "host";
print "ok 1\n";
print "not " unless $uri->dn eq "dn=base";
print "ok 2\n";
print "not " unless join("-",$uri->attributes) eq "cn-sn";
print "ok 3\n";
print "not " unless $uri->scope eq "sub";
print "ok 4\n";
print "not " unless $uri->filter eq "objectClass=*";
print "ok 5\n";
$uri = URI->new("ldap:");
$uri->dn("o=University of Michigan,c=US");
print "not " unless "$uri" eq "ldap:o=University%20of%20Michigan,c=US" &&
$uri->dn eq "o=University of Michigan,c=US";
print "ok 6\n";
$uri->host("ldap.itd.umich.edu");
print "not " unless $uri->as_string eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US";
print "ok 7\n";
# check defaults
print "not " unless $uri->_scope eq "" &&
$uri->scope eq "base" &&
$uri->_filter eq "" &&
$uri->filter eq "(objectClass=*)";
print "ok 8\n";
# attribute
$uri->attributes("postalAddress");
print "not " unless $uri eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US?postalAddress";
print "ok 9\n";
# does attribute escapeing work as it should
$uri->attributes($uri->attributes, "foo", ",", "*", "?", "#", "\0");
print "not " unless $uri->attributes eq "postalAddress,foo,%2C,*,%3F,%23,%00" &&
join("-", $uri->attributes) eq "postalAddress-foo-,-*-?-#-\0";
print "ok 10\n";
$uri->attributes("");
$uri->scope("sub?#");
print "not " unless $uri->query eq "?sub%3F%23" &&
$uri->scope eq "sub?#";
print "ok 11\n";
$uri->scope("");
$uri->filter("f=?,#");
print "not " unless $uri->query eq "??f=%3F,%23" &&
$uri->filter eq "f=?,#";
$uri->filter("(int=\\00\\00\\00\\04)");
print "not " unless $uri->query eq "??(int=%5C00%5C00%5C00%5C04)";
print "ok 12\n";
print "ok 13\n";
$uri->filter("");
$uri->extensions("!bindname" => "cn=Manager,co=Foo");
my %ext = $uri->extensions;
print "not " unless $uri->query eq "???!bindname=cn=Manager%2Cco=Foo" &&
keys %ext == 1 &&
$ext{"!bindname"} eq "cn=Manager,co=Foo";
print "ok 14\n";
$uri = URI->new("ldap://LDAP-HOST:389/o=University%20of%20Michigan,c=US?postalAddress?base?ObjectClass=*?FOO=Bar,bindname=CN%3DManager%CO%3dFoo");
print "not " unless $uri->canonical eq "ldap://ldap-host/o=University%20of%20Michigan,c=US?postaladdress???foo=Bar,bindname=CN=Manager%CO=Foo";
print "ok 15\n";
print "$uri\n";
print $uri->canonical, "\n";
$uri = URI->new("ldaps://host/dn=base?cn,sn?sub?objectClass=*");
print "not " unless $uri->host eq "host";
print "ok 16\n";
print "not " unless $uri->port eq 636;
print "ok 17\n";
print "not " unless $uri->dn eq "dn=base";
print "ok 18\n";
$uri = URI->new("ldapi://%2Ftmp%2Fldap.sock/????x-mod=-w--w----");
print "not " unless $uri->authority eq "%2Ftmp%2Fldap.sock";
print "ok 19\n";
print "not " unless $uri->un_path eq "/tmp/ldap.sock";
print "ok 20\n";
$uri->un_path("/var/x\@foo:bar/");
print "not " unless $uri eq "ldapi://%2Fvar%2Fx%40foo%3Abar%2F/????x-mod=-w--w----";
print "ok 21\n";
%ext = $uri->extensions;
print "not " unless $ext{"x-mod"} eq "-w--w----";
print "ok 22\n";
URI-1.30/t/rsync.t 0100644 0000764 0000764 00000000567 07713746365 012715 0 ustar gisle gisle #!perl -w
print "1..4\n";
use strict;
use URI;
my $u = URI->new('rsync://gisle@perl.com/foo/bar');
print "not " unless $u->user eq "gisle";
print "ok 1\n";
print "not " unless $u->port eq 873;
print "ok 2\n";
print "not " unless $u->path eq "/foo/bar";
print "ok 3\n";
$u->port(8730);
print "not " unless $u eq 'rsync://gisle@perl.com:8730/foo/bar';
print "ok 4\n";
URI-1.30/t/clone.t 0100644 0000764 0000764 00000000577 07713746365 012660 0 ustar gisle gisle #!perl -w
print "1..2\n";
use strict;
use URI::URL;
my $b = URI::URL->new("http://www/");
my $u1 = URI::URL->new("foo", $b);
my $u2 = $u1->clone;
$u1->base("http://yyy/");
#use Data::Dump; Data::Dump::dump($b, $u1, $u2);
print "not " unless $u1->abs->as_string eq "http://yyy/foo";
print "ok 1\n";
print "not " unless $u2->abs->as_string eq "http://www/foo";
print "ok 2\n";
URI-1.30/t/pop.t 0100644 0000764 0000764 00000002177 07713746365 012354 0 ustar gisle gisle #!perl -w
print "1..8\n";
use URI;
$u = URI->new('pop://aas@pop.sn.no');
print "not " unless $u->user eq "aas" &&
!defined($u->auth) &&
$u->host eq "pop.sn.no" &&
$u->port == 110 &&
$u eq 'pop://aas@pop.sn.no';
print "ok 1\n";
$u->auth("+APOP");
print "not " unless $u->auth eq "+APOP" &&
$u eq 'pop://aas;AUTH=+APOP@pop.sn.no';
print "ok 2\n";
$u->user("gisle");
print "not " unless $u->user eq "gisle" &&
$u eq 'pop://gisle;AUTH=+APOP@pop.sn.no';
print "ok 3\n";
$u->port(4000);
print "not " unless $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no:4000';
print "ok 4\n";
$u = URI->new("pop:");
$u->host("pop.sn.no");
$u->user("aas");
$u->auth("*");
print "not " unless $u eq 'pop://aas;AUTH=*@pop.sn.no';
print "ok 5\n";
$u->auth(undef);
print "not " unless $u eq 'pop://aas@pop.sn.no';
print "ok 6\n";
$u->user(undef);
print "not " unless $u eq 'pop://pop.sn.no';
print "ok 7\n";
# Try some funny characters too
$u->user('får;k@l');
print "not " unless $u->user eq 'får;k@l' &&
$u eq 'pop://f%E5r%3Bk%40l@pop.sn.no';
print "ok 8\n";
URI-1.30/t/heuristic.t 0100644 0000764 0000764 00000005043 07713746365 013550 0 ustar gisle gisle #!perl -w
if (-f "OFFLINE") {
print "1..0";
exit;
}
print "1..15\n";
use URI::Heuristic qw(uf_urlstr uf_url);
if (shift) {
$URI::Heuristic::DEBUG++;
open(STDERR, ">&STDOUT"); # redirect STDERR
}
print "not " unless uf_urlstr("http://www.sn.no/") eq "http://www.sn.no/";
print "ok 1\n";
if ($^O eq "MacOS") {
print "not " unless uf_urlstr("etc:passwd") eq "file:/etc/passwd";
} else {
print "not " unless uf_urlstr("/etc/passwd") eq "file:/etc/passwd";
}
print "ok 2\n";
if ($^O eq "MacOS") {
print "not " unless uf_urlstr(":foo.txt") eq "file:./foo.txt";
} else {
print "not " unless uf_urlstr("./foo.txt") eq "file:./foo.txt";
}
print "ok 3\n";
print "not " unless uf_urlstr("ftp.aas.no/lwp.tar.gz") eq "ftp://ftp.aas.no/lwp.tar.gz";
print "ok 4\n";
if($^O eq "MacOS") {
# its a weird, but valid, MacOS path, so it can't be left alone
print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:/C/%5CCONFIG.SYS";
} else {
print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:C:\\CONFIG.SYS";
}
print "ok 5\n";
if (gethostbyname("www.netscape.com")) {
# DNS probably work, lets run test 6..8
$URI::Heuristic::MY_COUNTRY = "bv";
print "not " unless uf_urlstr("perl/camel.gif") eq "http://www.perl.com/camel.gif";
print "ok 6\n";
$URI::Heuristic::MY_COUNTRY = "uk";
print "not " unless uf_urlstr("perl/camel.gif") eq "http://www.perl.co.uk/camel.gif";
print "ok 7\n";
$ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com";
print "not " unless uf_urlstr("perl") eq "http://www.perl.org";
print "ok 8\n";
} else {
# don't make the inocent worry
print "Skipping test 6-8 because DNS does not work\n";
for (6..8) { print "ok $_\n"; }
}
{
local $ENV{URL_GUESS_PATTERN} = "";
print "not " unless uf_urlstr("perl") eq "http://perl";
print "ok 9\n";
print "not " unless uf_urlstr("http:80") eq "http:80";
print "ok 10\n";
print "not " unless uf_urlstr("mailto:gisle\@aas.no") eq "mailto:gisle\@aas.no";
print "ok 11\n";
print "not " unless uf_urlstr("gisle\@aas.no") eq "mailto:gisle\@aas.no";
print "ok 12\n";
print "not " unless uf_urlstr("Gisle.Aas\@aas.perl.org") eq "mailto:Gisle.Aas\@aas.perl.org";
print "ok 13\n";
print "not " unless uf_url("gopher.sn.no")->scheme eq "gopher";
print "ok 14\n";
print "not " unless uf_urlstr("123.3.3.3:8080/foo") eq "http://123.3.3.3:8080/foo";
print "ok 15\n";
}
#
#print "not " unless uf_urlstr("some-site") eq "http://www.some-site.com";
#print "ok 15\n";
#
#print "not " unless uf_urlstr("some-site.com") eq "http://some-site.com";
#print "ok 16\n";
#
URI-1.30/t/roytest2.html 0100644 0000764 0000764 00000007074 06576171500 014040 0 ustar gisle gisle <HTML><HEAD>
<TITLE>Examples of Resolving Relative URLs, Part 2</TITLE>
<BASE href="http://a/b/c/d;p?q=1/2">
</HEAD><BODY>
<H1>Examples of Resolving Relative URLs, Part 2</H1>
This document has an embedded base URL of
<PRE>
Content-Base: http://a/b/c/d;p?q=1/2
</PRE>
the relative URLs should be resolved as shown below. In this test page,
I am particularly interested in testing whether "/" in query information
is or is not treated as part of the path hierarchy.
<P>
I will need your help testing the examples on multiple browsers.
What you need to do is point to the example anchor and compare it to the
resolved URL in your browser (most browsers have a feature by which you
can see the resolved URL at the bottom of the window/screen when the anchor
is active).
<H2>Tested Clients and Client Libraries</H2>
<DL COMPACT>
<DT>[R]
<DD>RFC 2396 (the right way to parse)
<DT>[X]
<DD>RFC 1808
<DT>[1]
<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
<DT>[2]
<DD>Lynx/2.7.1 libwww-FM/2.14
<DT>[3]
<DD>MSIE 3.01; Windows 95
<DT>[4]
<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
</DL>
<H3>Synopsis</H3>
RFC 1808 specified that the "/" character within query information
does not affect the hierarchy within URL parsing. It would appear that
it does in current practice, but only within the relative path after
it is attached to the base path. In other words, the base URL's query
information is being stripped off before any relative resolution, but
some parsers fail to separate the query information from the relative
path.<P>
We have decided that this behavior is due to an oversight in the original
libwww implementation, and it is better to correct the oversight in future
parsers than it is to make a nonsensical standard. A note has been added
to the URI draft to account for the differences in implementations. This should
have no impact on current practice since unescaped "/" is rarely (if ever)
used within the query part of a URL, and query parts themselves are rarely
used with relative URLs.
<H2>Examples</H2>
<PRE>
RESULTS from
<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4]
<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4]
<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4]
<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4]
<a href="//g">//g</a> = http://g [R,X,1,2,3,4]
<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4]
http://a/b/c/d;p?y [X]
<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4]
<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X]
http://a/b/c/g?y/x [1,2,3,4]
<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X]
http://a/b/c/x [1,2,3,4]
<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4]
<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4]
http://a/b/c/g#s/x [1]
<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4]
http://a/b/c/x [1]
<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4]
<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4]
<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4]
<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4]
<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4]
</PRE>
</BODY></HTML>
URI-1.30/t/old-base.t 0100644 0000764 0000764 00000101075 07732612562 013231 0 ustar gisle gisle #!/local/bin/perl -w
use URI::URL qw(url);
use URI::Escape qw(uri_escape uri_unescape);
# _expect()
#
# Handy low-level object method tester which we insert as a method
# in the URI::URL class
#
sub URI::URL::_expect {
my($self, $method, $expect, @args) = @_;
my $result = $self->$method(@args);
$expect = 'UNDEF' unless defined $expect;
$result = 'UNDEF' unless defined $result;
return 1 if $expect eq $result;
warn "'$self'->$method(@args) = '$result' " .
"(expected '$expect')\n";
$self->print_on('STDERR');
die "Test Failed";
}
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($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})#;
print "Turn lib path $x into $pwd/$x\n";
$_ = "$pwd/$x";
}
}
$| = 1;
print "1..8\n"; # for Test::Harness
# Do basic tests first.
# Dies if an error has been detected, prints "ok" otherwise.
print "Self tests for URI::URL version $URI::URL::VERSION...\n";
eval { scheme_parse_test(); };
print "not " if $@;
print "ok 1\n";
eval { parts_test(); };
print "not " if $@;
print "ok 2\n";
eval { escape_test(); };
print "not " if $@;
print "ok 3\n";
eval { newlocal_test(); };
print "not " if $@;
print "ok 4\n";
eval { absolute_test(); };
print "not " if $@;
print "ok 5\n";
eval { eq_test(); };
print "not " if $@;
print "ok 6\n";
# Let's test making our own things
URI::URL::strict(0);
# This should work after URI::URL::strict(0)
$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
$url->_expect('as_string' => 'x-myscheme:something');
$url->_expect('path' => 'something');
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';
$url->_expect('as_string', 'x-a+b.c://foo/bar;a?b');
$url->_expect('path', '/bar;a?b');
$url->foo;
$newurl = new URI::URL 'xxx', $url;
$newurl->foo;
$url = new URI::URL 'yyy', 'x-foo:';
$url->foo;
=cut
print "ok 7\n";
# Test the new wash&go constructor
print "not " if url("../foo.html", "http://www.sn.no/a/b")->abs->as_string
ne 'http://www.sn.no/foo.html';
print "ok 8\n";
print "URI::URL version $URI::URL::VERSION ok\n";
exit 0;
#####################################################################
#
# scheme_parse_test()
#
# test parsing and retrieval methods
sub scheme_parse_test {
print "scheme_parse_test:\n";
$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?g/fseg',
'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 $url_str (sort keys %$tests ){
print "Testing '$url_str'\n";
my $url = new URI::URL $url_str;
my $tests = $tests->{$url_str};
while( ($method, $exp) = each %$tests ){
$exp = 'UNDEF' unless defined $exp;
$url->_expect($method, $exp);
}
}
}
#####################################################################
#
# parts_test() (calls netloc_test test)
#
# Test individual component part access functions
#
sub parts_test {
print "parts_test:\n";
# 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');
$url->_expect('as_string' => 'http://web/1info?key%20words#this');
$url->epath('%2f/%2f');
$url->equery('a=%26');
$url->_expect('full_path' => '/%2f/%2f?a=%26');
# At this point it should be impossible to access the members path()
# and query() without complaints.
eval { my $p = $url->path; print "Path is $p\n"; };
die "Path exception failed" unless $@;
eval { my $p = $url->query; print "Query is $p\n"; };
die "Query exception failed" unless $@;
# but we should still be able to set it
$url->path("howdy");
$url->_expect('as_string' => 'http://web/howdy?a=%26#this');
# Test the path_components function
$url = new URI::URL 'file:%2f/%2f';
my $p;
$p = join('-', $url->path_components);
die "\$url->path_components returns '$p', expected '/-/'"
unless $p eq "/-/";
$url->host("localhost");
$p = join('-', $url->path_components);
die "\$url->path_components returns '$p', expected '-/-/'"
unless $p eq "-/-/";
$url->epath("/foo/bar/");
$p = join('-', $url->path_components);
die "\$url->path_components returns '$p', expected '-foo-bar-'"
unless $p eq "-foo-bar-";
$url->path_components("", "/etc", "\0", "..", "øse", "");
$url->_expect('full_path' => '/%2Fetc/%00/../%F8se/');
# Setting undef
$url = new URI::URL 'http://web/p;p?q#f';
$url->epath(undef);
$url->equery(undef);
$url->eparams(undef);
$url->frag(undef);
$url->_expect('as_string' => 'http://web');
# Test http query access methods
$url->keywords('dog');
$url->_expect('as_string' => 'http://web?dog');
$url->keywords(qw(dog bones));
$url->_expect('as_string' => 'http://web?dog+bones');
$url->keywords(0,0);
$url->_expect('as_string' => 'http://web?0+0');
$url->keywords('dog', 'bones', '#+=');
$url->_expect('as_string' => 'http://web?dog+bones+%23%2B%3D');
$a = join(":", $url->keywords);
die "\$url->keywords did not work (returned '$a')" unless $a eq 'dog:bones:#+=';
# calling query_form is an error
# eval { my $foo = $url->query_form; };
# die "\$url->query_form should croak since query contains keywords not a form."
# unless $@;
$url->query_form(a => 'foo', b => 'bar');
$url->_expect('as_string' => 'http://web?a=foo&b=bar');
my %a = $url->query_form;
die "\$url->query_form did not work"
unless $a{a} eq 'foo' && $a{b} eq 'bar';
$url->query_form(a => undef, a => 'foo', '&=' => '&=+');
$url->_expect('as_string' => 'http://web?a=&a=foo&%26%3D=%26%3D%2B');
my @a = $url->query_form;
die "Wrong length" unless @a == 6;
die "Bad keys from query_form"
unless $a[0] eq 'a' && $a[2] eq 'a' && $a[4] eq '&=';
die "Bad values from query_form"
unless $a[1] eq '' && $a[3] eq 'foo' && $a[5] eq '&=+';
# 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;
#print join(":", @a), "\n";
die "Wrong length" unless @a == 16;
die "Wrong sequence" unless $a[4] eq "" && $a[5] eq "b" &&
$a[10] eq "a" && $a[11] eq "b=c";
# Try array ref values in the key value pairs
$url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']);
$url->_expect('as_string', 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo');
netloc_test();
port_test();
$url->query(undef);
$url->_expect('query', undef);
$url = new URI::URL 'gopher://gopher/';
$url->port(33);
$url->gtype("3");
$url->selector("S");
$url->search("query");
$url->_expect('as_string', 'gopher://gopher:33/3S%09query');
$url->epath("45%09a");
$url->_expect('gtype' => '4');
$url->_expect('selector' => '5');
$url->_expect('search' => 'a');
$url->_expect('string' => undef);
$url->_expect('path' => "/45\ta");
# $url->path("00\t%09gisle");
# $url->_expect('search', '%09gisle');
# Let's test som other URL schemes
$url = new URI::URL 'news:';
$url->group("comp.lang.perl.misc");
$url->_expect('as_string' => 'news:comp.lang.perl.misc');
$url->article('<1234@a.sn.no>');
$url->_expect('as_string' => 'news:1234@a.sn.no'); # "<" 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");
# $url->_expect("as_string" => 'mailto:aas@a.sn.no');
# $url->address('foo@bar');
# $url->_expect("host" => 'bar');
# $url->_expect("user" => 'foo');
# $url = new URI::URL 'wais://host/database/wt/wpath';
# $url->database('foo');
# $url->_expect('as_string' => 'wais://host/foo/wt/wpath');
# $url->wtype('bar');
# $url->_expect('as_string' => 'wais://host/foo/bar/wpath');
# Test crack method for various URLs
my(@crack, $crack);
@crack = URI::URL->new("http://host/path;param?query#frag")->crack;
die "Cracked result should be 9 elements" unless @crack == 9;
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
die "Bad crack result" unless
$crack eq "http*UNDEF*UNDEF*host*80*/path*param*query*frag";
@crack = URI::URL->new("foo/bar", "ftp://aas\@ftp.sn.no/")->crack;
die "Cracked result should be 9 elements" unless @crack == 9;
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
# 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;
die "Cracked result should be 9 elements" unless @crack == 9;
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
die "Bad crack result" unless
$crack eq "ftp*u*p*host*21*/q?path*UNDEF*path*UNDEF";
@crack = URI::URL->new("ftp://ftp.sn.no/pub")->crack; # Test anon ftp
die "Cracked result should be 9 elements" unless @crack == 9;
die "No passwd in anonymous crack" unless $crack[2];
$crack[2] = 'passwd'; # easier to test when we know what it is
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
die "Bad crack result" unless
$crack eq "ftp*anonymous*passwd*ftp.sn.no*21*/pub*UNDEF*UNDEF*UNDEF";
@crack = URI::URL->new('mailto:aas@sn.no')->crack;
die "Cracked result should be 9 elements" unless @crack == 9;
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
# 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;
die "Cracked result should be 9 elements" unless @crack == 9;
$crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
print "Cracked result: $crack\n";
die "Bad crack result" unless
$crack eq "news*UNDEF*UNDEF*UNDEF*119*comp.lang.perl.misc*UNDEF*UNDEF*UNDEF";
}
#
# netloc_test()
#
# Test automatic netloc synchronisation
#
sub netloc_test {
print "netloc_test:\n";
my $url = new URI::URL 'ftp://anonymous:p%61ss@håst:12345';
$url->_expect('user', 'anonymous');
$url->_expect('password', 'pass');
$url->_expect('host', 'håst');
$url->_expect('port', 12345);
# Can't really know how netloc is represented since it is partially escaped
#$url->_expect('netloc', 'anonymous:pass@hst:12345');
$url->_expect('as_string' => 'ftp://anonymous:p%61ss@h%E5st:12345');
# The '0' is sometimes tricky to get right
$url->user(0);
$url->password(0);
$url->host(0);
$url->port(0);
$url->_expect('netloc' => '0:0@0:0');
$url->host(undef);
$url->_expect('netloc' => '0:0@:0');
$url->host('h');
$url->user(undef);
$url->_expect('netloc' => ':0@h:0');
$url->user('');
$url->_expect('netloc' => ':0@h:0');
$url->password('');
$url->_expect('netloc' => ':@h:0');
$url->user('foo');
$url->_expect('netloc' => 'foo:@h:0');
# Let's try a simple one
$url->user('nemo');
$url->password('p2');
$url->host('hst2');
$url->port(2);
$url->_expect('netloc' => 'nemo:p2@hst2:2');
$url->user(undef);
$url->password(undef);
$url->port(undef);
$url->_expect('netloc' => 'hst2');
$url->_expect('port' => '21'); # the default ftp port
$url->port(21);
$url->_expect('netloc' => 'hst2:21');
# Let's try some reserved chars
$url->user("@");
$url->password(":-#-;-/-?");
$url->_expect('as_string' => 'ftp://%40::-%23-;-%2F-%3F@hst2:21');
}
#
# port_test()
#
# Test port behaviour
#
sub port_test {
print "port_test:\n";
$url = URI::URL->new('http://foo/root/dir/');
my $port = $url->port;
die "Port undefined" unless defined $port;
die "Wrong port $port" unless $port == 80;
die "Wrong string" unless $url->as_string eq
'http://foo/root/dir/';
$url->port(8001);
$port = $url->port;
die "Port undefined" unless defined $port;
die "Wrong port $port" unless $port == 8001;
die "Wrong string" unless $url->as_string eq
'http://foo:8001/root/dir/';
$url->port(80);
$port = $url->port;
die "Port undefined" unless defined $port;
die "Wrong port $port" unless $port == 80;
die "Wrong string" unless $url->canonical->as_string eq
'http://foo/root/dir/';
$url->port(8001);
$url->port(undef);
$port = $url->port;
die "Port undefined" unless defined $port;
die "Wrong port $port" unless $port == 80;
die "Wrong string" unless $url->as_string eq
'http://foo/root/dir/';
}
#####################################################################
#
# escape_test()
#
# escaping functions
sub escape_test {
print "escape_test:\n";
# supply escaped URL
$url = new URI::URL 'http://web/this%20has%20spaces';
# check component is unescaped
$url->_expect('path', '/this has spaces');
# modify the unescaped form
$url->path('this ALSO has spaces');
# check whole url is escaped
$url->_expect('as_string',
'http://web/this%20ALSO%20has%20spaces');
$url = new URI::URL uri_escape('http://web/try %?#" those');
$url->_expect('as_string',
'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those');
my $all = pack('C*',0..255);
my $esc = uri_escape($all);
my $new = uri_unescape($esc);
die "uri_escape->uri_unescape mismatch" unless $all eq $new;
$url->path($all);
$url->_expect('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));
# test escaping uses uppercase (preferred by rfc1837)
$url = new URI::URL 'file://h/';
$url->path(chr(0x7F));
$url->_expect('as_string', 'file://h/%7F');
return;
# reserved characters differ per scheme
## XXX is this '?' allowed to be unescaped
$url = new URI::URL 'file://h/test?ing';
$url->_expect('path', '/test?ing');
$url = new URI::URL 'file://h/';
$url->epath('question?mark');
$url->_expect('as_string', 'file://h/question?mark');
# XXX Why should this be any different???
# Perhaps we should not expect too much :-)
$url->path('question?mark');
$url->_expect('as_string', 'file://h/question%3Fmark');
# See what happens when set different elements to this ugly sting
my $reserved = ';/?:@&=#%';
$url->path($reserved . "foo");
$url->_expect('as_string', 'file://h/%3B/%3F%3A%40%26%3D%23%25foo');
$url->scheme('http');
$url->path('');
$url->_expect('as_string', 'http://h/');
$url->query($reserved);
$url->params($reserved);
$url->frag($reserved);
$url->_expect('as_string', 'http://h/;%3B%2F%3F%3A%40&=%23%25?%3B%2F%3F%3A%40&=%23%25#;/?:@&=#%');
$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);
$url->_expect('as_string', 'ftp://%3B%2F%3F%3A%40%26%3D%23%25@%3B%2F%3F%3A%40%26%3D%23%25/foo');
}
#####################################################################
#
# newlocal_test()
#
sub newlocal_test {
return 1 if $^O eq "MacOS";
print "newlocal_test:\n";
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 = ($^O eq 'MSWin32' ? $ENV{TEMP} : '/tmp');
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,^/,) ? '' : '///' );
$url->_expect('as_string', URI::URL->new("file:$ss$dir/")->as_string);
print "Local directory is ". $url->local_path . "\n";
if ($^O ne 'VMS') {
# absolute dir
chdir('/') or die $!;
$url = newlocal URI::URL '/usr/';
$url->_expect('as_string', 'file:/usr/');
# absolute file
$url = newlocal URI::URL '/vmunix';
$url->_expect('as_string', 'file:/vmunix');
}
# relative file
chdir($tmpdir) or die $!;
$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';
$url->_expect('as_string', "file:$ss$dir/foo");
# relative dir
chdir($tmpdir) or die $!;
$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/';
$url->_expect('as_string', "file:$ss$dir/bar/");
# 0
if ($^O ne 'VMS') {
chdir('/') or die $!;
$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';
$url->_expect('as_string', "file:$ss${dir}0");
}
# Test access methods for file URLs
$url = new URI::URL 'file:/c:/dos';
$url->_expect('dos_path', 'C:\\DOS');
$url->_expect('unix_path', '/c:/dos');
#$url->_expect('vms_path', '[C:]DOS');
$url->_expect('mac_path', 'UNDEF');
$url = new URI::URL 'file:/foo/bar';
$url->_expect('unix_path', '/foo/bar');
$url->_expect('mac_path', 'foo:bar');
# Some edge cases
# $url = new URI::URL 'file:';
# $url->_expect('unix_path', '/');
$url = new URI::URL 'file:/';
$url->_expect('unix_path', '/');
$url = new URI::URL 'file:.';
$url->_expect('unix_path', '.');
$url = new URI::URL 'file:./foo';
$url->_expect('unix_path', './foo');
$url = new URI::URL 'file:0';
$url->_expect('unix_path', '0');
$url = new URI::URL 'file:../../foo';
$url->_expect('unix_path', '../../foo');
$url = new URI::URL 'file:foo/../bar';
$url->_expect('unix_path', 'foo/../bar');
# Relative files
$url = new URI::URL 'file:foo/b%61r/Note.txt';
$url->_expect('unix_path', 'foo/bar/Note.txt');
$url->_expect('mac_path', ':foo:bar:Note.txt');
$url->_expect('dos_path', 'FOO\\BAR\\NOTE.TXT');
#$url->_expect('vms_path', '[.FOO.BAR]NOTE.TXT');
# The VMS path found in RFC 1738 (section 3.10)
$url = new URI::URL 'file://vms.host.edu/disk$user/my/notes/note12345.txt';
# $url->_expect('vms_path', 'DISK$USER:[MY.NOTES]NOTE12345.TXT');
# $url->_expect('mac_path', 'disk$user:my:notes:note12345.txt');
chdir($savedir) or die $!;
}
#####################################################################
#
# absolute_test()
#
sub absolute_test {
print "Test relative/absolute URI::URL parsing:\n";
# 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';
$absolute_tests = <<EOM;
5.1. Normal Examples
g:h = <URL:g:h>
g = <URL:http://a/b/c/g>
./g = <URL:http://a/b/c/g>
g/ = <URL:http://a/b/c/g/>
/g = <URL:http://a/g>
//g = <URL:http://g>
# ?y = <URL:http://a/b/c/d;p?y>
g?y = <URL:http://a/b/c/g?y>
g?y/./x = <URL:http://a/b/c/g?y/./x>
#s = <URL:http://a/b/c/d;p?q#s>
g#s = <URL:http://a/b/c/g#s>
g#s/./x = <URL:http://a/b/c/g#s/./x>
g?y#s = <URL:http://a/b/c/g?y#s>
# ;x = <URL:http://a/b/c/d;x>
g;x = <URL:http://a/b/c/g;x>
g;x?y#s = <URL:http://a/b/c/g;x?y#s>
. = <URL:http://a/b/c/>
./ = <URL:http://a/b/c/>
.. = <URL:http://a/b/>
../ = <URL:http://a/b/>
../g = <URL:http://a/b/g>
../.. = <URL:http://a/>
../../ = <URL:http://a/>
../../g = <URL:http://a/g>
5.2. Abnormal Examples
Although the following abnormal examples are unlikely to occur
in normal practice, all URL parsers should be capable of resolving
them consistently. Each example uses the same base as above.
An empty reference resolves to the complete base URL:
<> = <URL:http://a/b/c/d;p?q#f>
Parsers must be careful in handling the case where there are more
relative path ".." segments than there are hierarchical levels in
the base URL's path. Note that the ".." syntax cannot be used to
change the <net_loc> of a URL.
../../../g = <URL:http://a/../g>
../../../../g = <URL:http://a/../../g>
Similarly, parsers must avoid treating "." and ".." as special
when they are not complete components of a relative path.
/./g = <URL:http://a/./g>
/../g = <URL:http://a/../g>
g. = <URL:http://a/b/c/g.>
.g = <URL:http://a/b/c/.g>
g.. = <URL:http://a/b/c/g..>
..g = <URL:http://a/b/c/..g>
Less likely are cases where the relative URL uses unnecessary or
nonsensical forms of the "." and ".." complete path segments.
./../g = <URL:http://a/b/g>
./g/. = <URL:http://a/b/c/g/>
g/./h = <URL:http://a/b/c/g/h>
g/../h = <URL:http://a/b/c/h>
Finally, some older parsers allow the scheme name to be present in
a relative URL if it is the same as the base URL scheme. This is
considered to be a loophole in prior specifications of partial
URLs [1] and should be avoided by future parsers.
http:g = <URL:http:g>
http: = <URL:http:>
EOM
# convert text to list like
# @absolute_tests = ( ['g:h' => 'g:h'], ...)
for $line (split("\n", $absolute_tests)) {
next unless $line =~ /^\s{6}/;
if ($line =~ /^\s+(\S+)\s*=\s*<URL:([^>]*)>/) {
my($rel, $abs) = ($1, $2);
$rel = '' if $rel eq '<>';
push(@absolute_tests, [$rel, $abs]);
}
else {
warn "illegal line '$line'";
}
}
# add some extra ones for good measure
push(@absolute_tests, ['x/y//../z' => 'http://a/b/c/x/y/z'],
['1' => 'http://a/b/c/1' ],
['0' => 'http://a/b/c/0' ],
['/0' => 'http://a/0' ],
# ['%2e/a' => 'http://a/b/c/%2e/a'], # %2e is '.'
# ['%2e%2e/a' => 'http://a/b/c/%2e%2e/a'],
);
print " Relative + Base => Expected Absolute URL\n";
print "================================================\n";
for $test (@absolute_tests) {
my($rel, $abs) = @$test;
my $abs_url = new URI::URL $abs;
my $abs_str = $abs_url->as_string;
printf(" %-10s + $base => %s\n", $rel, $abs);
my $u = new URI::URL $rel, $base;
my $got = $u->abs;
$got->_expect('as_string', $abs_str);
}
# bug found and fixed in 1.9 by "J.E. Fritz" <FRITZ@gems.vcu.edu>
$base = new URI::URL 'http://host/directory/file';
my $relative = new URI::URL 'file', $base;
my $result = $relative->abs;
my ($a, $b) = ($base->path, $result->path);
die "'$a' and '$b' should be the same" unless $a eq $b;
# 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;
die 'URL not canonicalised' unless $result eq 'http://host/dir2/file';
print "--------\n";
# 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:/?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);
printf(" %-12s+ $base => %s\n", $rel, $abs);
$abs->_expect('as_string', $expected_abs);
}
print "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) = @$_;
printf "url('$abs', '$base')->rel eq '$expect'\n";
my $rel = URI::URL->new($abs, $base)->rel;
$rel->_expect('as_string', $expect);
}
print "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
$u1->eq($u2) or die "1: $u1 ne $u2";
$u1->eq($u3) or die "2: $u1 ne $u3";
$u2->eq($u1) or die "3: $u2 ne $u1";
$u2->eq($u3) or die "4: $u2 ne $u3";
$u3->eq($u1) or die "5: $u3 ne $u1";
$u3->eq($u2) or die "6: $u3 ne $u2";
# Test empty path
my $u4 = new URI::URL 'http://www.sn.no';
$u4->eq("HTTP://WWW.SN.NO:80/") or die "7: $u4";
$u4->eq("http://www.sn.no:81") and die "8: $u4";
# Test mailto
# my $u5 = new URI::URL 'mailto:AAS@SN.no';
# $u5->eq('mailto:aas@sn.no') or die "9: $u5";
# Test reserved char
my $u6 = new URI::URL 'ftp://ftp/%2Fetc';
$u6->eq("ftp://ftp/%2fetc") or die "10: $u6";
$u6->eq("ftp://ftp://etc") and die "11: $u6";
}
URI-1.30/t/generic.t 0100644 0000764 0000764 00000012265 07713746365 013171 0 ustar gisle gisle #!perl -w
print "1..48\n";
use URI;
$foo = URI->new("Foo:opaque#frag");
print "not " unless ref($foo) eq "URI::_foreign";
print "ok 1\n";
print "not " unless $foo->as_string eq "Foo:opaque#frag";
print "ok 2\n";
print "not " unless "$foo" eq "Foo:opaque#frag";
print "ok 3\n";
# Try accessors
print "not " unless $foo->_scheme eq "Foo" && $foo->scheme eq "foo";
print "ok 4\n";
print "not " unless $foo->opaque eq "opaque";
print "ok 5\n";
print "not " unless $foo->fragment eq "frag";
print "ok 6\n";
print "not " unless $foo->canonical eq "foo:opaque#frag";
print "ok 7\n";
# Try modificators
$old = $foo->scheme("bar");
print "not " unless $old eq "foo" && $foo eq "bar:opaque#frag";
print "ok 8\n";
$old = $foo->scheme("");
print "not " unless $old eq "bar" && $foo eq "opaque#frag";
print "ok 9\n";
$old = $foo->scheme("foo");
$old = $foo->scheme(undef);
print "not " unless $old eq "foo" && $foo eq "opaque#frag";
print "ok 10\n";
$foo->scheme("foo");
$old = $foo->opaque("xxx");
print "not " unless $old eq "opaque" && $foo eq "foo:xxx#frag";
print "ok 11\n";
$old = $foo->opaque("");
print "not " unless $old eq "xxx" && $foo eq "foo:#frag";
print "ok 12\n";
$old = $foo->opaque(" #?/");
$old = $foo->opaque(undef);
print "not " unless $old eq "%20%23?/" && $foo eq "foo:#frag";
print "ok 13\n";
$foo->opaque("opaque");
$old = $foo->fragment("x");
print "not " unless $old eq "frag" && $foo eq "foo:opaque#x";
print "ok 14\n";
$old = $foo->fragment("");
print "not " unless $old eq "x" && $foo eq "foo:opaque#";
print "ok 15\n";
$old = $foo->fragment(undef);
print "not " unless $old eq "" && $foo eq "foo:opaque";
print "ok 16\n";
# Compare
print "not " unless $foo->eq("Foo:opaque") &&
$foo->eq(URI->new("FOO:opaque")) &&
$foo->eq("foo:opaque");
print "ok 17\n";
print "not " if $foo->eq("Bar:opaque") ||
$foo->eq("foo:opaque#");
print "ok 18\n";
# Try hierarchal unknown URLs
$foo = URI->new("foo://host:80/path?query#frag");
print "not " unless "$foo" eq "foo://host:80/path?query#frag";
print "ok 19\n";
# Accessors
print "not " unless $foo->scheme eq "foo";
print "ok 20\n";
print "not " unless $foo->authority eq "host:80";
print "ok 21\n";
print "not " unless $foo->path eq "/path";
print "ok 22\n";
print "not " unless $foo->query eq "query";
print "ok 23\n";
print "not " unless $foo->fragment eq "frag";
print "ok 24\n";
# Modificators
$old = $foo->authority("xxx");
print "not " unless $old eq "host:80" && $foo eq "foo://xxx/path?query#frag";
print "ok 25\n";
$old = $foo->authority("");
print "not " unless $old eq "xxx" && $foo eq "foo:///path?query#frag";
print "ok 26\n";
$old = $foo->authority(undef);
print "not " unless $old eq "" && $foo eq "foo:/path?query#frag";
print "ok 27\n";
$old = $foo->authority("/? #;@&");
print "not " unless !defined($old) && $foo eq "foo://%2F%3F%20%23;@&/path?query#frag";
print "ok 28\n";
$old = $foo->authority("host:80");
print "not " unless $old eq "%2F%3F%20%23;@&" && $foo eq "foo://host:80/path?query#frag";
print "ok 29\n";
$old = $foo->path("/foo");
print "not " unless $old eq "/path" && $foo eq "foo://host:80/foo?query#frag";
print "ok 30\n";
$old = $foo->path("bar");
print "not " unless $old eq "/foo" && $foo eq "foo://host:80/bar?query#frag";
print "ok 31\n";
$old = $foo->path("");
print "not " unless $old eq "/bar" && $foo eq "foo://host:80?query#frag";
print "ok 32\n";
$old = $foo->path(undef);
print "not " unless $old eq "" && $foo eq "foo://host:80?query#frag";
print "ok 33\n";
$old = $foo->path("@;/?#");
print "not " unless $old eq "" && $foo eq "foo://host:80/@;/%3F%23?query#frag";
print "ok 34\n";
$old = $foo->path("path");
print "not " unless $old eq "/@;/%3F%23" && $foo eq "foo://host:80/path?query#frag";
print "ok 35\n";
$old = $foo->query("foo");
print "not " unless $old eq "query" && $foo eq "foo://host:80/path?foo#frag";
print "ok 36\n";
$old = $foo->query("");
print "not " unless $old eq "foo" && $foo eq "foo://host:80/path?#frag";
print "ok 37\n";
$old = $foo->query(undef);
print "not " unless $old eq "" && $foo eq "foo://host:80/path#frag";
print "ok 38\n";
$old = $foo->query("/?&=# ");
print "not " unless !defined($old) && $foo eq "foo://host:80/path?/?&=%23%20#frag";
print "ok 39\n";
$old = $foo->query("query");
print "not " unless $old eq "/?&=%23%20" && $foo eq "foo://host:80/path?query#frag";
print "ok 40\n";
# Some buildup trics
$foo = URI->new("");
$foo->path("path");
$foo->authority("auth");
print "not " unless $foo eq "//auth/path";
print "ok 41\n";
$foo = URI->new("", "http:");
$foo->query("query");
$foo->authority("auth");
print "not " unless $foo eq "//auth?query";
print "ok 42\n";
$foo->path("path");
print "not " unless $foo eq "//auth/path?query";
print "ok 43\n";
$foo = URI->new("");
$old = $foo->path("foo");
print "not " unless $old eq "" && $foo eq "foo";
print "ok 44\n";
$old = $foo->path("bar");
print "not " unless $old eq "foo" && $foo eq "bar";
print "ok 45\n";
$old = $foo->opaque("foo");
print "not " unless $old eq "bar" && $foo eq "foo";
print "ok 46\n";
$old = $foo->path("");
print "not " unless $old eq "foo" && $foo eq "";
print "ok 47\n";
$old = $foo->query("q");
print "not " unless !defined($old) && $foo eq "?q";
print "ok 48\n";
URI-1.30/t/news.t 0100644 0000764 0000764 00000002337 07713746365 012530 0 ustar gisle gisle #!perl -w
print "1..7\n";
use URI;
$u = URI->new("news:comp.lang.perl.misc");
print "not " unless $u->group eq "comp.lang.perl.misc" &&
!defined($u->message) &&
$u->port == 119 &&
$u eq "news:comp.lang.perl.misc";
print "ok 1\n";
$u->host("news.online.no");
print "not " unless $u->group eq "comp.lang.perl.misc" &&
$u->port == 119 &&
$u eq "news://news.online.no/comp.lang.perl.misc";
print "ok 2\n";
$u->group("no.perl", 1 => 10);
print "not " unless $u eq "news://news.online.no/no.perl/1-10";
print "ok 3\n";
@g = $u->group;
#print "G: @g\n";
print "not " unless @g == 3 && "@g" eq "no.perl 1 10";
print "ok 4\n";
$u->message('42@g.aas.no');
#print "$u\n";
print "not " unless $u->message eq '42@g.aas.no' &&
!defined($u->group) &&
$u eq 'news://news.online.no/42@g.aas.no';
print "ok 5\n";
$u = URI->new("nntp:no.perl");
print "not " unless $u->group eq "no.perl" &&
$u->port == 119;
print "ok 6\n";
$u = URI->new("snews://snews.online.no/no.perl");
print "not " unless $u->group eq "no.perl" &&
$u->host eq "snews.online.no" &&
$u->port == 563;
print "ok 7\n";
URI-1.30/t/file.t 0100644 0000764 0000764 00000005271 07713746365 012473 0 ustar gisle gisle #!perl -w
use URI::file;
@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://foo/bar","!//foo/bar", "\\\\foo\\bar", "!foo:bar"],
[ "file://a:/", "!//a:/", "!A:\\", undef],
[ "file:/", "/", "\\", undef],
[ "file://A:relative/", "!//A:relative/", "A:", undef],
[ ".", ".", ".", ":"],
[ "..", "..", "..", "::"],
[ "%2E", "!.", "!.", ":."],
[ "../%2E%2E", "!../..", "!..\\..", "::.."],
);
if ($^O eq "MacOS") {
@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);
}
@os = @{shift @tests};
shift @os; # file
my $num = @tests;
print "1..$num\n";
$testno = 1;
for $t (@tests) {
my @t = @$t;
my $file = shift @t;
my $err;
my $u = URI->new($file, "file");
my $i = 0;
for $os (@os) {
my $f = $u->file($os);
my $expect = $t[$i];
$f = "<undef>" unless defined $f;
$expect = "<undef>" unless defined $expect;
my $loose;
$loose++ if $expect =~ s/^!//;
if ($expect ne $f) {
print "URI->new('$file', 'file')->file('$os') ne $expect, but $f\n";
$err++;
}
if (defined($t[$i]) && !$loose) {
$u2 = URI::file->new($t[$i], $os);
unless ($u2->as_string eq $file) {
print "URI::file->new('$t[$i]', '$os') ne $file, but $u2\n";
$err++;
}
}
$i++;
}
print "not " if $err;
print "ok $testno\n";
$testno++;
}
URI-1.30/t/roytest1.html 0100644 0000764 0000764 00000016505 06576171500 014036 0 ustar gisle gisle <HTML><HEAD>
<TITLE>Examples of Resolving Relative URLs</TITLE>
<BASE href="http://a/b/c/d;p?q">
</HEAD><BODY>
<H1>Examples of Resolving Relative URLs</H1>
This document has an embedded base URL of
<PRE>
Content-Base: http://a/b/c/d;p?q
</PRE>
the relative URLs should be resolved as shown below.
<P>
I will need your help testing the examples on multiple browsers.
What you need to do is point to the example anchor and compare it to the
resolved URL in your browser (most browsers have a feature by which you
can see the resolved URL at the bottom of the window/screen when the anchor
is active).
<H2>Tested Clients and Client Libraries</H2>
<DL COMPACT>
<DT>[R]
<DD>RFC 2396 (the right way to parse)
<DT>[X]
<DD>RFC 1808
<DT>[1]
<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
<DT>[2]
<DD>Lynx/2.7.1 libwww-FM/2.14
<DT>[3]
<DD>MSIE 3.01; Windows 95
<DT>[4]
<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
<DT>[5]
<DD>libwww-perl/5.14 [Martijn Koster]
</DL>
<H2>Normal Examples</H2>
<PRE>
RESULTS from
<a href="g:h">g:h</a> = g:h [R,X,2,3,4,5]
http://a/b/c/g:h [1]
<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4,5]
<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4,5]
<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4,5]
<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4,5]
<a href="//g">//g</a> = http://g [R,X,1,2,3,4,5]
<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4]
http://a/b/c/d;p?y [X,5]
<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4,5]
<a name="s" href="#s">#s</a> = (current document)#s [R,2,4]
http://a/b/c/d;p?q#s [X,1,3,5]
<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4,5]
<a href="g?y#s">g?y#s</a> = http://a/b/c/g?y#s [R,X,1,2,3,4,5]
<a href=";x">;x</a> = http://a/b/c/;x [R,1,2,3,4]
http://a/b/c/d;x [X,5]
<a href="g;x">g;x</a> = http://a/b/c/g;x [R,X,1,2,3,4,5]
<a href="g;x?y#s">g;x?y#s</a> = http://a/b/c/g;x?y#s [R,X,1,2,3,4,5]
<a href=".">.</a> = http://a/b/c/ [R,X,2,5]
http://a/b/c/. [1]
http://a/b/c [3,4]
<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4,5]
<a href="..">..</a> = http://a/b/ [R,X,2,5]
http://a/b [1,3,4]
<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4,5]
<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4,5]
<a href="../..">../..</a> = http://a/ [R,X,2,5]
http://a [1,3,4]
<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4,5]
<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4,5]
</PRE>
<H2>Abnormal Examples</H2>
Although the following abnormal examples are unlikely to occur in
normal practice, all URL parsers should be capable of resolving them
consistently. Each example uses the same base as above.<P>
An empty reference refers to the start of the current document.
<PRE>
<a href=""><></a> = (current document) [R,2,4]
http://a/b/c/d;p?q [X,3,5]
http://a/b/c/ [1]
</PRE>
Parsers must be careful in handling the case where there are more
relative path ".." segments than there are hierarchical levels in the
base URL's path. Note that the ".." syntax cannot be used to change
the site component of a URL.
<PRE>
<a href="../../../g">../../../g</a> = http://a/../g [R,X,2,4,5]
http://a/g [R,1,3]
<a href="../../../../g">../../../../g</a> = http://a/../../g [R,X,2,4,5]
http://a/g [R,1,3]
</PRE>
In practice, some implementations strip leading relative symbolic
elements (".", "..") after applying a relative URL calculation, based
on the theory that compensating for obvious author errors is better
than allowing the request to fail. Thus, the above two references
will be interpreted as "http://a/g" by some implementations.
<P>
Similarly, parsers must avoid treating "." and ".." as special when
they are not complete components of a relative path.
<PRE>
<a href="/./g">/./g</a> = http://a/./g [R,X,2,3,4,5]
http://a/g [1]
<a href="/../g">/../g</a> = http://a/../g [R,X,2,3,4,5]
http://a/g [1]
<a href="g.">g.</a> = http://a/b/c/g. [R,X,1,2,3,4,5]
<a href=".g">.g</a> = http://a/b/c/.g [R,X,1,2,3,4,5]
<a href="g..">g..</a> = http://a/b/c/g.. [R,X,1,2,3,4,5]
<a href="..g">..g</a> = http://a/b/c/..g [R,X,1,2,3,4,5]
</PRE>
Less likely are cases where the relative URL uses unnecessary or
nonsensical forms of the "." and ".." complete path segments.
<PRE>
<a href="./../g">./../g</a> = http://a/b/g [R,X,1,2,5]
http://a/b/c/../g [3,4]
<a href="./g/.">./g/.</a> = http://a/b/c/g/ [R,X,2,5]
http://a/b/c/g/. [1]
http://a/b/c/g [3,4]
<a href="g/./h">g/./h</a> = http://a/b/c/g/h [R,X,1,2,3,4,5]
<a href="g/../h">g/../h</a> = http://a/b/c/h [R,X,1,2,3,4,5]
<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/g;x=1/y [R,1,2,3,4]
http://a/b/c/g;x=1/./y [X,5]
<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/y [R,1,2,3,4]
http://a/b/c/g;x=1/../y [X,5]
</PRE>
All client applications remove the query component from the base URL
before resolving relative URLs. However, some applications fail to
separate the reference's query and/or fragment components from a
relative path before merging it with the base path. This error is
rarely noticed, since typical usage of a fragment never includes the
hierarchy ("/") character, and the query component is not normally
used within relative references.
<PRE>
<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X,5]
http://a/b/c/g?y/x [1,2,3,4]
<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X,5]
http://a/b/c/x [1,2,3,4]
<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4,5]
http://a/b/c/g#s/x [1]
<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4,5]
http://a/b/c/x [1]
</PRE>
Some parsers allow the scheme name to be present in a relative URI if
it is the same as the base URI scheme. This is considered to be a
loophole in prior specifications of partial URI [RFC1630]. Its use
should be avoided.
<PRE>
<a href="http:g">http:g</a> = http:g [R,X,5]
| http://a/b/c/g [1,2,3,4] (ok for compat.)
<a href="http:">http:</a> = http: [R,X,5]
http://a/b/c/ [1]
http://a/b/c/d;p?q [2,3,4]
</PRE>
</BODY></HTML>
URI-1.30/t/ftp.t 0100644 0000764 0000764 00000002237 07720213241 012320 0 ustar gisle gisle #!perl -w
print "1..13\n";
use strict;
use URI;
my $uri;
$uri = URI->new("ftp://ftp.example.com/path");
print "not " unless $uri->scheme eq "ftp";
print "ok 1\n";
print "not " unless $uri->host eq "ftp.example.com";
print "ok 2\n";
print "not " unless $uri->port eq 21;
print "ok 3\n";
print "not " unless $uri->user eq "anonymous";
print "ok 4\n";
print "not " unless $uri->password eq 'anonymous@';
print "ok 5\n";
$uri->userinfo("gisle\@aas.no");
print "not " unless $uri eq "ftp://gisle%40aas.no\@ftp.example.com/path";
print "ok 6\n";
print "not " unless $uri->user eq "gisle\@aas.no";
print "ok 7\n";
print "not " if defined($uri->password);
print "ok 8\n";
$uri->password("secret");
print "not " unless $uri eq "ftp://gisle%40aas.no:secret\@ftp.example.com/path";
print "ok 9\n";
$uri = URI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path");
print "not " unless $uri eq "ftp://gisle\@aas.no:secret\@ftp.example.com/path";
print "ok 10\n";
print "not " unless $uri->userinfo eq "gisle\@aas.no:secret";
print "ok 11\n";
print "not " unless $uri->user eq "gisle\@aas.no";
print "ok 12\n";
print "not " unless $uri->password eq "secret";
print "ok 13\n";
URI-1.30/t/urn-isbn.t 0100644 0000764 0000764 00000002417 07737265236 013307 0 ustar gisle gisle #!perl -w
eval {
require Business::ISBN;
};
if ($@) {
print "1..0 # Skipped: Needs the Business::ISBN module installed\n\n";
print $@;
exit;
}
print "1..13\n";
use URI;
my $u = URI->new("URN:ISBN:0395363411");
print "not " unless $u eq "URN:ISBN:0395363411" &&
$u->scheme eq "urn" &&
$u->nid eq "isbn";
print "ok 1\n";
print "not " unless $u->canonical eq "urn:isbn:0-395-36341-1";
print "ok 2\n";
print "not " unless $u->isbn eq "0-395-36341-1";
print "ok 3\n";
print "not " unless $u->isbn_country_code == 0;
print "ok 4\n";
print "not " unless $u->isbn_publisher_code == 395;
print "ok 5\n";
print "not " unless $u->isbn_as_ean eq "9780395363416";
print "ok 6\n";
print "not " unless $u->nss eq "0395363411";
print "ok 7\n";
print "not " unless $u->isbn("0-88730-866-x") eq "0-395-36341-1";
print "ok 8\n";
print "not " unless $u->nss eq "0-88730-866-x";
print "ok 9\n";
print "not " unless $u->isbn eq "0-88730-866-X";
print "ok 10\n";
print "not " unless URI::eq("urn:isbn:088730866x", "URN:ISBN:0-88-73-08-66-X");
print "ok 11\n";
# try to illegal ones
$u = URI->new("urn:ISBN:abc");
print "not " unless $u eq "urn:ISBN:abc";
print "ok 12\n";
print "not " if $u->nss ne "abc" || defined $u->isbn;
print "ok 13\n";
URI-1.30/t/abs.t 0100644 0000764 0000764 00000012725 07713746364 012322 0 ustar gisle gisle #!perl -w
print "1..45\n";
# This test the resolution of abs path for all examples given
# in the "Uniform Resource Identifiers (URI): Generic Syntax" document.
use URI;
$base = "http://a/b/c/d;p?q";
$testno = 1;
while (<DATA>) {
#next if 1 .. /^C\.\s+/;
#last if /^D\.\s+/;
next unless /\s+(\S+)\s*=\s*(.*)/;
my $uref = $1;
my $expect = $2;
$expect =~ s/\(current document\)/$base/;
#print "$uref => $expect\n";
my $bad;
my $u = URI->new($uref, $base);
if ($u->abs($base)->as_string ne $expect) {
$bad++;
my $abs = $u->abs($base)->as_string;
print qq(URI->new("$uref")->abs("$base") ==> "$abs"\n);
}
# Let's test another version of the same thing
$u = URI->new($uref);
my $b = URI->new($base);
if ($u->abs($b,1) ne $expect && $uref !~ /^http:/) {
$bad++;
print qq(URI->new("$uref")->abs(URI->new("$base"), 1)\n);
}
# Let's try the other way
$u = URI->new($expect)->rel($base)->as_string;
if ($u ne $uref) {
push(@rel_fail, qq($testno: URI->new("$expect", "$base")->rel ==> "$u" (not "$uref")\n));
}
print "not " if $bad;
print "ok ", $testno++, "\n";
}
if (@rel_fail) {
print "\n\nIn the following cases we did not get back to where we started with rel()\n";
print @rel_fail;
}
__END__
Network Working Group T. Berners-Lee, MIT/LCS
INTERNET-DRAFT R. Fielding, U.C. Irvine
draft-fielding-uri-syntax-02 L. Masinter, Xerox Corporation
Expires six months after publication date March 4, 1998
Uniform Resource Identifiers (URI): Generic Syntax
[...]
C. Examples of Resolving Relative URI References
Within an object with a well-defined base URI of
http://a/b/c/d;p?q
the relative URIs would be resolved as follows:
C.1. Normal Examples
g:h = g:h
g = http://a/b/c/g
./g = http://a/b/c/g
g/ = http://a/b/c/g/
/g = http://a/g
//g = http://g
?y = http://a/b/c/d;p?y
g?y = http://a/b/c/g?y
#s = (current document)#s
g#s = http://a/b/c/g#s
g?y#s = http://a/b/c/g?y#s
;x = http://a/b/c/;x
g;x = http://a/b/c/g;x
g;x?y#s = http://a/b/c/g;x?y#s
. = http://a/b/c/
./ = http://a/b/c/
.. = http://a/b/
../ = http://a/b/
../g = http://a/b/g
../.. = http://a/
../../ = http://a/
../../g = http://a/g
C.2. Abnormal Examples
Although the following abnormal examples are unlikely to occur in
normal practice, all URI parsers should be capable of resolving them
consistently. Each example uses the same base as above.
An empty reference refers to the start of the current document.
<> = (current document)
Parsers must be careful in handling the case where there are more
relative path ".." segments than there are hierarchical levels in
the base URI's path. Note that the ".." syntax cannot be used to
change the authority component of a URI.
../../../g = http://a/../g
../../../../g = http://a/../../g
In practice, some implementations strip leading relative symbolic
elements (".", "..") after applying a relative URI calculation, based
on the theory that compensating for obvious author errors is better
than allowing the request to fail. Thus, the above two references
will be interpreted as "http://a/g" by some implementations.
Similarly, parsers must avoid treating "." and ".." as special when
they are not complete components of a relative path.
/./g = http://a/./g
/../g = http://a/../g
g. = http://a/b/c/g.
.g = http://a/b/c/.g
g.. = http://a/b/c/g..
..g = http://a/b/c/..g
Less likely are cases where the relative URI uses unnecessary or
nonsensical forms of the "." and ".." complete path segments.
./../g = http://a/b/g
./g/. = http://a/b/c/g/
g/./h = http://a/b/c/g/h
g/../h = http://a/b/c/h
g;x=1/./y = http://a/b/c/g;x=1/y
g;x=1/../y = http://a/b/c/y
All client applications remove the query component from the base URI
before resolving relative URIs. However, some applications fail to
separate the reference's query and/or fragment components from a
relative path before merging it with the base path. This error is
rarely noticed, since typical usage of a fragment never includes the
hierarchy ("/") character, and the query component is not normally
used within relative references.
g?y/./x = http://a/b/c/g?y/./x
g?y/../x = http://a/b/c/g?y/../x
g#s/./x = http://a/b/c/g#s/./x
g#s/../x = http://a/b/c/g#s/../x
Some parsers allow the scheme name to be present in a relative URI
if it is the same as the base URI scheme. This is considered to be
a loophole in prior specifications of partial URIs [RFC1630]. Its
use should be avoided.
http:g = http:g
http: = http:
==========================================================================
Some extra tests for good measure...
#foo? = (current document)#foo?
?#foo = http://a/b/c/d;p?#foo
URI-1.30/t/storable-test.pl 0100644 0000764 0000764 00000001143 07737264542 014504 0 ustar gisle gisle #!perl -w
use strict;
use Storable;
if (@ARGV && $ARGV[0] eq "store") {
require URI;
require URI::URL;
my $a = {
u => new URI('http://search.cpan.org/'),
};
print "# store\n";
store [URI->new("http://search.cpan.org")], 'urls.sto';
} else {
print "# retrieve\n";
my $a = retrieve 'urls.sto';
my $u = $a->[0];
#use Data::Dumper; print Dumper($a);
print "not " unless $u eq "http://search.cpan.org";
print "ok 1\n";
print "not " unless $u->scheme eq "http";
print "ok 2\n";
print "not " unless ref($u) eq "URI::http";
print "ok 3\n";
}
URI-1.30/t/mix.t 0100644 0000764 0000764 00000003511 07713746365 012344 0 ustar gisle gisle #!perl -w
print "1..6\n";
# Test mixing of URI and URI::WithBase objects
use URI;
use URI::WithBase;
use URI::URL;
$str = "http://www.sn.no/";
$rel = "path/img.gif";
$u = URI->new($str);
$uw = URI::WithBase->new($str, "http:");
$uu = URI::URL->new($str);
sub Dump
{
require Data::Dumper;
print Data::Dumper->Dump([$a, $b, $c, $d], [qw(a b c d)]);
}
$a = URI->new($rel, $u);
$b = URI->new($rel, $uw);
$c = URI->new($rel, $uu);
$d = URI->new($rel, $str);
#Dump();
print "not " unless $a->isa("URI") &&
ref($b) eq ref($uw) &&
ref($c) eq ref($uu) &&
$d->isa("URI");
print "ok 1\n";
print "not " if $b->base && $c->base;
print "ok 2\n";
$a = URI::URL->new($rel, $u);
$b = URI::URL->new($rel, $uw);
$c = URI::URL->new($rel, $uu);
$d = URI::URL->new($rel, $str);
print "not " unless ref($a) eq "URI::URL" &&
ref($b) eq "URI::URL" &&
ref($c) eq "URI::URL" &&
ref($d) eq "URI::URL";
print "ok 3\n";
print "not " unless ref($b->base) eq ref($uw) &&
$b->base eq $uw &&
ref($c->base) eq ref($uu) &&
$c->base eq $uu &&
$d->base eq $str;
print "ok 4\n";
$a = URI->new($uu, $u);
$b = URI->new($uu, $uw);
$c = URI->new($uu, $uu);
$d = URI->new($uu, $str);
#Dump();
print "not " unless ref($a) eq ref($b) &&
ref($b) eq ref($c) &&
ref($c) eq ref($d) &&
ref($d) eq ref($u);
print "ok 5\n";
$a = URI::URL->new($u, $u);
$b = URI::URL->new($u, $uw);
$c = URI::URL->new($u, $uu);
$d = URI::URL->new($u, $str);
print "not " unless ref($a) eq "URI::URL" &&
ref($b) eq "URI::URL" &&
ref($c) eq "URI::URL" &&
ref($d) eq "URI::URL";
print "ok 6\n";
URI-1.30/t/split.t 0100644 0000764 0000764 00000003054 07707661752 012703 0 ustar gisle gisle #!perl -w
print "1..17\n";
use strict;
use URI::Split qw(uri_split uri_join);
sub j { join("-", map { defined($_) ? $_ : "<undef>" } @_) }
print "not " unless j(uri_split("p")) eq "<undef>-<undef>-p-<undef>-<undef>";
print "ok 1\n";
print "not " unless j(uri_split("p?q")) eq "<undef>-<undef>-p-q-<undef>";
print "ok 2\n";
print "not " unless j(uri_split("p#f")) eq "<undef>-<undef>-p-<undef>-f";
print "ok 3\n";
print "not " unless j(uri_split("p?q/#f/?")) eq "<undef>-<undef>-p-q/-f/?";
print "ok 4\n";
print "not " unless j(uri_split("s://a/p?q#f")) eq "s-a-/p-q-f";
print "ok 5\n";
print "not " unless uri_join("s", "a", "/p", "q", "f") eq "s://a/p?q#f";
print "ok 6\n";
print "not " unless uri_join("s", "a", "p", "q", "f") eq "s://a/p?q#f";
print "ok 7\n";
print "not " unless uri_join(undef, undef, "", undef, undef) eq "";
print "ok 8\n";
print "not " unless uri_join(undef, undef, "p", undef, undef) eq "p";
print "ok 9\n";
print "not " unless uri_join("s", undef, "p") eq "s:p";
print "ok 10\n";
print "not " unless uri_join("s") eq "s:";
print "ok 11\n";
print "not " unless uri_join() eq "";
print "ok 12\n";
print "not " unless uri_join("s", "a") eq "s://a";
print "ok 13\n";
print "not " unless uri_join("s", "a/b") eq "s://a%2Fb";
print "ok 14\n";
print "not " unless uri_join("s", ":/?#", ":/?#", ":/?#", ":/?#") eq "s://:%2F%3F%23/:/%3F%23?:/?%23#:/?#";
print "ok 15\n";
print "not " unless uri_join(undef, undef, "a:b") eq "a%3Ab";
print "ok 16\n";
print "not " unless uri_join("s", undef, "//foo//bar") eq "s:////foo//bar";
print "ok 17\n";
URI-1.30/t/urn-oid.t 0100644 0000764 0000764 00000000612 07512204441 013100 0 ustar gisle gisle #!perl -w
print "1..4\n";
use strict;
use URI;
my $u = URI->new("urn:oid");
$u->oid(1..10);
#print "$u\n";
print "not " unless $u eq "urn:oid:1.2.3.4.5.6.7.8.9.10";
print "ok 1\n";
print "not " unless $u->oid eq "1.2.3.4.5.6.7.8.9.10";
print "ok 2\n";
print "not " unless $u->scheme eq "urn" && $u->nid eq "oid";
print "ok 3\n";
print "not " unless $u->oid eq $u->nss;
print "ok 4\n";
URI-1.30/t/mailto.t 0100644 0000764 0000764 00000002361 07713746365 013036 0 ustar gisle gisle #!perl -w
print "1..7\n";
use URI;
$u = URI->new('mailto:gisle@aas.no');
print "not " unless $u->to eq 'gisle@aas.no' &&
$u eq 'mailto:gisle@aas.no';
print "ok 1\n";
$old = $u->to('larry@wall.org');
print "not " unless $old eq 'gisle@aas.no' &&
$u->to eq 'larry@wall.org' &&
$u eq 'mailto:larry@wall.org';
print "ok 2\n";
$u->to("?/#");
print "not " unless $u->to eq "?/#" &&
$u eq 'mailto:%3F/%23';
print "ok 3\n";
@h = $u->headers;
print "not " unless @h == 2 && "@h" eq "to ?/#";
print "ok 4\n";
$u->headers(to => 'gisle@aas.no',
cc => 'gisle@ActiveState.com,larry@wall.org',
Subject => 'How do you do?',
garbage => '/;?#=&',
);
@h = $u->headers;
print "not " unless $u->to eq 'gisle@aas.no' &&
@h == 8 &&
"@h" eq 'to gisle@aas.no cc gisle@ActiveState.com,larry@wall.org Subject How do you do? garbage /;?#=&';
print "ok 5\n";
#print "$u\n";
print "not " unless $u eq 'mailto:gisle@aas.no?cc=gisle%40ActiveState.com%2Clarry%40wall.org&Subject=How+do+you+do%3F&garbage=%2F%3B%3F%23%3D%26';
print "ok 6\n";
$u = URI->new("mailto:");
$u->to("gisle");
print "not " unless $u eq 'mailto:gisle';
print "ok 7\n";
URI-1.30/t/roytest5.html 0100644 0000764 0000764 00000006442 06576171500 014041 0 ustar gisle gisle <HTML><HEAD>
<TITLE>Examples of Resolving Relative URLs, Part 5</TITLE>
<BASE href="http:///s//a/b/c">
</HEAD><BODY>
<H1>Examples of Resolving Relative URLs, Part 5</H1>
This document has an embedded base URL of
<PRE>
Content-Base: http:///s//a/b/c
</PRE>
in order to test a notion that Tim Berners-Lee mentioned regarding
the ability of URIs to have a triple-slash (or even more slashes)
to indicate higher levels of hierarchy than those already used by URLs.
This is the same as Part 4, except that the scheme "fred" is replaced
with "http" for clients that stupidly change their parsing behavior
based on the scheme name.
<H2>Tested Clients and Client Libraries</H2>
<DL COMPACT>
<DT>[R]
<DD>RFC 2396 (the right way to parse)
<DT>Tim
<DD>Tim Berners-Lee's proposed interpretation
<DT>[1]
<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
<DT>[2]
<DD>Lynx/2.7.1 libwww-FM/2.14
<DT>[3]
<DD>MSIE 3.01; Windows 95
<DT>[4]
<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)
</DL>
<H3>Synopsis</H3>
RFC 1808 specified that the highest level for relative URLs is indicated
by a double-slash "//", and therefore that any triple-slash would be
considered a null site component, rather than a higher-level component
than the site component (as proposed by Tim).<P>
Draft 09 assumes that a triple-slash means an empty site component,
as does Netscape Navigator if the scheme is known.
Oddly, Lynx seems to straddle both sides.
<H2>Examples</H2>
<PRE>
RESULTS from
<a href="g:h">g:h</a> = g:h [R,Tim,2,3]
http:///s//a/b/g:h [1]
<a href="g">g</a> = http:///s//a/b/g [R,Tim,1,2,3]
<a href="./g">./g</a> = http:///s//a/b/g [R,Tim,1,2,3]
<a href="g/">g/</a> = http:///s//a/b/g/ [R,Tim,1,2,3]
<a href="/g">/g</a> = http:///g [R,1,2,3]
http:///s//a/g [Tim]
<a href="//g">//g</a> = http://g [R,1,2,3]
http:///s//g [Tim]
<a href="//g/x">//g/x</a> = http://g/x [R,1,2,3]
http:///s//g/x [Tim]
<a href="///g">///g</a> = http:///g [R,Tim,1,2,3]
<a href="./">./</a> = http:///s//a/b/ [R,Tim,1,2,3]
<a href="../">../</a> = http:///s//a/ [R,Tim,1,2,3]
<a href="../g">../g</a> = http:///s//a/g [R,Tim,1,2,3]
<a href="../../">../../</a> = http:///s// [R,1]
http:///s//a/../ [Tim,2]
http:///s//a/ [3]
<a href="../../g">../../g</a> = http:///s//g [R,1]
http:///s//a/../g [Tim,2]
http:///s//a/g [3]
<a href="../../../g">../../../g</a> = http:///s/g [R,1]
http:///s//a/../../g [Tim,2]
http:///s//a/g [3]
<a href="../../../../g">../../../../g</a> = http:///g [R,1]
http:///s//a/../../../g [Tim,2]
http:///s//a/g [3]
</PRE>
</BODY></HTML>
URI-1.30/t/sip.t 0100644 0000764 0000764 00000003246 07713746365 012347 0 ustar gisle gisle #!perl -w
print "1..8\n";
use URI;
$u = URI->new('sip:phone@domain.ext');
print "not " unless $u->user eq 'phone' &&
$u->host eq 'domain.ext' &&
$u->port eq '5060' &&
$u eq 'sip:phone@domain.ext';
print "ok 1\n";
$u->host_port('otherdomain.int:9999');
print "not " unless $u->host eq 'otherdomain.int' &&
$u->port eq '9999' &&
$u eq 'sip:phone@otherdomain.int:9999';
print "ok 2\n";
$u->port('5060');
$u = $u->canonical;
print "not " unless $u->host eq 'otherdomain.int' &&
$u->port eq '5060' &&
$u eq 'sip:phone@otherdomain.int';
print "ok 3\n";
$u->user('voicemail');
print "not " unless $u->user eq 'voicemail' &&
$u eq 'sip:voicemail@otherdomain.int';
print "ok 4\n";
$u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent');
print "not " unless $u->host eq 'domain.ext' &&
$u->query eq 'Subject=Meeting&Priority=Urgent';
print "ok 5\n";
$u->query_form(Subject => 'Lunch', Priority => 'Low');
@q = $u->query_form;
print "not " unless $u->host eq 'domain.ext' &&
$u->query eq 'Subject=Lunch&Priority=Low' &&
@q == 4 && "@q" eq "Subject Lunch Priority Low";
print "ok 6\n";
$u = URI->new('sip:phone@domain.ext;maddr=127.0.0.1;ttl=16');
print "not " unless $u->host eq 'domain.ext' &&
$u->params eq 'maddr=127.0.0.1;ttl=16';
print "ok 7\n";
$u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent');
$u->params_form(maddr => '127.0.0.1', ttl => '16');
@p = $u->params_form;
print "not " unless $u->host eq 'domain.ext' &&
$u->query eq 'Subject=Meeting&Priority=Urgent' &&
$u->params eq 'maddr=127.0.0.1;ttl=16' &&
@p == 4 && "@p" eq "maddr 127.0.0.1 ttl 16";
print "ok 8\n";
URI-1.30/t/data.t 0100644 0000764 0000764 00000006002 07713746365 012456 0 ustar gisle gisle #!perl -w
eval {
require MIME::Base64;
};
if ($@) {
print "1..0\n";
print $@;
exit;
}
print "1..21\n";
use URI;
$u = URI->new("data:,A%20brief%20note");
print "not " unless $u->scheme eq "data" && $u->opaque eq ",A%20brief%20note";
print "ok 1\n";
print "not " unless $u->media_type eq "text/plain;charset=US-ASCII" &&
$u->data eq "A brief note";
print "ok 2\n";
$old = $u->data("Får-i-kål er tingen!");
print "not " unless $old eq "A brief note" && $u eq "data:,F%E5r-i-k%E5l%20er%20tingen!";
print "ok 3\n";
$old = $u->media_type("text/plain;charset=iso-8859-1");
print "not " unless $old eq "text/plain;charset=US-ASCII" &&
$u eq "data:text/plain;charset=iso-8859-1,F%E5r-i-k%E5l%20er%20tingen!";
print "ok 4\n";
$u = URI->new("data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAwAAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFzByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSpa/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJlZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uisF81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PHhhx4dbgYKAAA7");
print "not " unless $u->media_type eq "image/gif";
print "ok 5\n";
if ($ENV{DISPLAY} && $ENV{XV}) {
open(XV, "| $ENV{XV} -") || die;
print XV $u->data;
close(XV);
}
print "not " unless length($u->data) == 273;
print "ok 6\n";
$u = URI->new("data:text/plain;charset=iso-8859-7,%be%fg%be"); # %fg
print "not " unless $u->data eq "\xBE%fg\xBE";
print "ok 7\n";
$u = URI->new("data:application/vnd-xxx-query,select_vcount,fcol_from_fieldtable/local");
print "not " unless $u->data eq "select_vcount,fcol_from_fieldtable/local";
print "ok 8\n";
$u->data("");
print "not " unless $u eq "data:application/vnd-xxx-query,";
print "ok 9\n";
$u->data("a,b"); $u->media_type(undef);
print "not " unless $u eq "data:,a,b";
print "ok 10\n";
# Test automatic selection of URI/BASE64 encoding
$u = URI->new("data:");
$u->data("");
print "not " unless $u eq "data:,";
print "ok 11\n";
$u->data(">");
print "not " unless $u eq "data:,%3E" && $u->data eq ">";
print "ok 12\n";
$u->data(">>>>>");
print "not " unless $u eq "data:,%3E%3E%3E%3E%3E";
print "ok 13\n";
$u->data(">>>>>>");
print "not " unless $u eq "data:;base64,Pj4+Pj4+";
print "ok 14\n";
$u->media_type("text/plain;foo=bar");
print "not " unless $u eq "data:text/plain;foo=bar;base64,Pj4+Pj4+";
print "ok 15\n";
$u->media_type("foo");
print "not " unless $u eq "data:foo;base64,Pj4+Pj4+";
print "ok 16\n";
$u->data(">" x 3000);
print "not " unless $u eq ("data:foo;base64," . ("Pj4+" x 1000)) &&
$u->data eq (">" x 3000);
print "ok 17\n";
$u->media_type(undef);
$u->data(undef);
print "not " unless $u eq "data:,";
print "ok 18\n";
$u = URI->new("data:foo");
print "not " unless $u->media_type("bar,båz") eq "foo";
print "ok 19\n";
print "not " unless $u->media_type eq "bar,båz";
print "ok 20\n";
$old = $u->data("new");
print "not " unless $old eq "" && $u eq "data:bar%2Cb%E5z,new";
print "ok 21\n";
URI-1.30/t/rfc2732.t 0100644 0000764 0000764 00000002453 07713746365 012643 0 ustar gisle gisle #!perl -w
print "1..9\n";
use strict;
use URI;
my $uri = URI->new("http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html");
print "not " unless $uri->as_string eq "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html";
print "ok 1\n";
print "not " unless $uri->host eq "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]";
print "ok 2\n";
print "not " unless $uri->host_port eq "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80";
print "ok 3\n";
print "not " unless $uri->port eq "80";
print "ok 4\n";
$uri->host("host");
print "not " unless $uri->as_string eq "http://host:80/index.html";
print "ok 5\n";
$uri = URI->new("ftp://ftp:@[3ffe:2a00:100:7031::1]");
print "not " unless $uri->as_string eq "ftp://ftp:@[3ffe:2a00:100:7031::1]";
print "ok 6\n";
print "not " unless $uri->port eq "21" && !$uri->_port;
print "ok 7\n";
print "not " unless $uri->host("ftp") eq "[3ffe:2a00:100:7031::1]";
print "ok 8\n";
print "not " unless $uri eq "ftp://ftp:\@ftp";
print "ok 9\n";
__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-1.30/t/old-relbase.t 0100644 0000764 0000764 00000001600 07713746365 013735 0 ustar gisle gisle #!perl -w
print "1..5\n";
use URI::URL;
# We used to have problems with URLs that used a base that was
# not absolute itself.
$u1 = url("/foo/bar", "http://www.acme.com/");
$u2 = url("../foo/", $u1);
$u3 = url("zoo/foo", $u2);
$a1 = $u1->abs->as_string;
$a2 = $u2->abs->as_string;
$a3 = $u3->abs->as_string;
print "$a1\n$a2\n$a3\n";
print "not " unless $a1 eq "http://www.acme.com/foo/bar";
print "ok 1\n";
print "not " unless $a2 eq "http://www.acme.com/foo/";
print "ok 2\n";
print "not " unless $a3 eq "http://www.acme.com/foo/zoo/foo";
print "ok 3\n";
# We used to have problems with URI::URL as the base class :-(
$u4 = url("foo", "URI::URL");
$a4 = $u4->abs;
print "$a4\n";
print "not " unless $u4 eq "foo" && $a4 eq "uri:/foo";
print "ok 4\n";
# Test new_abs for URI::URL objects
print "not " unless URI::URL->new_abs("foo", "http://foo/bar") eq "http://foo/foo";
print "ok 5\n";
URI-1.30/t/http.t 0100644 0000764 0000764 00000002620 07713746365 012526 0 ustar gisle gisle #!perl -w
print "1..13\n";
use URI;
$u = URI->new("<http://www.perl.com/path?q=fôo>");
#print "$u\n";
print "not " unless $u eq "http://www.perl.com/path?q=f%F4o";
print "ok 1\n";
print "not " unless $u->port == 80;
print "ok 2\n";
# play with port
$old = $u->port(8080);
print "not " unless $old == 80 && $u eq "http://www.perl.com:8080/path?q=f%F4o";
print "ok 3\n";
$u->port(80);
print "not " unless $u eq "http://www.perl.com:80/path?q=f%F4o";
print "ok 4\n";
$u->port("");
print "not " unless $u eq "http://www.perl.com:/path?q=f%F4o" && $u->port == 80;
print "ok 5\n";
$u->port(undef);
print "not " unless $u eq "http://www.perl.com/path?q=f%F4o";
print "ok 6\n";
@q = $u->query_form;
print "not " unless @q == 2 && "@q" eq "q fôo";
print "ok 7\n";
$u->query_form(foo => "bar", bar => "baz");
print "not " unless $u->query eq "foo=bar&bar=baz";
print "ok 8\n";
print "not " unless $u->host eq "www.perl.com";
print "ok 9\n";
print "not " unless $u->path eq "/path";
print "ok 10\n";
$u->scheme("https");
print "not " unless $u->port == 443;
print "ok 11\n";
print "not " unless $u eq "https://www.perl.com/path?foo=bar&bar=baz";
print "ok 12\n";
$u = URI->new("http://%77%77%77%2e%70%65%72%6c%2e%63%6f%6d/%70%75%62/%61/%32%30%30%31/%30%38/%32%37/%62%6a%6f%72%6e%73%74%61%64%2e%68%74%6d%6c");
print "not " unless $u->canonical eq "http://www.perl.com/pub/a/2001/08/27/bjornstad.html";
print "ok 13\n";
URI-1.30/t/roytest4.html 0100644 0000764 0000764 00000007210 06576171500 014032 0 ustar gisle gisle <HTML><HEAD>
<TITLE>Examples of Resolving Relative URLs, Part 4</TITLE>
<BASE href="fred:///s//a/b/c">
</HEAD><BODY>
<H1>Examples of Resolving Relative URLs, Part 4</H1>
This document has an embedded base URL of
<PRE>
Content-Base: fred:///s//a/b/c
</PRE>
in order to test a notion that Tim Berners-Lee mentioned regarding
the ability of URIs to have a triple-slash (or even more slashes)
to indicate higher levels of hierarchy than those already used by URLs.
<H2>Tested Clients and Client Libraries</H2>
<DL COMPACT>
<DT>[R]
<DD>RFC 2396 (the right way to parse)
<DT>Tim
<DD>Tim Berners-Lee's proposed interpretation
<DT>[1]
<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
<DT>[2]
<DD>Lynx/2.7.1 libwww-FM/2.14
<DT>[3]
<DD>MSIE 3.01; Windows 95
<DT>[4]
<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)
</DL>
<H3>Synopsis</H3>
RFC 1808 specified that the highest level for relative URLs is indicated
by a double-slash "//", and therefore that any triple-slash would be
considered a null site component, rather than a higher-level component
than the site component (as proposed by Tim).<P>
The URI draft assumes that a triple-slash means an empty site component.
Netscape Navigator behaves irrationally, apparently because their parser
is scheme-dependent and therefore doesn't do the hierarchical parsing that
would be expected. Oddly, Lynx seems to straddle both sides.
<H2>Examples</H2>
<PRE>
RESULTS from
<a href="g:h">g:h</a> = g:h [R,Tim,2,3]
fred:///s//a/b/g:h [1]
<a href="g">g</a> = fred:///s//a/b/g [R,Tim,1,2,3]
<a href="./g">./g</a> = fred:///s//a/b/g [R,Tim,2,3]
fred:///s//a/b/./g [1]
<a href="g/">g/</a> = fred:///s//a/b/g/ [R,Tim,1,2,3]
<a href="/g">/g</a> = fred:///g [R,1,2,3]
fred:///s//a/g [Tim]
<a href="//g">//g</a> = fred://g [R,1,2,3]
fred:///s//g [Tim]
<a href="//g/x">//g/x</a> = fred://g/x [R,1,2,3]
fred:///s//g/x [Tim]
<a href="///g">///g</a> = fred:///g [R,Tim,1,2,3]
<a href="./">./</a> = fred:///s//a/b/ [R,Tim,2,3]
fred:///s//a/b/./ [1]
<a href="../">../</a> = fred:///s//a/ [R,Tim,2,3]
fred:///s//a/b/../ [1]
<a href="../g">../g</a> = fred:///s//a/g [R,Tim,2,3]
fred:///s//a/b/../g [1]
<a href="../../">../../</a> = fred:///s// [R]
fred:///s//a/../ [Tim,2]
fred:///s//a/b/../../ [1]
fred:///s//a/ [3]
<a href="../../g">../../g</a> = fred:///s//g [R]
fred:///s//a/../g [Tim,2]
fred:///s//a/b/../../g [1]
fred:///s//a/g [3]
<a href="../../../g">../../../g</a> = fred:///s/g [R]
fred:///s//a/../../g [Tim,2]
fred:///s//a/b/../../../g [1]
fred:///s//a/g [3]
<a href="../../../../g">../../../../g</a> = fred:///g [R]
fred:///s//a/../../../g [Tim,2]
fred:///s//a/b/../../../../g [1]
fred:///s//a/g [3]
</PRE>
</BODY></HTML>
URI-1.30/t/query.t 0100644 0000764 0000764 00000003175 07762365777 012732 0 ustar gisle gisle #!perl -w
print "1..17\n";
use strict;
use URI ();
my $u = URI->new("", "http");
my @q;
$u->query_form(a => 3, b => 4);
print "not " unless $u eq "?a=3&b=4";
print "ok 1\n";
$u->query_form(a => undef);
print "not " unless $u eq "?a=";
print "ok 2\n";
$u->query_form("a[=&+#] " => " [=&+#]");
print "not " unless $u eq "?a%5B%3D%26%2B%23%5D+=+%5B%3D%26%2B%23%5D";
print "ok 3\n";
@q = $u->query_form;
print "not " unless join(":", @q) eq "a[=&+#] : [=&+#]";
print "ok 4\n";
@q = $u->query_keywords;
print "not " if @q;
print "ok 5\n";
$u->query_keywords("a", "b");
print "not " unless $u eq "?a+b";
print "ok 6\n";
$u->query_keywords(" ", "+", "=", "[", "]");
print "not " unless $u eq "?%20+%2B+%3D+%5B+%5D";
print "ok 7\n";
@q = $u->query_keywords;
print "not " unless join(":", @q) eq " :+:=:[:]";
print "ok 8\n";
@q = $u->query_form;
print "not " if @q;
print "ok 9\n";
$u->query(" +?=#");
print "not " unless $u eq "?%20+?=%23";
print "ok 10\n";
$u->query_keywords([qw(a b)]);
print "not " unless $u eq "?a+b";
print "ok 11\n";
$u->query_keywords([]);
print "not " unless $u eq "";
print "ok 12\n";
$u->query_form({ a => 1, b => 2 });
print "not " unless $u eq "?a=1&b=2" || $u eq "?b=2&a=1";
print "ok 13\n";
$u->query_form([ a => 1, b => 2 ]);
print "not " unless $u eq "?a=1&b=2";
print "ok 14\n";
$u->query_form({});
print "not " unless $u eq "";
print "ok 15\n";
$u->query_form([a => [1..4]]);
print "not " unless $u eq "?a=1&a=2&a=3&a=4";
print "ok 16\n";
$u->query_form([]);
print "not " unless $u eq "";
print "ok 17\n";
__END__
# Some debugging while writing new tests
print "\@q='", join(":", @q), "'\n";
print "\$u='$u'\n";
URI-1.30/t/mms.t 0100644 0000764 0000764 00000001423 07774526046 012342 0 ustar gisle gisle #!perl -w
print "1..8\n";
use URI;
$u = URI->new("<mms://66.250.188.13/KFOG_FM>");
#print "$u\n";
print "not " unless $u eq "mms://66.250.188.13/KFOG_FM";
print "ok 1\n";
print "not " unless $u->port == 1755;
print "ok 2\n";
# play with port
$old = $u->port(8755);
print "not " unless $old == 1755 && $u eq "mms://66.250.188.13:8755/KFOG_FM";
print "ok 3\n";
$u->port(1755);
print "not " unless $u eq "mms://66.250.188.13:1755/KFOG_FM";
print "ok 4\n";
$u->port("");
print "not " unless $u eq "mms://66.250.188.13:/KFOG_FM" && $u->port == 1755;
print "ok 5\n";
$u->port(undef);
print "not " unless $u eq "mms://66.250.188.13/KFOG_FM";
print "ok 6\n";
print "not " unless $u->host eq "66.250.188.13";
print "ok 7\n";
print "not " unless $u->path eq "/KFOG_FM";
print "ok 8\n";
URI-1.30/t/rel.t 0100644 0000764 0000764 00000000756 07707412073 012326 0 ustar gisle gisle #!/usr/bin/perl -w
print "1..4\n";
use strict;
use URI;
my $uri = URI->new("http://www.example.com/foo/bar/");
print "not " unless $uri->rel("http://www.example.com/foo/bar/") eq "./";
print "ok 1\n";
print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM/foo/bar/") eq "./";
print "ok 2\n";
print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM/FOO/BAR/") eq "../../foo/bar/";
print "ok 3\n";
print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM:80/foo/bar/") eq "./";
print "ok 4\n";
URI-1.30/t/roy-test.t 0100644 0000764 0000764 00000002234 07713746365 013336 0 ustar gisle gisle #!perl -w
print "1..102\n";
if (-d "t") {
chdir("t") || die "Can't chdir 't': $!";
# fix all relative library locations
foreach (@INC) {
$_ = "../$_" unless m,^/,;
}
}
use URI;
$no = 1;
for $i (1..5) {
my $file = "roytest$i.html";
open(FILE, $file) || die "Can't open $file: $!";
print "# $file\n";
$base = undef;
while (<FILE>) {
if (/^<BASE href="([^"]+)">/) {
$base = URI->new($1);
} elsif (/^<a href="([^"]*)">.*<\/a>\s*=\s*(\S+)/) {
die "Missing base at line $." unless $base;
$link = $1;
$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";
}
$abs = URI->new($link)->abs($base);
unless ($abs eq $exp) {
print "$file:$.: Expected: $exp\n";
print qq( abs("$link","$base") ==> "$abs"\n);
print "not ";
}
print "ok $no\n";
$no++;
}
}
close(FILE);
}
URI-1.30/t/old-absconf.t 0100644 0000764 0000764 00000001620 07713746365 013735 0 ustar gisle gisle #!perl -w
print "1..6\n";
use URI::URL qw(url);
# Test configuration via some global variables.
$URI::URL::ABS_REMOTE_LEADING_DOTS = 1;
$URI::URL::ABS_ALLOW_RELATIVE_SCHEME = 1;
$u1 = url("../../../../abc", "http://web/a/b");
print "not " unless $u1->abs->as_string eq "http://web/abc";
print "ok 1\n";
{
local $URI::URL::ABS_REMOTE_LEADING_DOTS;
print "not " unless $u1->abs->as_string eq "http://web/../../../abc";
print "ok 2\n";
}
$u1 = url("http:../../../../abc", "http://web/a/b");
print "not " unless $u1->abs->as_string eq "http://web/abc";
print "ok 3\n";
{
local $URI::URL::ABS_ALLOW_RELATIVE_SCHEME;
print "not " unless $u1->abs->as_string eq "http:../../../../abc";
print "ok 4\n";
print "not " unless $u1->abs(undef,1)->as_string eq "http://web/abc";
print "ok 5\n";
}
print "not " unless $u1->abs(undef,0)->as_string eq "http:../../../../abc";
print "ok 6\n";
URI-1.30/t/storable.t 0100644 0000764 0000764 00000000445 07737265575 013372 0 ustar gisle gisle #!perl -w
eval {
require Storable;
print "1..3\n";
};
if ($@) {
print "1..0 # skipped: Needs the Storable module installed\n";
exit;
}
system($^X, "-Iblib/lib", "t/storable-test.pl", "store");
system($^X, "-Iblib/lib", "t/storable-test.pl", "retrieve");
unlink('urls.sto');
URI-1.30/t/query-param.t 0100644 0000764 0000764 00000003757 07762371257 014024 0 ustar gisle gisle #!perl -w
print "1..18\n";
use strict;
use URI;
use URI::QueryParam;
my $u = URI->new("http://www.sol.no?foo=4&bar=5&foo=5");
my $h = $u->query_form_hash;
print "not " unless $h->{foo}[0] eq "4" && $h->{foo}[1] eq "5" && $h->{bar} eq "5";
print "ok 1\n";
$u->query_form_hash({ a => 1, b => 2});
print "not " unless $u->query eq "a=1&b=2" || $u->query eq "b=2&a=1";
print "ok 2\n";
$u->query("a=1&b=2&a=3&b=4&a=5");
print "not " unless $u->query_param == 2 && join(":", $u->query_param) eq "a:b";
print "ok 3\n";
print "not " unless $u->query_param("a") eq "1" &&
join(":", $u->query_param("a")) eq "1:3:5";
print "ok 4\n";
print "not " unless $u->query_param(a => 11 .. 14) eq "1";
print "ok 5\n";
print "not " unless $u->query eq "a=11&b=2&a=12&b=4&a=13&a=14";
print "ok 6\n";
print "not " unless join(":", $u->query_param(a => 11)) eq "11:12:13:14";
print "ok 7\n";
print "not " unless $u->query eq "a=11&b=2&b=4";
print "ok 8\n";
print "not " unless $u->query_param_delete("a") eq "11";
print "ok 9\n";
print "not " unless $u->query eq "b=2&b=4";
print "ok 10\n";
$u->query_param_append(a => 1, 3, 5);
$u->query_param_append(b => 6);
print "not " unless $u->query eq "b=2&b=4&a=1&a=3&a=5&b=6";
print "ok 11\n";
$u->query_param(a => []); # same as $u->query_param_delete("a");
print "not " unless $u->query eq "b=2&b=4&b=6";
print "ok 12\n";
$u->query(undef);
$u->query_param(a => 1, 2, 3);
$u->query_param(b => 1);
print "not " unless $u->query eq 'a=3&a=2&a=1&b=1';
print "ok 13\n";
$u->query_param_delete('a');
$u->query_param_delete('b');
print "not " if $u->query;
print "ok 14\n";
print "not " unless $u->as_string eq 'http://www.sol.no';
print "ok 15\n";
$u->query(undef);
$u->query_param(a => 1, 2, 3);
$u->query_param(b => 1);
print "not " unless $u->query eq 'a=3&a=2&a=1&b=1';
print "ok 16\n";
$u->query_param('a' => []);
$u->query_param('b' => []);
print "not " if $u->query;
print "ok 17\n";
print "not " unless $u->as_string eq 'http://www.sol.no';
print "ok 18\n";
URI-1.30/t/escape.t 0100644 0000764 0000764 00000001045 07713746365 013007 0 ustar gisle gisle #!perl -w
print "1..6\n";
use URI::Escape;
print "not " unless uri_escape("|abcå") eq "%7Cabc%E5";
print "ok 1\n";
print "not " unless uri_escape("abc", "b-d") eq "a%62%63";
print "ok 2\n";
print "not " if defined(uri_escape(undef));
print "ok 3\n";
print "not " unless uri_unescape("%7Cabc%e5") eq "|abcå";
print "ok 4\n";
print "not " unless join(":", uri_unescape("%40A%42", "CDE", "F%47H")) eq
'@AB:CDE:FGH';
print "ok 5\n";
use URI::Escape qw(%escapes);
print "not" unless $escapes{"%"} eq "%25";
print "ok 6\n";
URI-1.30/t/roytest3.html 0100644 0000764 0000764 00000006017 06576171500 014035 0 ustar gisle gisle <HTML><HEAD>
<TITLE>Examples of Resolving Relative URLs, Part 3</TITLE>
<BASE href="http://a/b/c/d;p=1/2?q">
</HEAD><BODY>
<H1>Examples of Resolving Relative URLs, Part 3</H1>
This document has an embedded base URL of
<PRE>
Content-Base: http://a/b/c/d;p=1/2?q
</PRE>
the relative URLs should be resolved as shown below. For this test page,
I am particularly interested in testing whether "/" in parameters is or is not
treated as part of the path hierarchy.
<P>
I will need your help testing the examples on multiple browsers.
What you need to do is point to the example anchor and compare it to the
resolved URL in your browser (most browsers have a feature by which you
can see the resolved URL at the bottom of the window/screen when the anchor
is active).
<H2>Tested Clients and Client Libraries</H2>
<DL COMPACT>
<DT>[R]
<DD>RFC 2396 (the right way to parse)
<DT>[X]
<DD>RFC 1808
<DT>[1]
<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
<DT>[2]
<DD>Lynx/2.7.1 libwww-FM/2.14
<DT>[3]
<DD>MSIE 3.01; Windows 95
<DT>[4]
<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
</DL>
<H3>Synopsis</H3>
RFC 1808 specified that the "/" character within parameter information
does not affect the hierarchy within URL parsing. It would appear that
it does in current practice. This implies that the parameters should
be part of each path segment and not outside the path. The URI draft has
been written accordingly.
<H2>Examples</H2>
<PRE>
RESULTS from
<a href="g">g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4]
http://a/b/c/g [X]
<a href="./g">./g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4]
http://a/b/c/g [X]
<a href="g/">g/</a> = http://a/b/c/d;p=1/g/ [R,1,2,3,4]
http://a/b/c/g/ [X]
<a href="g?y">g?y</a> = http://a/b/c/d;p=1/g?y [R,1,2,3,4]
http://a/b/c/g?y [X]
<a href=";x">;x</a> = http://a/b/c/d;p=1/;x [R,1,2,3,4]
http://a/b/c/d;x [X]
<a href="g;x">g;x</a> = http://a/b/c/d;p=1/g;x [R,1,2,3,4]
http://a/b/c/g;x [X]
<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/d;p=1/g;x=1/y [R,1,2,3,4]
http://a/b/c/g;x=1/./y [X]
<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/d;p=1/y [R,1,2,3,4]
http://a/b/c/g;x=1/../y [X]
<a href="./">./</a> = http://a/b/c/d;p=1/ [R,1,2,3,4]
http://a/b/c/ [X]
<a href="../">../</a> = http://a/b/c/ [R,1,2,3,4]
http://a/b/ [X]
<a href="../g">../g</a> = http://a/b/c/g [R,1,2,3,4]
http://a/b/g [X]
<a href="../../">../../</a> = http://a/b/ [R,1,2,3,4]
http://a/ [X]
<a href="../../g">../../g</a> = http://a/b/g [R,1,2,3,4]
http://a/g [X]
</PRE>
</BODY></HTML>
URI-1.30/t/rtsp.t 0100644 0000764 0000764 00000001600 07713746365 012534 0 ustar gisle gisle #!perl -w
print "1..9\n";
use URI;
$u = URI->new("<rtsp://media.perl.com/fôo.smi/>");
#print "$u\n";
print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/";
print "ok 1\n";
print "not " unless $u->port == 554;
print "ok 2\n";
# play with port
$old = $u->port(8554);
print "not " unless $old == 554 && $u eq "rtsp://media.perl.com:8554/f%F4o.smi/";
print "ok 3\n";
$u->port(554);
print "not " unless $u eq "rtsp://media.perl.com:554/f%F4o.smi/";
print "ok 4\n";
$u->port("");
print "not " unless $u eq "rtsp://media.perl.com:/f%F4o.smi/" && $u->port == 554;
print "ok 5\n";
$u->port(undef);
print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/";
print "ok 6\n";
print "not " unless $u->host eq "media.perl.com";
print "ok 7\n";
print "not " unless $u->path eq "/f%F4o.smi/";
print "ok 8\n";
$u->scheme("rtspu");
print "not " unless $u->scheme eq "rtspu";
print "ok 9\n";
URI-1.30/URI/ 0040755 0000764 0000764 00000000000 10001246222 011524 5 ustar gisle gisle URI-1.30/URI/mailto.pm 0100644 0000764 0000764 00000002346 06576171474 013405 0 ustar gisle gisle package URI::mailto; # RFC 2368
require URI;
require URI::_query;
@ISA=qw(URI URI::_query);
use strict;
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;
}
1;
URI-1.30/URI/_generic.pm 0100644 0000764 0000764 00000013033 07762356455 013670 0 ustar gisle gisle package URI::_generic;
require URI;
require URI::_query;
@ISA=qw(URI URI::_query);
use strict;
use URI::Escape qw(uri_unescape);
use Carp ();
my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g;
my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
sub _no_scheme_ok { 1 }
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::escapes{$1}/go;
$$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::escapes{$1}/go;
_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::escapes{$1}/go;
_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;
$abs->fragment($self->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 oposite 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 <janl@ifi.uio.no>.
# 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-1.30/URI/_ldap.pm 0100644 0000764 0000764 00000006251 07775073716 013200 0 ustar gisle gisle # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. 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 vars qw($VERSION);
$VERSION = "1.10";
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 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 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);
# Lowecase 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-1.30/URI/urn.pm 0100644 0000764 0000764 00000003642 07523320747 012714 0 ustar gisle gisle package URI::urn; # RFC 2141
require URI;
@ISA=qw(URI);
use strict;
use Carp qw(carp);
use vars qw(%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
eval "require $impclass";
die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
$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-1.30/URI/file.pm 0100644 0000764 0000764 00000020100 10001242470 012770 0 ustar gisle gisle package URI::file;
use strict;
use vars qw(@ISA $VERSION);
require URI::_generic;
@ISA = qw(URI::_generic);
$VERSION = sprintf("%d.%02d", q$Revision: 4.14 $ =~ /(\d+)\.(\d+)/);
use URI::Escape qw(uri_unescape);
# Map from $^O values to implementation classes. The Unix
# class is the default.
my %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 path { shift->path_query(@_) }
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(shift);
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 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<URI::file> class supports C<URI> objects belonging to the I<file>
URI scheme. This scheme allows us to map the conventional file names
found on various computer systems to the URI name space. An old
specification of the I<file> URI scheme is found in RFC 1738. Some
older background information is also in RFC 1630. There are no newer
specifications as far as I know.
If you simply want to construct I<file> URI objects from URI strings,
use the normal C<URI> constructor. If you want to construct I<file>
URI objects from the actual file names used by various systems, then
use one of the following C<URI::file> constructors:
=over 4
=item $u = URI::file->new( $filename, [$os] )
Maps a file name to the I<file:> 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<file> URI that represents the current working directory.
See L<Cwd>.
=back
The following methods are supported for I<file> URI (in addition to
the common and generic methods described in L<URI>):
=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<undef> 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<URI::file> 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<File::Spec> module. For instance, the following
code translates the UNIX-style file name F<Foo/Bar.pm> 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 RFC
2396). 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 uses ":" as path separator, but not in the same way
as a generic URI. ":foo" is a relative name. "foo:bar" is an absolute
name. Also, path segments can contain the "/" character as well as the
literal "." or "..". So the mapping looks like this:
Mac URI
---------- -------------------
:foo:bar <==> foo/bar
: <==> ./
::foo:bar <==> ../foo/bar
::: <==> ../../
foo:bar <==> file:/foo/bar
foo:bar: <==> file:/foo/bar/
.. <==> %2E%2E
<undef> <== /
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:
<undef> <== 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
distribted 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 SEE ALSO
L<URI>, L<File::Spec>, L<perlport>
=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-1.30/URI/_login.pm 0100644 0000764 0000764 00000000336 06576171473 013363 0 ustar gisle gisle package URI::_login;
require URI::_server;
require URI::_userpass;
@ISA = qw(URI::_server URI::_userpass);
# Generic terminal logins. This is used as a base class for 'telnet',
# 'tn3270', and 'rlogin' URL schemes.
1;
URI-1.30/URI/Heuristic.pm 0100644 0000764 0000764 00000013113 10001242470 014016 0 ustar gisle gisle package URI::Heuristic;
# $Id: Heuristic.pm,v 4.17 2004/01/14 13:33:44 gisle Exp $
=head1 NAME
URI::Heuristic - Expand URI using heuristics
=head1 SYNOPSIS
use URI::Heuristic qw(uf_uristr);
$u = uf_uristr("perl"); # http://www.perl.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<scheme:> 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<URI> 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 two 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<Locale::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 vars qw(@EXPORT_OK $VERSION $MY_COUNTRY %LOCAL_GUESSING $DEBUG);
require Exporter;
*import = \&Exporter::import;
@EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
$VERSION = sprintf("%d.%02d", q$Revision: 4.17 $ =~ /(\d+)\.(\d+)/);
sub MY_COUNTRY() {
for ($MY_COUNTRY) {
return $_ if defined;
# First try the environment.
$_ = $ENV{COUNTRY};
return $_ if defined;
# Could use LANG, LC_ALL, etc at this point, but probably too
# much of a wild guess. (Catalan != Canada, etc.)
#
# 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);
}
}
%LOCAL_GUESSING =
(
'us' => [qw(www.ACME.gov www.ACME.mil)],
'uk' => [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 <gisle@aas.no>
);
sub uf_uristr ($)
{
local($_) = @_;
print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
return unless defined;
s/^\s+//;
s/\s+$//;
if (/^(www|web|home)\./) {
$_ = "http://$_";
} elsif (/^(ftp|gopher|news|wais|http|https)\./) {
$_ = "$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;
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;
}
}
$_ = "http://$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-1.30/URI/rtsp.pm 0100644 0000764 0000764 00000000131 07515035611 013060 0 ustar gisle gisle package URI::rtsp;
require URI::http;
@ISA=qw(URI::http);
sub default_port { 554 }
1;
URI-1.30/URI/file/ 0040755 0000764 0000764 00000000000 10001246222 012443 5 ustar gisle gisle URI-1.30/URI/file/Base.pm 0100644 0000764 0000764 00000002311 06601742165 013667 0 ustar gisle gisle package URI::file::Base;
use strict;
use URI::Escape qw();
sub new
{
my $class = shift;
my $path = shift;
$path = "" unless defined $path;
my($auth, $escaped_auth, $escaped_path);
($auth, $escaped_auth) = $class->extract_authority($path);
($path, $escaped_path) = $class->extract_path($path);
if (defined $auth) {
$auth =~ s,%,%25,g unless $escaped_auth;
$auth =~ s,([/?\#]),$URI::Escape::escapes{$1},g;
$auth = "//$auth";
if (defined $path) {
$path = "/$path" unless substr($path, 0, 1) eq "/";
} else {
$path = "";
}
} else {
return unless defined $path;
$auth = "";
}
$path =~ s,([%;?]),$URI::Escape::escapes{$1},g 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 extract_authority
{
undef;
}
sub extract_path
{
undef;
}
sub is_this_host
{
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-1.30/URI/file/OS2.pm 0100644 0000764 0000764 00000001016 07732612557 013430 0 ustar gisle gisle package URI::file::OS2;
require URI::file::Win32;
@ISA=qw(URI::file::Win32);
# The Win32 version translates k:/foo to file://k:/foo (?!)
# We add an empty host
sub 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-1.30/URI/file/Mac.pm 0100644 0000764 0000764 00000004624 07457135752 013536 0 ustar gisle gisle package URI::file::Mac;
require URI::file::Base;
@ISA=qw(URI::file::Base);
use strict;
use URI::Escape qw(uri_unescape);
sub 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::escapes{$1},g;
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->is_this_host($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-1.30/URI/file/QNX.pm 0100644 0000764 0000764 00000000472 07052016546 013467 0 ustar gisle gisle package URI::file::QNX;
require URI::file::Unix;
@ISA=qw(URI::file::Unix);
use strict;
sub 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-1.30/URI/file/FAT.pm 0100644 0000764 0000764 00000000724 06601723671 013436 0 ustar gisle gisle package URI::file::FAT;
require URI::file::Win32;
@ISA=qw(URI::file::Win32);
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-1.30/URI/file/Win32.pm 0100644 0000764 0000764 00000002545 06601723724 013730 0 ustar gisle gisle package URI::file::Win32;
require URI::file::Base;
@ISA=qw(URI::file::Base);
use strict;
use URI::Escape qw(uri_unescape);
sub extract_authority
{
my $class = shift;
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;
}
sub extract_path
{
my($class, $path) = @_;
$path =~ s,\\,/,g;
$path =~ s,//+,/,g;
$path =~ s,(/\.)+/,/,g;
$path;
}
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 if /\0/;
return if /\//;
#return if /\\/; # URLs with "\" is not uncommon
}
return unless $class->fix_path(@path);
my $path = join("\\", @path);
$path =~ s/^\\// if $rel;
$path = $auth . $path;
$path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
$path;
}
sub fix_path { 1; }
1;
URI-1.30/URI/file/Unix.pm 0100644 0000764 0000764 00000001562 07457135752 013757 0 ustar gisle gisle package URI::file::Unix;
require URI::file::Base;
@ISA=qw(URI::file::Base);
use strict;
use URI::Escape qw(uri_unescape);
sub extract_path
{
my($class, $path) = @_;
# tidy path
$path =~ s,//+,/,g;
$path =~ s,(/\.)+/,/,g;
$path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
$path;
}
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->is_this_host($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 if /\0/;
return if /\//; # should we really?
}
join("/", @path);
}
1;
URI-1.30/URI/snews.pm 0100644 0000764 0000764 00000000166 06576171475 013256 0 ustar gisle gisle package URI::snews; # draft-gilman-news-url-01
require URI::news;
@ISA=qw(URI::news);
sub default_port { 563 }
1;
URI-1.30/URI/rsync.pm 0100644 0000764 0000764 00000000305 07052015657 013235 0 ustar gisle gisle package URI::rsync; # http://rsync.samba.org/
# rsync://[USER@]HOST[:PORT]/SRC
require URI::_server;
require URI::_userpass;
@ISA=qw(URI::_server URI::_userpass);
sub default_port { 873 }
1;
URI-1.30/URI/URL.pm 0100644 0000764 0000764 00000012632 10001242550 012525 0 ustar gisle gisle package URI::URL;
require URI::WithBase;
@ISA=qw(URI::WithBase);
use strict;
use vars qw(@EXPORT $VERSION);
$VERSION = "5.03";
# Provide as much as possible of the old URI::URL interface for backwards
# compatibility...
require Exporter;
*import = \&Exporter::import;
@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 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 loosing
# 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<URI::URL> class that used to
be distributed with the libwww-perl library.
The following differences exist compared to the C<URI> 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<URI::URL>
class is a subclass of C<URI::WithBase>.
=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<URI::WithBase>.
=item *
$url->abs and $url->rel have an optional $base argument. See
L<URI::WithBase>.
=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<URI>, L<URI::WithBase>
=head1 COPYRIGHT
Copyright 1998-2000 Gisle Aas.
=cut
URI-1.30/URI/_foreign.pm 0100644 0000764 0000764 00000000113 06577303347 013673 0 ustar gisle gisle package URI::_foreign;
require URI::_generic;
@ISA=qw(URI::_generic);
1;
URI-1.30/URI/tn3270.pm 0100644 0000764 0000764 00000000137 07604745010 013033 0 ustar gisle gisle package URI::tn3270;
require URI::_login;
@ISA = qw(URI::_login);
sub default_port { 23 }
1;
URI-1.30/URI/ftp.pm 0100644 0000764 0000764 00000002042 07413711610 012661 0 ustar gisle gisle package URI::ftp;
require URI::_server;
require URI::_userpass;
@ISA=qw(URI::_server URI::_userpass);
use strict;
sub default_port { 21 }
sub path { shift->path_query(@_) } # XXX
sub _user { shift->SUPER::user(@_); }
sub _password { shift->SUPER::password(@_); }
sub user
{
my $self = shift;
my $user = $self->_user(@_);
$user = "anonymous" unless defined $user;
$user;
}
sub password
{
my $self = shift;
my $pass = $self->_password(@_);
unless (defined $pass) {
my $user = $self->user;
if ($user eq 'anonymous' || $user eq 'ftp') {
# anonymous ftp login password
# If there is no ftp anonymous password specified
# then we'll just use 'anonymous@'
# We don't try to send the read e-mail address because:
# - We want to remain anonymous
# - We want to stop SPAM
# - We don't want to let ftp sites to discriminate by the user,
# host, country or ftp client being used.
$pass = 'anonymous@';
}
}
$pass;
}
1;
URI-1.30/URI/Escape.pm 0100644 0000764 0000764 00000011361 10001242470 013262 0 ustar gisle gisle #
# $Id: Escape.pm,v 3.22 2004/01/14 13:33:44 gisle Exp $
#
package URI::Escape;
use strict;
=head1 NAME
URI::Escape - Escape and unescape 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 escape and unescape URI strings as
defined by RFC 2396 (and updated by RFC 2732).
A URI consists of a restricted set of characters,
denoted as C<uric> in RFC 2396. 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:
"A" .. "Z", "a" .. "z", "0" .. "9",
";", "/", "?", ":", "@", "&", "=", "+", "$", ",", "[", "]", # 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 (iff the
character is part of C<uric>).
Some of the C<uric> characters are I<reserved> 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 2396 for further details.
The functions provided (and exported by default) from this module are:
=over 4
=item uri_escape($string, [$unsafe])
Replaces each unsafe character in the $string with the
corresponding escape sequence and returns the result.
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<not> part of the C<uric> character class shown above as well as the
reserved characters. I.e. the default is:
"^A-Za-z0-9\-_.!~*'()"
=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<sprintf("%%%02X", ord($byte))>
each time.
=head1 SEE ALSO
L<URI>
=head1 COPYRIGHT
Copyright 1995-2001 Gisle Aas.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
use vars qw(%escapes);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(uri_escape uri_unescape);
@EXPORT_OK = qw(%escapes);
$VERSION = sprintf("%d.%02d", q$Revision: 3.22 $ =~ /(\d+)\.(\d+)/);
use Carp ();
# Build a char->hex map
for (0..255) {
$escapes{chr($_)} = sprintf("%%%02X", $_);
}
my %subst; # compiled patternes
sub uri_escape
{
my($text, $patn) = @_;
return undef unless defined $text;
if (defined $patn){
unless (exists $subst{$patn}) {
# Because we can't compile the regex we fake it with a cached sub
(my $tmp = $patn) =~ s,/,\\/,g;
eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1}/g; }";
Carp::croak("uri_escape: $@") if $@;
}
&{$subst{$patn}}($text);
} else {
# Default unsafe characters. RFC 2732 ^(uric - reserved)
$text =~ s/([^A-Za-z0-9\-_.!~*'()])/$escapes{$1}/g;
}
$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
foreach (@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;
}
1;
URI-1.30/URI/urn/ 0040755 0000764 0000764 00000000000 10001246221 012327 5 ustar gisle gisle URI-1.30/URI/urn/oid.pm 0100644 0000764 0000764 00000000403 07512204441 013445 0 ustar gisle gisle package URI::urn::oid; # RFC 2061
require URI::urn;
@ISA=qw(URI::urn);
use strict;
sub oid {
my $self = shift;
my $old = $self->nss;
if (@_) {
$self->nss(join(".", @_));
}
return split(/\./, $old) if wantarray;
return $old;
}
1;
URI-1.30/URI/urn/isbn.pm 0100644 0000764 0000764 00000002147 07511617042 013640 0 ustar gisle gisle package URI::urn::isbn; # RFC 3187
require URI::urn;
@ISA=qw(URI::urn);
use strict;
use Business::ISBN ();
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;
}
sub isbn_country_code {
my $isbn = shift->_isbn || return undef;
return $isbn->country_code;
}
sub isbn_as_ean {
my $isbn = shift->_isbn || return undef;
return $isbn->as_ean;
}
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-1.30/URI/data.pm 0100644 0000764 0000764 00000006417 10001242550 013000 0 ustar gisle gisle package URI::data; # RFC 2397
require URI;
@ISA=qw(URI);
use strict;
use MIME::Base64 qw(encode_base64 decode_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;
return $base64 ? decode_base64($data) : uri_unescape($data);
}
# I could not find a better way to interpolate the tr/// chars from
# a variable.
my $ENC = $URI::uric;
$ENC =~ s/%//;
eval <<EOT; die $@ if $@;
sub _uric_count
{
\$_[0] =~ tr/$ENC//;
}
EOT
1;
__END__
=head1 NAME
URI::data - URI that contains immediate data
=head1 SYNOPSIS
use URI;
$u = URI->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<URI::data> class supports C<URI> objects belonging to the I<data>
URI scheme. The I<data> 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<URI> objects belonging to the data scheme support the common methods
(described in L<URI>) 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<URI>
=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-1.30/URI/Split.pm 0100644 0000764 0000764 00000004434 10001242543 013161 0 ustar gisle gisle package URI::Split;
use strict;
use vars qw(@ISA @EXPORT_OK);
require Exporter;
@ISA = qw(Exporter);
@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::escapes{$1},g;
$uri .= "//$auth";
$path = "/$path" if length($path) && $path !~ m,^/,;
}
elsif ($path =~ m,^//,) {
$uri .= "//"; # XXX force empty auth
}
unless (length $uri) {
$path =~ s,(:),$URI::Escape::escapes{$1}, while $path =~ m,^[^:/?\#]+:,;
}
$path =~ s,([?\#]),$URI::Escape::escapes{$1},g;
$uri .= $path;
if (defined $query) {
$query =~ s,(\#),$URI::Escape::escapes{$1},g;
$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<undef> 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<undef>.
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<undef> 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<URI>, L<URI::Escape>
=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-1.30/URI/_segment.pm 0100644 0000764 0000764 00000000571 06576171473 013716 0 ustar gisle gisle package URI::_segment;
# Represents a generic path_segment so that it can be treated as
# a string too.
use strict;
use URI::Escape qw(uri_unescape);
use overload '""' => sub { $_[0]->[0] },
fallback => 1;
sub new
{
my $class = shift;
my @segment = split(';', shift, -1);
$segment[0] = uri_unescape($segment[0]);
bless \@segment, $class;
}
1;
URI-1.30/URI/_query.pm 0100644 0000764 0000764 00000003756 07762360214 013420 0 ustar gisle gisle package URI::_query;
use strict;
use URI ();
use URI::Escape qw(uri_unescape);
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::escapes{$1}/go;
$$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 @new = @_;
if (@new == 1) {
my $n = $new[0];
if (ref($n) eq "ARRAY") {
@new = @$n;
}
elsif (ref($n) eq "HASH") {
@new = %$n;
}
}
my @query;
while (my($key,$vals) = splice(@new, 0, 2)) {
$key = '' unless defined $key;
$key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
$key =~ s/ /+/g;
$vals = [ref($vals) ? @$vals : $vals];
for my $val (@$vals) {
$val = '' unless defined $val;
$val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
$val =~ s/ /+/g;
push(@query, "$key=$val");
}
}
$self->query(@query ? join('&', @query) : undef);
}
return if !defined($old) || !length($old) || !defined(wantarray);
return unless $old =~ /=/; # not a form
map { s/\+/ /g; uri_unescape($_) }
map { /=/ ? split(/=/, $_, 2) : ($_ => '')} 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 && ref($copy[0]);
for (@copy) { s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; }
$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
*equery = \&query;
1;
URI-1.30/URI/rtspu.pm 0100644 0000764 0000764 00000000132 07515035611 013246 0 ustar gisle gisle package URI::rtspu;
require URI::rtsp;
@ISA=qw(URI::rtsp);
sub default_port { 554 }
1;
URI-1.30/URI/ldapi.pm 0100644 0000764 0000764 00000000714 07775127577 013215 0 ustar gisle gisle package URI::ldapi;
use strict;
use vars qw(@ISA);
require URI::_generic;
require URI::_ldap;
@ISA=qw(URI::_ldap URI::_generic);
require 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-1.30/URI/QueryParam.pm 0100644 0000764 0000764 00000011047 10001242543 014152 0 ustar gisle gisle package URI::QueryParam;
use strict;
sub URI::_query::query_param {
my $self = shift;
my @old = $self->query_form;
if (@_ == 0) {
# get keys
my %seen;
my @keys;
for (my $i = 0; $i < @old; $i += 2) {
push(@keys, $old[$i]) unless $seen{$old[$i]}++;
}
return @keys;
}
my $key = shift;
my @i;
for (my $i = 0; $i < @old; $i += 2) {
push(@i, $i) if $old[$i] eq $key;
}
if (@_) {
my @new = @old;
my @new_i = @i;
my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
#print "VALS:@vals [@i]\n";
while (@new_i > @vals) {
#print "REMOVE $new_i[-1]\n";
splice(@new, pop(@new_i), 2);
}
while (@vals > @new_i) {
my $i = @new_i ? $new_i[-1] + 2 : @new;
#print "SPLICE $i\n";
splice(@new, $i, 0, $key => pop(@vals));
}
for (@vals) {
#print "SET $new_i[0]\n";
$new[shift(@new_i)+1] = $_;
}
$self->query_form(\@new);
}
return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
}
sub URI::_query::query_param_append {
my $self = shift;
my $key = shift;
$self->query_form($self->query_form, $key => \@_); # XXX
return;
}
sub URI::_query::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 URI::_query::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 ref($_) eq "ARRAY";
push(@$_, $v);
}
}
else {
$hash{$k} = $v;
}
}
return \%hash;
}
1;
__END__
=head1 NAME
URI::QueryParam - Additional query methods for URIs
=head1 SYNOPSIS
use URI;
use URI::QueryParam;
$u = URI->new("", "http");
$u->query_param(foo => 1, 2, 3);
print $u->query; # prints foo=1&foo=2&foo=3
for my $key ($u->query_param) {
print "$key: ", join(", ", $u->query_param($key)), "\n";
}
=head1 DESCRIPTION
Loading the C<URI::QueryParam> module adds some extra methods to
URIs that support query methods. These methods provide an alternative
interface to the $u->query_form data.
The query_param_* methods have deliberately been made identical to the
interface of the corresponding C<CGI.pm> methods.
The following additional methods are made available:
=over
=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.
=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.
=back
=head1 SEE ALSO
L<URI>, L<CGI>
=head1 COPYRIGHT
Copyright 2002 Gisle Aas.
=cut
URI-1.30/URI/rlogin.pm 0100644 0000764 0000764 00000000140 06576171475 013401 0 ustar gisle gisle package URI::rlogin;
require URI::_login;
@ISA = qw(URI::_login);
sub default_port { 513 }
1;
URI-1.30/URI/https.pm 0100644 0000764 0000764 00000000131 06576171474 013250 0 ustar gisle gisle package URI::https;
require URI::http;
@ISA=qw(URI::http);
sub default_port { 443 }
1;
URI-1.30/URI/pop.pm 0100644 0000764 0000764 00000002226 06576171475 012714 0 ustar gisle gisle package URI::pop; # RFC 2384
require URI::_server;
@ISA=qw(URI::_server);
use strict;
use URI::Escape qw(uri_unescape);
sub default_port { 110 }
#pop://<user>;auth=<auth>@<host>:<port>
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 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 unless defined $old;
$old =~ s/^[^;]*//;
return uri_unescape($1) if $old =~ /;auth=(.*)/i;
return;
}
1;
URI-1.30/URI/http.pm 0100644 0000764 0000764 00000001431 07344042457 013061 0 ustar gisle gisle package URI::http;
require URI::_server;
@ISA=qw(URI::_server);
use strict;
use vars qw(%unreserved_escape);
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 = $other->clone if $other == $self;
unless (%unreserved_escape) {
for ("A" .. "Z", "a" .. "z", "0" .."9",
"-", "_", ".", "!", "~", "*", "'", "(", ")"
) {
$unreserved_escape{sprintf "%%%02X", ord($_)} = $_;
}
}
$$other =~ s/(%[0-9A-F]{2})/exists $unreserved_escape{$1} ?
$unreserved_escape{$1} : $1/ge;
$other->path("/") if $slash_path;
}
$other;
}
1;
URI-1.30/URI/sips.pm 0100644 0000764 0000764 00000000127 07530310367 013054 0 ustar gisle gisle package URI::sips;
require URI::sip;
@ISA=qw(URI::sip);
sub default_port { 5061 }
1;
URI-1.30/URI/mms.pm 0100644 0000764 0000764 00000000131 07774526046 012702 0 ustar gisle gisle package URI::mms;
require URI::http;
@ISA=qw(URI::http);
sub default_port { 1755 }
1;
URI-1.30/URI/nntp.pm 0100644 0000764 0000764 00000000133 06576171474 013067 0 ustar gisle gisle package URI::nntp; # draft-gilman-news-url-01
require URI::news;
@ISA=qw(URI::news);
1;
URI-1.30/URI/sip.pm 0100644 0000764 0000764 00000003321 07713746605 012703 0 ustar gisle gisle #
# Written by Ryan Kereliuk <ryker@ryker.org>. This file may be
# distributed under the same terms as Perl itself.
#
# The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
#
package URI::sip;
require URI::_server;
require URI::_userpass;
@ISA=qw(URI::_server URI::_userpass);
use strict;
use vars qw(@ISA $VERSION);
use URI::Escape qw(uri_unescape);
$VERSION = "0.10";
sub default_port { 5060 }
sub authority
{
my $self = shift;
$$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
my $old = $2;
if (@_) {
my $auth = shift;
$$self = defined($1) ? $1 : "";
my $rest = $3;
if (defined $auth) {
$auth =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
$$self .= "$auth";
}
$$self .= $rest;
}
$old;
}
sub params_form
{
my $self = shift;
$$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
my $paramstr = $3;
if (@_) {
my @args = @_;
$$self = $1 . $2;
my $rest = $4;
my @new;
for (my $i=0; $i < @args; $i += 2) {
push(@new, "$args[$i]=$args[$i+1]");
}
$paramstr = join(";", @new);
$$self .= ";" . $paramstr . $rest;
}
$paramstr =~ s/^;//o;
return split(/[;=]/, $paramstr);
}
sub params
{
my $self = shift;
$$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
my $paramstr = $3;
if (@_) {
my $new = shift;
$$self = $1 . $2;
my $rest = $4;
$$self .= $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 {};
sub rel {};
sub query_keywords {};
1;
URI-1.30/URI/ldaps.pm 0100644 0000764 0000764 00000000131 07775063635 013212 0 ustar gisle gisle package URI::ldaps;
require URI::ldap;
@ISA=qw(URI::ldap);
sub default_port { 636 }
1;
URI-1.30/URI/news.pm 0100644 0000764 0000764 00000002623 06576171474 013072 0 ustar gisle gisle package URI::news; # draft-gilman-news-url-01
require URI::_server;
@ISA=qw(URI::_server);
use strict;
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 unless $old =~ /\@/;
return $old;
}
1;
URI-1.30/URI/ssh.pm 0100644 0000764 0000764 00000000172 07370321364 012674 0 ustar gisle gisle package URI::ssh;
require URI::_login;
@ISA=qw(URI::_login);
# ssh://[USER@]HOST[:PORT]/SRC
sub default_port { 22 }
1;
URI-1.30/URI/ldap.pm 0100644 0000764 0000764 00000005665 10001242550 013013 0 ustar gisle gisle # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. 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 vars qw(@ISA $VERSION);
$VERSION = "1.11";
require URI::_server;
require URI::_ldap;
@ISA=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<URI::ldap> 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<URI::ldap> supports all the generic and server methods defined by
L<URI>, 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<Distinguished Name> 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<RFC-2255|http://www.cis.ohio-state.edu/htbin/rfc/rfc2255.html>
=head1 AUTHOR
Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
Slightly modified by Gisle Aas to f
