--- /dev/null
+#!/local/bin/perl -w
+
+use URI::URL qw(url);
+use URI::Escape qw(uri_escape uri_unescape);
+
+# want compatiblity
+use URI::file;
+$URI::file::DEFAULT_AUTHORITY = undef;
+
+# _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:pass@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";
+}
+
projects / dh-make-perl / blobdiff