1#!/local/bin/perl -w 2 3use URI::URL qw(url); 4use URI::Escape qw(uri_escape uri_unescape); 5 6# want compatiblity 7use 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# 15sub 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 27package main; 28 29# Must ensure that there is no relative paths in @INC because we will 30# chdir in the newlocal tests. 31unless ($^O eq "MacOS") { 32chomp($pwd = ($^O =~ /mswin32/i ? `cd` : $^O eq 'VMS' ? `show default` : `pwd`)); 33if ($^O eq 'VMS') { 34 $pwd =~ s#^\s+##; 35 $pwd = VMS::Filespec::unixpath($pwd); 36 $pwd =~ s#/$##; 37} 38for (@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 51print "1..8\n"; # for Test::Harness 52 53# Do basic tests first. 54# Dies if an error has been detected, prints "ok" otherwise. 55 56print "Self tests for URI::URL version $URI::URL::VERSION...\n"; 57 58eval { scheme_parse_test(); }; 59print "not " if $@; 60print "ok 1\n"; 61 62eval { parts_test(); }; 63print "not " if $@; 64print "ok 2\n"; 65 66eval { escape_test(); }; 67print "not " if $@; 68print "ok 3\n"; 69 70eval { newlocal_test(); }; 71print "not " if $@; 72print "ok 4\n"; 73 74eval { absolute_test(); }; 75print "not " if $@; 76print "ok 5\n"; 77 78eval { eq_test(); }; 79print "not " if $@; 80print "ok 6\n"; 81 82# Let's test making our own things 83URI::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'); 90URI::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') 110URI::URL::implementor('x-a+b.c', 'MyURL'); 111URI::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 125print "ok 7\n"; 126 127# Test the new wash&go constructor 128print "not " if url("../foo.html", "http://www.sn.no/a/b")->abs->as_string 129 ne 'http://www.sn.no/foo.html'; 130print "ok 8\n"; 131 132print "URI::URL version $URI::URL::VERSION ok\n"; 133 134exit 0; 135 136 137 138 139##################################################################### 140# 141# scheme_parse_test() 142# 143# test parsing and retrieval methods 144 145sub 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# 274sub 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# 474sub 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# 532sub 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 572sub 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 648sub 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# 788sub 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; 8005.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 8275.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:> 870EOM 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 995sub 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 1024