git.maemo.org Git - dh-make-perl/blob - dev/i386/liburi-perl/liburi-perl-1.35.dfsg.1/t/old-base.t

   1 #!/local/bin/perl -w
   2
   3 use URI::URL qw(url);
   4 use URI::Escape qw(uri_escape uri_unescape);
   5
   6 # want compatiblity
   7 use URI::file;
   8 $URI::file::DEFAULT_AUTHORITY = undef;
   9
  10 # _expect()
  11 #
  12 # Handy low-level object method tester which we insert as a method
  13 # in the URI::URL class
  14 #
  15 sub URI::URL::_expect {
  16     my($self, $method, $expect, @args) = @_;
  17     my $result = $self->$method(@args);
  18     $expect = 'UNDEF' unless defined $expect;
  19     $result = 'UNDEF' unless defined $result;
  20     return 1 if $expect eq $result;
  21     warn "'$self'->$method(@args) = '$result' " .
  22                 "(expected '$expect')\n";
  23     $self->print_on('STDERR');
  24     die "Test Failed";
  25 }
  26
  27 package main;
  28
  29 # Must ensure that there is no relative paths in @INC because we will
  30 # chdir in the newlocal tests.
  31 unless ($^O eq "MacOS") {
  32 chomp($pwd = ($^O =~ /mswin32/i ? `cd` : $^O eq 'VMS' ? `show default` : `pwd`));
  33 if ($^O eq 'VMS') {
  34     $pwd =~ s#^\s+##;
  35     $pwd = VMS::Filespec::unixpath($pwd);
  36     $pwd =~ s#/$##;
  37 }
  38 for (@INC) {
  39     my $x = $_;
  40     $x = VMS::Filespec::unixpath($x) if $^O eq 'VMS';
  41     next if $x =~ m|^/| or $^O =~ /os2|mswin32/i
  42         and $x =~ m#^(\w:[\\/]|[\\/]{2})#;
  43     print "Turn lib path $x into $pwd/$x\n";
  44     $_ = "$pwd/$x";
  45
  46 }
  47 }
  48
  49 $| = 1;
  50
  51 print "1..8\n";  # for Test::Harness
  52
  53 # Do basic tests first.
  54 # Dies if an error has been detected, prints "ok" otherwise.
  55
  56 print "Self tests for URI::URL version $URI::URL::VERSION...\n";
  57
  58 eval { scheme_parse_test(); };
  59 print "not " if $@;
  60 print "ok 1\n";
  61
  62 eval { parts_test(); };
  63 print "not " if $@;
  64 print "ok 2\n";
  65
  66 eval { escape_test(); };
  67 print "not " if $@;
  68 print "ok 3\n";
  69
  70 eval { newlocal_test(); };
  71 print "not " if $@;
  72 print "ok 4\n";
  73
  74 eval { absolute_test(); };
  75 print "not " if $@;
  76 print "ok 5\n";
  77
  78 eval { eq_test(); };
  79 print "not " if $@;
  80 print "ok 6\n";
  81
  82 # Let's test making our own things
  83 URI::URL::strict(0);
  84 # This should work after URI::URL::strict(0)
  85 $url = new URI::URL "x-myscheme:something";
  86 # Since no implementor is registered for 'x-myscheme' then it will
  87 # be handled by the URI::URL::_generic class
  88 $url->_expect('as_string' => 'x-myscheme:something');
  89 $url->_expect('path' => 'something');
  90 URI::URL::strict(1);
  91
  92 =comment
  93
  94 # Let's try to make our URL subclass
  95 {
  96     package MyURL;
  97     @ISA = URI::URL::implementor();
  98
  99     sub _parse {
 100         my($self, $init) = @_;
 101         $self->URI::URL::_generic::_parse($init, qw(netloc path));
 102     }
 103
 104     sub foo {
 105         my $self = shift;
 106         print ref($self)."->foo called for $self\n";
 107     }
 108 }
 109 # Let's say that it implements the 'x-a+b.c' scheme (alias 'x-foo')
 110 URI::URL::implementor('x-a+b.c', 'MyURL');
 111 URI::URL::implementor('x-foo', 'MyURL');
 112
 113 # Now we are ready to try our new URL scheme
 114 $url = new URI::URL 'x-a+b.c://foo/bar;a?b';
 115 $url->_expect('as_string', 'x-a+b.c://foo/bar;a?b');
 116 $url->_expect('path', '/bar;a?b');
 117 $url->foo;
 118 $newurl = new URI::URL 'xxx', $url;
 119 $newurl->foo;
 120 $url = new URI::URL 'yyy', 'x-foo:';
 121 $url->foo;
 122
 123 =cut
 124
 125 print "ok 7\n";
 126
 127 # Test the new wash&go constructor
 128 print "not " if url("../foo.html", "http://www.sn.no/a/b")->abs->as_string
 129                 ne 'http://www.sn.no/foo.html';
 130 print "ok 8\n";
 131
 132 print "URI::URL version $URI::URL::VERSION ok\n";
 133
 134 exit 0;
 135
 136
 137
 138
 139 #####################################################################
 140 #
 141 # scheme_parse_test()
 142 #
 143 # test parsing and retrieval methods
 144
 145 sub scheme_parse_test {
 146
 147     print "scheme_parse_test:\n";
 148
 149     $tests = {
 150         'hTTp://web1.net/a/b/c/welcome#intro'
 151         => {    'scheme'=>'http', 'host'=>'web1.net', 'port'=>80,
 152                 'path'=>'/a/b/c/welcome', 'frag'=>'intro','query'=>undef,
 153                 'epath'=>'/a/b/c/welcome', 'equery'=>undef,
 154                 'params'=>undef, 'eparams'=>undef,
 155                 'as_string'=>'http://web1.net/a/b/c/welcome#intro',
 156                 'full_path' => '/a/b/c/welcome' },
 157
 158         'http://web:1/a?query+text'
 159         => {    'scheme'=>'http', 'host'=>'web', 'port'=>1,
 160                 'path'=>'/a', 'frag'=>undef, 'query'=>'query+text' },
 161
 162         'http://web.net/'
 163         => {    'scheme'=>'http', 'host'=>'web.net', 'port'=>80,
 164                 'path'=>'/', 'frag'=>undef, 'query'=>undef,
 165                 'full_path' => '/',
 166                 'as_string' => 'http://web.net/' },
 167
 168         'http://web.net'
 169         => {    'scheme'=>'http', 'host'=>'web.net', 'port'=>80,
 170                 'path'=>'/', 'frag'=>undef, 'query'=>undef,
 171                 'full_path' => '/',
 172                 'as_string' => 'http://web.net/' },
 173
 174         'http:0'
 175          => {   'scheme'=>'http', 'path'=>'0', 'query'=>undef,
 176                 'as_string'=>'http:0', 'full_path'=>'0', },
 177
 178         'http:/0?0'
 179          => {   'scheme'=>'http', 'path'=>'/0', 'query'=>'0',
 180                 'as_string'=>'http:/0?0', 'full_path'=>'/0?0', },
 181
 182         'http://0:0/0/0;0?0#0'
 183          => {   'scheme'=>'http', 'host'=>'0', 'port'=>'0',
 184                 'path' => '/0/0', 'query'=>'0', 'params'=>'0',
 185                 'netloc'=>'0:0',
 186                 'frag'=>0, 'as_string'=>'http://0:0/0/0;0?0#0' },
 187
 188         'ftp://0%3A:%40@h:0/0?0'
 189         =>  {   'scheme'=>'ftp', 'user'=>'0:', 'password'=>'@',
 190                 'host'=>'h', 'port'=>'0', 'path'=>'/0?0',
 191                 'query'=>'0', params=>undef,
 192                 'netloc'=>'0%3A:%40@h:0',
 193                 'as_string'=>'ftp://0%3A:%40@h:0/0?0' },
 194
 195         'ftp://usr:pswd@web:1234/a/b;type=i'
 196         => {    'host'=>'web', 'port'=>1234, 'path'=>'/a/b',
 197                 'user'=>'usr', 'password'=>'pswd',
 198                 'params'=>'type=i',
 199                 'as_string'=>'ftp://usr:pswd@web:1234/a/b;type=i' },
 200
 201         'ftp://host/a/b'
 202         => {    'host'=>'host', 'port'=>21, 'path'=>'/a/b',
 203                 'user'=>'anonymous',
 204                 'as_string'=>'ftp://host/a/b' },
 205
 206         'file://host/fseg/fs?g/fseg'
 207         # don't escape ? for file: scheme
 208         => {    'host'=>'host', 'path'=>'/fseg/fs?g/fseg',
 209                 'as_string'=>'file://host/fseg/fs?g/fseg' },
 210
 211         'gopher://host'
 212         => {     'gtype'=>'1', 'as_string' => 'gopher://host', },
 213
 214         'gopher://host/'
 215         => {     'gtype'=>'1', 'as_string' => 'gopher://host/', },
 216
 217         'gopher://gopher/2a_selector'
 218         => {    'gtype'=>'2', 'selector'=>'a_selector',
 219                 'as_string' => 'gopher://gopher/2a_selector', },
 220
 221         'mailto:libwww-perl@ics.uci.edu'
 222         => {    'address'       => 'libwww-perl@ics.uci.edu',
 223                 'encoded822addr'=> 'libwww-perl@ics.uci.edu',
 224 #               'user'          => 'libwww-perl',
 225 #               'host'          => 'ics.uci.edu',
 226                 'as_string'     => 'mailto:libwww-perl@ics.uci.edu', },
 227
 228         'news:*'
 229         => {    'groupart'=>'*', 'group'=>'*', as_string=>'news:*' },
 230         'news:comp.lang.perl'
 231         => {    'group'=>'comp.lang.perl' },
 232         'news:perl-faq/module-list-1-794455075@ig.co.uk'
 233         => {    'article'=>
 234                     'perl-faq/module-list-1-794455075@ig.co.uk' },
 235
 236         'nntp://news.com/comp.lang.perl/42'
 237         => {    'group'=>'comp.lang.perl', }, #'digits'=>42 },
 238
 239         'telnet://usr:pswd@web:12345/'
 240         => {    'user'=>'usr', 'password'=>'pswd', 'host'=>'web' },
 241         'rlogin://aas@a.sn.no'
 242         => {    'user'=>'aas', 'host'=>'a.sn.no' },
 243 #       'tn3270://aas@ibm'
 244 #       => {    'user'=>'aas', 'host'=>'ibm',
 245 #               'as_string'=>'tn3270://aas@ibm/'},
 246
 247 #       'wais://web.net/db'
 248 #       => { 'database'=>'db' },
 249 #       'wais://web.net/db?query'
 250 #       => { 'database'=>'db', 'query'=>'query' },
 251 #       'wais://usr:pswd@web.net/db/wt/wp'
 252 #       => {    'database'=>'db', 'wtype'=>'wt', 'wpath'=>'wp',
 253 #               'password'=>'pswd' },
 254     };
 255
 256     foreach $url_str (sort keys %$tests ){
 257         print "Testing '$url_str'\n";
 258         my $url = new URI::URL $url_str;
 259         my $tests = $tests->{$url_str};
 260         while( ($method, $exp) = each %$tests ){
 261             $exp = 'UNDEF' unless defined $exp;
 262             $url->_expect($method, $exp);
 263         }
 264     }
 265 }
 266
 267
 268 #####################################################################
 269 #
 270 # parts_test()          (calls netloc_test test)
 271 #
 272 # Test individual component part access functions
 273 #
 274 sub parts_test {
 275     print "parts_test:\n";
 276
 277     # test storage part access/edit methods (netloc, user, password,
 278     # host and port are tested by &netloc_test)
 279
 280     $url = new URI::URL 'file://web/orig/path';
 281     $url->scheme('http');
 282     $url->path('1info');
 283     $url->query('key words');
 284     $url->frag('this');
 285     $url->_expect('as_string' => 'http://web/1info?key%20words#this');
 286
 287     $url->epath('%2f/%2f');
 288     $url->equery('a=%26');
 289     $url->_expect('full_path' => '/%2f/%2f?a=%26');
 290
 291     # At this point it should be impossible to access the members path()
 292     # and query() without complaints.
 293     eval { my $p = $url->path; print "Path is $p\n"; };
 294     die "Path exception failed" unless $@;
 295     eval { my $p = $url->query; print "Query is $p\n"; };
 296     die "Query exception failed" unless $@;
 297
 298     # but we should still be able to set it
 299     $url->path("howdy");
 300     $url->_expect('as_string' => 'http://web/howdy?a=%26#this');
 301
 302     # Test the path_components function
 303     $url = new URI::URL 'file:%2f/%2f';
 304     my $p;
 305     $p = join('-', $url->path_components);
 306     die "\$url->path_components returns '$p', expected '/-/'"
 307       unless $p eq "/-/";
 308     $url->host("localhost");
 309     $p = join('-', $url->path_components);
 310     die "\$url->path_components returns '$p', expected '-/-/'"
 311       unless $p eq "-/-/";
 312     $url->epath("/foo/bar/");
 313     $p = join('-', $url->path_components);
 314     die "\$url->path_components returns '$p', expected '-foo-bar-'"
 315       unless $p eq "-foo-bar-";
 316     $url->path_components("", "/etc", "\0", "..", "øse", "");
 317     $url->_expect('full_path' => '/%2Fetc/%00/../%F8se/');
 318
 319     # Setting undef
 320     $url = new URI::URL 'http://web/p;p?q#f';
 321     $url->epath(undef);
 322     $url->equery(undef);
 323     $url->eparams(undef);
 324     $url->frag(undef);
 325     $url->_expect('as_string' => 'http://web');
 326
 327     # Test http query access methods
 328     $url->keywords('dog');
 329     $url->_expect('as_string' => 'http://web?dog');
 330     $url->keywords(qw(dog bones));
 331     $url->_expect('as_string' => 'http://web?dog+bones');
 332     $url->keywords(0,0);
 333     $url->_expect('as_string' => 'http://web?0+0');
 334     $url->keywords('dog', 'bones', '#+=');
 335     $url->_expect('as_string' => 'http://web?dog+bones+%23%2B%3D');
 336     $a = join(":", $url->keywords);
 337     die "\$url->keywords did not work (returned '$a')" unless $a eq 'dog:bones:#+=';
 338     # calling query_form is an error
 339 #    eval { my $foo = $url->query_form; };
 340 #    die "\$url->query_form should croak since query contains keywords not a form."
 341 #      unless $@;
 342
 343     $url->query_form(a => 'foo', b => 'bar');
 344     $url->_expect('as_string' => 'http://web?a=foo&b=bar');
 345     my %a = $url->query_form;
 346     die "\$url->query_form did not work"
 347       unless $a{a} eq 'foo' && $a{b} eq 'bar';
 348
 349     $url->query_form(a => undef, a => 'foo', '&=' => '&=+');
 350     $url->_expect('as_string' => 'http://web?a=&a=foo&%26%3D=%26%3D%2B');
 351
 352     my @a = $url->query_form;
 353     die "Wrong length" unless @a == 6;
 354     die "Bad keys from query_form"
 355       unless $a[0] eq 'a' && $a[2] eq 'a' && $a[4] eq '&=';
 356     die "Bad values from query_form"
 357       unless $a[1] eq '' && $a[3] eq 'foo' && $a[5] eq '&=+';
 358
 359     # calling keywords is an error
 360 #    eval { my $foo = $url->keywords; };
 361 #    die "\$url->keywords should croak when query is a form"
 362 #      unless $@;
 363     # Try this odd one
 364     $url->equery('&=&=b&a=&a&a=b=c&&a=b');
 365     @a = $url->query_form;
 366     #print join(":", @a), "\n";
 367     die "Wrong length" unless @a == 16;
 368     die "Wrong sequence" unless $a[4]  eq ""  && $a[5]  eq "b" &&
 369                                 $a[10] eq "a" && $a[11] eq "b=c";
 370
 371     # Try array ref values in the key value pairs
 372     $url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']);
 373     $url->_expect('as_string', 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo');
 374
 375
 376     netloc_test();
 377     port_test();
 378
 379     $url->query(undef);
 380     $url->_expect('query', undef);
 381
 382     $url = new URI::URL 'gopher://gopher/';
 383     $url->port(33);
 384     $url->gtype("3");
 385     $url->selector("S");
 386     $url->search("query");
 387     $url->_expect('as_string', 'gopher://gopher:33/3S%09query');
 388
 389     $url->epath("45%09a");
 390     $url->_expect('gtype' => '4');
 391     $url->_expect('selector' => '5');
 392     $url->_expect('search' => 'a');
 393     $url->_expect('string' => undef);
 394     $url->_expect('path' => "/45\ta");
 395 #    $url->path("00\t%09gisle");
 396 #    $url->_expect('search', '%09gisle');
 397
 398     # Let's test som other URL schemes
 399     $url = new URI::URL 'news:';
 400     $url->group("comp.lang.perl.misc");
 401     $url->_expect('as_string' => 'news:comp.lang.perl.misc');
 402     $url->article('<1234@a.sn.no>');
 403     $url->_expect('as_string' => 'news:1234@a.sn.no'); # "<" and ">" are gone
 404     # This one should be illegal
 405     eval { $url->article("no.perl"); };
 406     die "This one should really complain" unless $@;
 407
 408 #    $url = new URI::URL 'mailto:';
 409 #    $url->user("aas");
 410 #    $url->host("a.sn.no");
 411 #    $url->_expect("as_string" => 'mailto:aas@a.sn.no');
 412 #    $url->address('foo@bar');
 413 #    $url->_expect("host" => 'bar');
 414 #    $url->_expect("user" => 'foo');
 415
 416 #    $url = new URI::URL 'wais://host/database/wt/wpath';
 417 #    $url->database('foo');
 418 #    $url->_expect('as_string' => 'wais://host/foo/wt/wpath');
 419 #    $url->wtype('bar');
 420 #    $url->_expect('as_string' => 'wais://host/foo/bar/wpath');
 421
 422     # Test crack method for various URLs
 423     my(@crack, $crack);
 424     @crack = URI::URL->new("http://host/path;param?query#frag")->crack;
 425     die "Cracked result should be 9 elements" unless @crack == 9;
 426     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 427     print "Cracked result: $crack\n";
 428     die "Bad crack result" unless
 429       $crack eq "http*UNDEF*UNDEF*host*80*/path*param*query*frag";
 430
 431     @crack = URI::URL->new("foo/bar", "ftp://aas\@ftp.sn.no/")->crack;
 432     die "Cracked result should be 9 elements" unless @crack == 9;
 433     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 434     print "Cracked result: $crack\n";
 435 #    die "Bad crack result" unless
 436 #      $crack eq "ftp*UNDEF*UNDEF*UNDEF*21*foo/bar*UNDEF*UNDEF*UNDEF";
 437
 438     @crack = URI::URL->new('ftp://u:p@host/q?path')->crack;
 439     die "Cracked result should be 9 elements" unless @crack == 9;
 440     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 441     print "Cracked result: $crack\n";
 442     die "Bad crack result" unless
 443       $crack eq "ftp*u*p*host*21*/q?path*UNDEF*path*UNDEF";
 444
 445     @crack = URI::URL->new("ftp://ftp.sn.no/pub")->crack;    # Test anon ftp
 446     die "Cracked result should be 9 elements" unless @crack == 9;
 447     die "No passwd in anonymous crack" unless $crack[2];
 448     $crack[2] = 'passwd';  # easier to test when we know what it is
 449     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 450     print "Cracked result: $crack\n";
 451     die "Bad crack result" unless
 452       $crack eq "ftp*anonymous*passwd*ftp.sn.no*21*/pub*UNDEF*UNDEF*UNDEF";
 453
 454     @crack = URI::URL->new('mailto:aas@sn.no')->crack;
 455     die "Cracked result should be 9 elements" unless @crack == 9;
 456     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 457     print "Cracked result: $crack\n";
 458 #    die "Bad crack result" unless
 459 #      $crack eq "mailto*aas*UNDEF*sn.no*UNDEF*aas\@sn.no*UNDEF*UNDEF*UNDEF";
 460
 461     @crack = URI::URL->new('news:comp.lang.perl.misc')->crack;
 462     die "Cracked result should be 9 elements" unless @crack == 9;
 463     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
 464     print "Cracked result: $crack\n";
 465     die "Bad crack result" unless
 466       $crack eq "news*UNDEF*UNDEF*UNDEF*119*comp.lang.perl.misc*UNDEF*UNDEF*UNDEF";
 467 }
 468
 469 #
 470 # netloc_test()
 471 #
 472 # Test automatic netloc synchronisation
 473 #
 474 sub netloc_test {
 475     print "netloc_test:\n";
 476
 477     my $url = new URI::URL 'ftp://anonymous:p%61ss@håst:12345';
 478     $url->_expect('user', 'anonymous');
 479     $url->_expect('password', 'pass');
 480     $url->_expect('host', 'håst');
 481     $url->_expect('port', 12345);
 482     # Can't really know how netloc is represented since it is partially escaped
 483     #$url->_expect('netloc', 'anonymous:pass@hst:12345');
 484     $url->_expect('as_string' => 'ftp://anonymous:pass@h%E5st:12345');
 485
 486     # The '0' is sometimes tricky to get right
 487     $url->user(0);
 488     $url->password(0);
 489     $url->host(0);
 490     $url->port(0);
 491     $url->_expect('netloc' => '0:0@0:0');
 492     $url->host(undef);
 493     $url->_expect('netloc' => '0:0@:0');
 494     $url->host('h');
 495     $url->user(undef);
 496     $url->_expect('netloc' => ':0@h:0');
 497     $url->user('');
 498     $url->_expect('netloc' => ':0@h:0');
 499     $url->password('');
 500     $url->_expect('netloc' => ':@h:0');
 501     $url->user('foo');
 502     $url->_expect('netloc' => 'foo:@h:0');
 503
 504     # Let's try a simple one
 505     $url->user('nemo');
 506     $url->password('p2');
 507     $url->host('hst2');
 508     $url->port(2);
 509     $url->_expect('netloc' => 'nemo:p2@hst2:2');
 510
 511     $url->user(undef);
 512     $url->password(undef);
 513     $url->port(undef);
 514     $url->_expect('netloc' => 'hst2');
 515     $url->_expect('port' => '21');  # the default ftp port
 516
 517     $url->port(21);
 518     $url->_expect('netloc' => 'hst2:21');
 519
 520     # Let's try some reserved chars
 521     $url->user("@");
 522     $url->password(":-#-;-/-?");
 523     $url->_expect('as_string' => 'ftp://%40::-%23-;-%2F-%3F@hst2:21');
 524
 525 }
 526
 527 #
 528 # port_test()
 529 #
 530 # Test port behaviour
 531 #
 532 sub port_test {
 533     print "port_test:\n";
 534
 535     $url = URI::URL->new('http://foo/root/dir/');
 536     my $port = $url->port;
 537     die "Port undefined" unless defined $port;
 538     die "Wrong port $port" unless $port == 80;
 539     die "Wrong string" unless $url->as_string eq
 540         'http://foo/root/dir/';
 541
 542     $url->port(8001);
 543     $port = $url->port;
 544     die "Port undefined" unless defined $port;
 545     die "Wrong port $port" unless $port == 8001;
 546     die "Wrong string" unless $url->as_string eq
 547         'http://foo:8001/root/dir/';
 548
 549     $url->port(80);
 550     $port = $url->port;
 551     die "Port undefined" unless defined $port;
 552     die "Wrong port $port" unless $port == 80;
 553     die "Wrong string" unless $url->canonical->as_string eq
 554         'http://foo/root/dir/';
 555
 556     $url->port(8001);
 557     $url->port(undef);
 558     $port = $url->port;
 559     die "Port undefined" unless defined $port;
 560     die "Wrong port $port" unless $port == 80;
 561     die "Wrong string" unless $url->as_string eq
 562         'http://foo/root/dir/';
 563 }
 564
 565
 566 #####################################################################
 567 #
 568 # escape_test()
 569 #
 570 # escaping functions
 571
 572 sub escape_test {
 573     print "escape_test:\n";
 574
 575     # supply escaped URL
 576     $url = new URI::URL 'http://web/this%20has%20spaces';
 577     # check component is unescaped
 578     $url->_expect('path', '/this has spaces');
 579
 580     # modify the unescaped form
 581     $url->path('this ALSO has spaces');
 582     # check whole url is escaped
 583     $url->_expect('as_string',
 584                   'http://web/this%20ALSO%20has%20spaces');
 585
 586     $url = new URI::URL uri_escape('http://web/try %?#" those');
 587     $url->_expect('as_string',
 588                   'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those');
 589
 590     my $all = pack('C*',0..255);
 591     my $esc = uri_escape($all);
 592     my $new = uri_unescape($esc);
 593     die "uri_escape->uri_unescape mismatch" unless $all eq $new;
 594
 595     $url->path($all);
 596     $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));
 597
 598     # test escaping uses uppercase (preferred by rfc1837)
 599     $url = new URI::URL 'file://h/';
 600     $url->path(chr(0x7F));
 601     $url->_expect('as_string', 'file://h/%7F');
 602
 603     return;
 604     # reserved characters differ per scheme
 605
 606     ## XXX is this '?' allowed to be unescaped
 607     $url = new URI::URL 'file://h/test?ing';
 608     $url->_expect('path', '/test?ing');
 609
 610     $url = new URI::URL 'file://h/';
 611     $url->epath('question?mark');
 612     $url->_expect('as_string', 'file://h/question?mark');
 613     # XXX Why should this be any different???
 614     #     Perhaps we should not expect too much :-)
 615     $url->path('question?mark');
 616     $url->_expect('as_string', 'file://h/question%3Fmark');
 617
 618     # See what happens when set different elements to this ugly sting
 619     my $reserved = ';/?:@&=#%';
 620     $url->path($reserved . "foo");
 621     $url->_expect('as_string', 'file://h/%3B/%3F%3A%40%26%3D%23%25foo');
 622
 623     $url->scheme('http');
 624     $url->path('');
 625     $url->_expect('as_string', 'http://h/');
 626     $url->query($reserved);
 627     $url->params($reserved);
 628     $url->frag($reserved);
 629     $url->_expect('as_string', 'http://h/;%3B%2F%3F%3A%40&=%23%25?%3B%2F%3F%3A%40&=%23%25#;/?:@&=#%');
 630
 631     $str = $url->as_string;
 632     $url = new URI::URL $str;
 633     die "URL changed" if $str ne $url->as_string;
 634
 635     $url = new URI::URL 'ftp:foo';
 636     $url->user($reserved);
 637     $url->host($reserved);
 638     $url->_expect('as_string', 'ftp://%3B%2F%3F%3A%40%26%3D%23%25@%3B%2F%3F%3A%40%26%3D%23%25/foo');
 639
 640 }
 641
 642
 643 #####################################################################
 644 #
 645 # newlocal_test()
 646 #
 647
 648 sub newlocal_test {
 649     return 1 if $^O eq "MacOS";
 650
 651     print "newlocal_test:\n";
 652     my $isMSWin32 = ($^O =~ /MSWin32/i);
 653     my $pwd = ($isMSWin32 ? 'cd' :
 654               ($^O eq 'qnx' ? '/usr/bin/fullpath -t' :
 655               ($^O eq 'VMS' ? 'show default' :
 656               (-e '/bin/pwd' ? '/bin/pwd' : 'pwd'))));
 657     my $tmpdir = ($^O eq 'MSWin32' ? $ENV{TEMP} : '/tmp');
 658     if ( $^O eq 'qnx' ) {
 659         $tmpdir = `/usr/bin/fullpath -t $tmpdir`;
 660         chomp $tmpdir;
 661     }
 662     $tmpdir = '/sys$scratch' if $^O eq 'VMS';
 663     $tmpdir =~ tr|\\|/|;
 664
 665     my $savedir = `$pwd`;     # we don't use Cwd.pm because we want to check
 666                               # that it get require'd correctly by URL.pm
 667     chomp $savedir;
 668     if ($^O eq 'VMS') {
 669         $savedir =~ s#^\s+##;
 670         $savedir = VMS::Filespec::unixpath($savedir);
 671         $savedir =~ s#/$##;
 672     }
 673
 674     # cwd
 675     chdir($tmpdir) or die $!;
 676     my $dir = `$pwd`; $dir =~ tr|\\|/|;
 677     chomp $dir;
 678     if ($^O eq 'VMS') {
 679         $dir =~ s#^\s+##;
 680         $dir = VMS::Filespec::unixpath($dir);
 681         $dir =~ s#/$##;
 682     }
 683     $dir = uri_escape($dir, ':');
 684     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2';
 685     $url = newlocal URI::URL;
 686     my $ss = $isMSWin32 ? '//' : (($dir =~ m,^/,) ? '' : '///' );
 687     $url->_expect('as_string', URI::URL->new("file:$ss$dir/")->as_string);
 688
 689     print "Local directory is ". $url->local_path . "\n";
 690
 691     if ($^O ne 'VMS') {
 692     # absolute dir
 693     chdir('/') or die $!;
 694     $url = newlocal URI::URL '/usr/';
 695     $url->_expect('as_string', 'file:/usr/');
 696
 697     # absolute file
 698     $url = newlocal URI::URL '/vmunix';
 699     $url->_expect('as_string', 'file:/vmunix');
 700     }
 701
 702     # relative file
 703     chdir($tmpdir) or die $!;
 704     $dir = `$pwd`; $dir =~ tr|\\|/|;
 705     chomp $dir;
 706     if ($^O eq 'VMS') {
 707         $dir =~ s#^\s+##;
 708         $dir = VMS::Filespec::unixpath($dir);
 709         $dir =~ s#/$##;
 710     }
 711     $dir = uri_escape($dir, ':');
 712     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2';
 713     $url = newlocal URI::URL 'foo';
 714     $url->_expect('as_string', "file:$ss$dir/foo");
 715
 716     # relative dir
 717     chdir($tmpdir) or die $!;
 718     $dir = `$pwd`; $dir =~ tr|\\|/|;
 719     chomp $dir;
 720     if ($^O eq 'VMS') {
 721         $dir =~ s#^\s+##;
 722         $dir = VMS::Filespec::unixpath($dir);
 723         $dir =~ s#/$##;
 724     }
 725     $dir = uri_escape($dir, ':');
 726     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2';
 727     $url = newlocal URI::URL 'bar/';
 728     $url->_expect('as_string', "file:$ss$dir/bar/");
 729
 730     # 0
 731     if ($^O ne 'VMS') {
 732     chdir('/') or die $!;
 733     $dir = `$pwd`; $dir =~ tr|\\|/|;
 734         chomp $dir;
 735         $dir = uri_escape($dir, ':');
 736     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2';
 737     $url = newlocal URI::URL '0';
 738     $url->_expect('as_string', "file:$ss${dir}0");
 739     }
 740
 741     # Test access methods for file URLs
 742     $url = new URI::URL 'file:/c:/dos';
 743     $url->_expect('dos_path', 'C:\\DOS');
 744     $url->_expect('unix_path', '/c:/dos');
 745     #$url->_expect('vms_path', '[C:]DOS');
 746     $url->_expect('mac_path',  'UNDEF');
 747
 748     $url = new URI::URL 'file:/foo/bar';
 749     $url->_expect('unix_path', '/foo/bar');
 750     $url->_expect('mac_path', 'foo:bar');
 751
 752     # Some edge cases
 753 #    $url = new URI::URL 'file:';
 754 #    $url->_expect('unix_path', '/');
 755     $url = new URI::URL 'file:/';
 756     $url->_expect('unix_path', '/');
 757     $url = new URI::URL 'file:.';
 758     $url->_expect('unix_path', '.');
 759     $url = new URI::URL 'file:./foo';
 760     $url->_expect('unix_path', './foo');
 761     $url = new URI::URL 'file:0';
 762     $url->_expect('unix_path', '0');
 763     $url = new URI::URL 'file:../../foo';
 764     $url->_expect('unix_path', '../../foo');
 765     $url = new URI::URL 'file:foo/../bar';
 766     $url->_expect('unix_path', 'foo/../bar');
 767
 768     # Relative files
 769     $url = new URI::URL 'file:foo/b%61r/Note.txt';
 770     $url->_expect('unix_path', 'foo/bar/Note.txt');
 771     $url->_expect('mac_path', ':foo:bar:Note.txt');
 772     $url->_expect('dos_path', 'FOO\\BAR\\NOTE.TXT');
 773     #$url->_expect('vms_path', '[.FOO.BAR]NOTE.TXT');
 774
 775     # The VMS path found in RFC 1738 (section 3.10)
 776     $url = new URI::URL 'file://vms.host.edu/disk$user/my/notes/note12345.txt';
 777 #    $url->_expect('vms_path', 'DISK$USER:[MY.NOTES]NOTE12345.TXT');
 778 #    $url->_expect('mac_path', 'disk$user:my:notes:note12345.txt');
 779
 780     chdir($savedir) or die $!;
 781 }
 782
 783
 784 #####################################################################
 785 #
 786 # absolute_test()
 787 #
 788 sub absolute_test {
 789
 790     print "Test relative/absolute URI::URL parsing:\n";
 791
 792     # Tests from draft-ietf-uri-relative-url-06.txt
 793     # Copied verbatim from the draft, parsed below
 794
 795     @URI::URL::g::ISA = qw(URI::URL::_generic); # for these tests
 796
 797     my $base = 'http://a/b/c/d;p?q#f';
 798
 799     $absolute_tests = <<EOM;
 800 5.1.  Normal Examples
 801
 802       g:h        = <URL:g:h>
 803       g          = <URL:http://a/b/c/g>
 804       ./g        = <URL:http://a/b/c/g>
 805       g/         = <URL:http://a/b/c/g/>
 806       /g         = <URL:http://a/g>
 807       //g        = <URL:http://g>
 808 #      ?y         = <URL:http://a/b/c/d;p?y>
 809       g?y        = <URL:http://a/b/c/g?y>
 810       g?y/./x    = <URL:http://a/b/c/g?y/./x>
 811       #s         = <URL:http://a/b/c/d;p?q#s>
 812       g#s        = <URL:http://a/b/c/g#s>
 813       g#s/./x    = <URL:http://a/b/c/g#s/./x>
 814       g?y#s      = <URL:http://a/b/c/g?y#s>
 815  #     ;x         = <URL:http://a/b/c/d;x>
 816       g;x        = <URL:http://a/b/c/g;x>
 817       g;x?y#s    = <URL:http://a/b/c/g;x?y#s>
 818       .          = <URL:http://a/b/c/>
 819       ./         = <URL:http://a/b/c/>
 820       ..         = <URL:http://a/b/>
 821       ../        = <URL:http://a/b/>
 822       ../g       = <URL:http://a/b/g>
 823       ../..      = <URL:http://a/>
 824       ../../     = <URL:http://a/>
 825       ../../g    = <URL:http://a/g>
 826
 827 5.2.  Abnormal Examples
 828
 829    Although the following abnormal examples are unlikely to occur
 830    in normal practice, all URL parsers should be capable of resolving
 831    them consistently.  Each example uses the same base as above.
 832
 833    An empty reference resolves to the complete base URL:
 834
 835       <>         = <URL:http://a/b/c/d;p?q#f>
 836
 837    Parsers must be careful in handling the case where there are more
 838    relative path ".." segments than there are hierarchical levels in
 839    the base URL's path.  Note that the ".." syntax cannot be used to
 840    change the <net_loc> of a URL.
 841
 842      ../../../g = <URL:http://a/../g>
 843      ../../../../g = <URL:http://a/../../g>
 844
 845    Similarly, parsers must avoid treating "." and ".." as special
 846    when they are not complete components of a relative path.
 847
 848       /./g       = <URL:http://a/./g>
 849       /../g      = <URL:http://a/../g>
 850       g.         = <URL:http://a/b/c/g.>
 851       .g         = <URL:http://a/b/c/.g>
 852       g..        = <URL:http://a/b/c/g..>
 853       ..g        = <URL:http://a/b/c/..g>
 854
 855    Less likely are cases where the relative URL uses unnecessary or
 856    nonsensical forms of the "." and ".." complete path segments.
 857
 858       ./../g     = <URL:http://a/b/g>
 859       ./g/.      = <URL:http://a/b/c/g/>
 860       g/./h      = <URL:http://a/b/c/g/h>
 861       g/../h     = <URL:http://a/b/c/h>
 862
 863    Finally, some older parsers allow the scheme name to be present in
 864    a relative URL if it is the same as the base URL scheme.  This is
 865    considered to be a loophole in prior specifications of partial
 866    URLs [1] and should be avoided by future parsers.
 867
 868       http:g     = <URL:http:g>
 869       http:      = <URL:http:>
 870 EOM
 871     # convert text to list like
 872     # @absolute_tests = ( ['g:h' => 'g:h'], ...)
 873
 874     for $line (split("\n", $absolute_tests)) {
 875         next unless $line =~ /^\s{6}/;
 876         if ($line =~ /^\s+(\S+)\s*=\s*<URL:([^>]*)>/) {
 877             my($rel, $abs) = ($1, $2);
 878             $rel = '' if $rel eq '<>';
 879             push(@absolute_tests, [$rel, $abs]);
 880         }
 881         else {
 882             warn "illegal line '$line'";
 883         }
 884     }
 885
 886     # add some extra ones for good measure
 887
 888     push(@absolute_tests, ['x/y//../z' => 'http://a/b/c/x/y/z'],
 889                           ['1'         => 'http://a/b/c/1'    ],
 890                           ['0'         => 'http://a/b/c/0'    ],
 891                           ['/0'        => 'http://a/0'        ],
 892 #                         ['%2e/a'     => 'http://a/b/c/%2e/a'],  # %2e is '.'
 893 #                         ['%2e%2e/a'  => 'http://a/b/c/%2e%2e/a'],
 894         );
 895
 896     print "  Relative    +  Base  =>  Expected Absolute URL\n";
 897     print "================================================\n";
 898     for $test (@absolute_tests) {
 899         my($rel, $abs) = @$test;
 900         my $abs_url = new URI::URL $abs;
 901         my $abs_str = $abs_url->as_string;
 902
 903         printf("  %-10s  +  $base  =>  %s\n", $rel, $abs);
 904         my $u   = new URI::URL $rel, $base;
 905         my $got = $u->abs;
 906         $got->_expect('as_string', $abs_str);
 907     }
 908
 909     # bug found and fixed in 1.9 by "J.E. Fritz" <FRITZ@gems.vcu.edu>
 910     $base = new URI::URL 'http://host/directory/file';
 911     my $relative = new URI::URL 'file', $base;
 912     my $result = $relative->abs;
 913
 914     my ($a, $b) = ($base->path, $result->path);
 915         die "'$a' and '$b' should be the same" unless $a eq $b;
 916
 917     # Counter the expectation of least surprise,
 918     # section 6 of the draft says the URL should
 919     # be canonicalised, rather than making a simple
 920     # substitution of the last component.
 921     # Better doublecheck someone hasn't "fixed this bug" :-)
 922     $base = new URI::URL 'http://host/dir1/../dir2/file';
 923     $relative = new URI::URL 'file', $base;
 924     $result = $relative->abs;
 925     die 'URL not canonicalised' unless $result eq 'http://host/dir2/file';
 926
 927     print "--------\n";
 928     # Test various other kinds of URLs and how they like to be absolutized
 929     for (["http://abc/", "news:45664545", "http://abc/"],
 930          ["news:abc",    "http://abc/",   "news:abc"],
 931          ["abc",         "file:/test?aas", "file:/abc"],
 932 #        ["gopher:",     "",               "gopher:"],
 933 #        ["?foo",        "http://abc/a",   "http://abc/a?foo"],
 934          ["?foo",        "file:/abc",      "file:/?foo"],
 935          ["#foo",        "http://abc/a",   "http://abc/a#foo"],
 936          ["#foo",        "file:a",         "file:a#foo"],
 937          ["#foo",        "file:/a",         "file:/a#foo"],
 938          ["#foo",        "file:/a",         "file:/a#foo"],
 939          ["#foo",        "file://localhost/a", "file://localhost/a#foo"],
 940          ['123@sn.no',   "news:comp.lang.perl.misc", 'news:/123@sn.no'],
 941          ['no.perl',     'news:123@sn.no',           'news:/no.perl'],
 942          ['mailto:aas@a.sn.no', "http://www.sn.no/", 'mailto:aas@a.sn.no'],
 943
 944          # Test absolutizing with old behaviour.
 945          ['http:foo',     'http://h/a/b',   'http://h/a/foo'],
 946          ['http:/foo',    'http://h/a/b',   'http://h/foo'],
 947          ['http:?foo',    'http://h/a/b',   'http://h/a/b?foo'],
 948          ['http:#foo',    'http://h/a/b',   'http://h/a/b#foo'],
 949          ['http:?foo#bar','http://h/a/b',   'http://h/a/b?foo#bar'],
 950          ['file:/foo',    'http://h/a/b',   'file:/foo'],
 951
 952         )
 953     {
 954         my($url, $base, $expected_abs) = @$_;
 955         my $rel = new URI::URL $url, $base;
 956         my $abs = $rel->abs($base, 1);
 957         printf("  %-12s+  $base  =>  %s\n", $rel, $abs);
 958         $abs->_expect('as_string', $expected_abs);
 959     }
 960     print "absolute test ok\n";
 961
 962     # Test relative function
 963     for (
 964          ["http://abc/a",   "http://abc",        "a"],
 965          ["http://abc/a",   "http://abc/b",      "a"],
 966          ["http://abc/a?q", "http://abc/b",      "a?q"],
 967          ["http://abc/a;p", "http://abc/b",      "a;p"],
 968          ["http://abc/a",   "http://abc/a/b/c/", "../../../a"],
 969          ["http://abc/a/",  "http://abc/a/",     "./"],
 970          ["http://abc/a#f", "http://abc/a",      "#f"],
 971
 972          ["file:/etc/motd", "file:/",            "etc/motd"],
 973          ["file:/etc/motd", "file:/etc/passwd",  "motd"],
 974          ["file:/etc/motd", "file:/etc/rc2.d/",  "../motd"],
 975          ["file:/etc/motd", "file:/usr/lib/doc", "../../etc/motd"],
 976          ["file:",          "file:/etc/",        "../"],
 977          ["file:foo",       "file:/etc/",        "../foo"],
 978
 979          ["mailto:aas",     "http://abc",        "mailto:aas"],
 980
 981          # Nicolai Langfeldt's original example
 982          ["http://www.math.uio.no/doc/mail/top.html",
 983           "http://www.math.uio.no/doc/linux/", "../mail/top.html"],
 984         )
 985     {
 986         my($abs, $base, $expect) = @$_;
 987         printf "url('$abs', '$base')->rel eq '$expect'\n";
 988         my $rel = URI::URL->new($abs, $base)->rel;
 989         $rel->_expect('as_string', $expect);
 990     }
 991     print "relative test ok\n";
 992 }
 993
 994
 995 sub eq_test
 996 {
 997     my $u1 = new URI::URL 'http://abc.com:80/~smith/home.html';
 998     my $u2 = new URI::URL 'http://ABC.com/%7Esmith/home.html';
 999     my $u3 = new URI::URL 'http://ABC.com:/%7esmith/home.html';
1000
1001     # Test all permutations of these tree
1002     $u1->eq($u2) or die "1: $u1 ne $u2";
1003     $u1->eq($u3) or die "2: $u1 ne $u3";
1004     $u2->eq($u1) or die "3: $u2 ne $u1";
1005     $u2->eq($u3) or die "4: $u2 ne $u3";
1006     $u3->eq($u1) or die "5: $u3 ne $u1";
1007     $u3->eq($u2) or die "6: $u3 ne $u2";
1008
1009     # Test empty path
1010     my $u4 = new URI::URL 'http://www.sn.no';
1011     $u4->eq("HTTP://WWW.SN.NO:80/") or die "7: $u4";
1012     $u4->eq("http://www.sn.no:81") and die "8: $u4";
1013
1014     # Test mailto
1015 #    my $u5 = new URI::URL 'mailto:AAS@SN.no';
1016 #    $u5->eq('mailto:aas@sn.no') or die "9: $u5";
1017
1018     # Test reserved char
1019     my $u6 = new URI::URL 'ftp://ftp/%2Fetc';
1020     $u6->eq("ftp://ftp/%2fetc") or die "10: $u6";
1021     $u6->eq("ftp://ftp://etc") and die "11: $u6";
1022 }
1023