[Catalyst-commits] r7491 - in Catalyst-Plugin-SmartURI/1.000/trunk:
lib/Catalyst lib/Catalyst/Plugin t t/uri
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Thu Mar 13 05:48:22 GMT 2008
Author: caelum
Date: 2008-03-13 05:48:22 +0000 (Thu, 13 Mar 2008)
New Revision: 7491
Added:
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/README
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/abs.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/clone.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/data.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/escape.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/file.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ftp.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/generic.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/heuristic.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/http.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ldap.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mailto.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mix.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mms.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/news.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-absconf.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-base.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-file.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-relbase.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/pop.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query-param.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rel.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rfc2732.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roy-test.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest1.html
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest2.html
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest3.html
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest4.html
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest5.html
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rsync.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rtsp.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/sip.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/split.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable-test.pl
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable.t
Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/urn-oid.t
Modified:
Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/Plugin/SmartURI.pm
Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/SmartURI.pm
Catalyst-Plugin-SmartURI/1.000/trunk/t/02-c-a-rest-compat.t
Log:
SmartURI now passes all the core URI tests, although I still need to add some
things to make it 100% compatible with URI.
Modified: Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/Plugin/SmartURI.pm
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/Plugin/SmartURI.pm 2008-03-12 16:09:16 UTC (rev 7490)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/Plugin/SmartURI.pm 2008-03-13 05:48:22 UTC (rev 7491)
@@ -62,16 +62,20 @@
sub setup_engine {
my $app = shift;
- my $new_request_class = $app.'::Request::SmartURI';
- Class::C3::Componentised->inject_base(
- $new_request_class,
- 'Catalyst::Request::SmartURI',
- $app->request_class
- );
- Class::C3::reinitialize();
+ my $request_class = $app->request_class;
- $app->request_class($new_request_class);
+ unless ($request_class->isa('Catalyst::Request::SmartURI')) {
+ my $new_request_class = $app.'::Request::SmartURI';
+ Class::C3::Componentised->inject_base(
+ $new_request_class,
+ 'Catalyst::Request::SmartURI',
+ $request_class
+ );
+ Class::C3::reinitialize();
+ $app->request_class($new_request_class);
+ }
+
$app->next::method(@_)
}
Modified: Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/SmartURI.pm
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/SmartURI.pm 2008-03-12 16:09:16 UTC (rev 7490)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/lib/Catalyst/SmartURI.pm 2008-03-13 05:48:22 UTC (rev 7491)
@@ -23,48 +23,201 @@
=cut
+use URI;
+use URI::URL;
use Class::C3;
use Class::C3::Componentised;
-use base 'URI';
+use File::Find::Rule;
+use File::Spec::Functions qw/splitpath splitdir catfile/;
+use List::MoreUtils 'firstidx';
+use Scalar::Util 'blessed';
+use List::Util 'first';
+use IO::Scalar;
+use base 'Class::Accessor::Fast';
+
+__PACKAGE__->mk_ro_accessors(qw/obj factory_class/);
+
+# Constructors
+
sub new {
my $class = shift;
- # URI objects are not really URI objects, but URI::http etc.
- my $self = $class->next::method(@_);
+ my $self = {obj => URI->new($class->deflate(@_)), factory_class => $class};
- my $uri_class = ref $self;
- (my $new_uri_class = $uri_class) =~ s/^URI::/Catalyst::SmartURI::/;
+ bless $self, $class->make_uri_class(blessed $self->{obj}, 1);
+}
+sub new_abs {
+ my $class = shift;
+
+ my $self = {obj => URI->new_abs($class->deflate(@_)), factory_class => $class};
+
+ bless $self, $class->make_uri_class(blessed $self->{obj}, 1);
+}
+
+sub newlocal {
+ my $class = shift;
+
+ my $self = {obj => URI::URL->newlocal($class->deflate(@_)), factory_class => $class};
+
+ bless $self, $class->make_uri_class(blessed $self->{obj}, 1);
+}
+
+# Utilities
+
+sub hostless {
+ my $uri = shift;
+
+ $uri->scheme('');
+ $uri->host('');
+
+ my $class = blessed $uri;
+
+ return $class->new( $uri =~ m!^/*(/.*)! );
+}
+
+# The gory details
+
+sub AUTOLOAD {
+ use vars '$AUTOLOAD';
+ my $self = shift;
+# stolen from URI sources
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ return if ! blessed $self || $method eq 'DESTROY';
+
+ my $class = $self->factory_class;
+
+ my @res;
+ if (wantarray) {
+ @res = $self->obj->$method($class->deflate(@_));
+ } else {
+ $res[0] = $self->obj->$method($class->deflate(@_));
+ }
+ @res = $class->inflate(@res);
+
+ return wantarray ? @res : $res[0];
+}
+
+use overload
+ '""' => sub { "".$_[0]->obj },
+ '==' =>
+ sub { overload::StrVal($_[0]->obj) eq overload::StrVal($_[1]->obj) },
+ fallback => 1;
+
+sub eq {
+ my ($self, $other) = @_;
+
+# Support URI::eq($first, $second) syntax. Not inheritance-safe :(
+ $self = blessed $self ? $self : __PACKAGE__->new($self);
+
+ return $self->obj->eq(ref $other eq blessed $self ? $other->obj : $other);
+}
+
+# Preload some URI classes, the ones that come in files anyway
+sub import {
no strict 'refs';
+ my $class = shift;
- unless (%{$new_uri_class.'::'}) {
- Class::C3::Componentised->inject_base(
- $new_uri_class,
- 'Catalyst::SmartURI::__BASE__',
- $uri_class
- );
- Class::C3::reinitialize();
+ return if ${$class.'::__INITIALIZED__'};
+
+# File::Find::Rule is not taint safe, and Module::Starter suggests running
+# tests in taint mode. Thanks for helping me with this one Somni!!!
+ {
+ no warnings 'redefine';
+ my $getcwd = \&File::Find::Rule::getcwd;
+ *File::Find::Rule::getcwd = sub { $getcwd->() =~ m!^(.*)\z! };
+ # What are portably valid characters in a directory name anyway?
}
- bless $self, $new_uri_class;
+ my @uri_pms = File::Find::Rule->extras({untaint => 1})->file->name('*.pm')
+ ->in( File::Find::Rule->extras({untaint => 1})->directory
+ ->maxdepth(1)->name('URI')->in(@INC)
+ );
+ my @new_uri_pms;
+
+ for (@uri_pms) {
+ my ($dir, $file) = (splitpath($_))[1,2];
+
+ my @dir = grep $_ ne '', splitdir $dir;
+ my @rel_dir = @dir[(firstidx { $_ eq 'URI' } @dir) .. $#dir];
+ my $mod = join '::' => @rel_dir, ($file =~ /^(.*)\.pm\z/);
+
+ my $new_class = $class->make_uri_class($mod, 0);
+
+ push @new_uri_pms, catfile(split /::/, $new_class) . '.pm';
+ }
+
+# HLAGHALAGHLAGHLAGHLAGH
+ push @INC, sub {
+ if (first { $_ eq $_[1] } @new_uri_pms) {
+ open my $fh, '<', \"1;\n";
+ return $fh;
+ }
+ };
+
+ Class::C3::reinitialize();
+
+ ${$class.'::__INITIALIZED__'} = 1;
}
-{
- package Catalyst::SmartURI::__BASE__;
+sub resolve_uri_class {
+ my ($class, $uri_class) = @_;
- sub hostless {
- my $uri = shift;
+ (my $new_class = $uri_class) =~ s/^URI::/${class}::/;
- $uri->scheme('');
- $uri->host('');
+ return $new_class;
+}
- my $class = ref $uri;
+sub make_uri_class {
+ my ($class, $uri_class, $re_init_c3) = @_;
- return $class->new( $uri =~ m!^/*(/.*)! );
+ my $new_uri_class = $class->resolve_uri_class($uri_class);
+
+ no strict 'refs';
+
+ unless (%{$new_uri_class.'::'}) {
+ Class::C3::Componentised->inject_base($new_uri_class, $class);
+
+ *{$new_uri_class.'::new'} = sub {
+ eval "require $uri_class";
+ bless {
+ obj => $uri_class->new($class->deflate(@_[1..$#_])),
+ factory_class => $class
+ }, $new_uri_class;
+ };
+
+ *{$new_uri_class.'::import'} = sub {
+ eval "require $uri_class";
+ if (my $code = $uri_class->can('import')) {
+ splice @_, 0, 1, $uri_class;
+ goto &$code;
+ }
+ };
+
+ Class::C3::reinitialize() if $re_init_c3;
}
+
+ return $new_uri_class;
}
+sub inflate {
+ my $class = shift;
+
+ map { blessed $_ ?
+ bless { obj => $_, factory_class => $class },
+ $class->make_uri_class(blessed $_, 1)
+ :
+ $_
+ } @_;
+}
+
+sub deflate {
+ my $class = shift;
+ map { blessed $_ && $_->isa($class) ? $_->{obj} : $_ } @_
+}
+
=head1 AUTHOR
Rafael Kitover, C<< <rkitover at cpan.org> >>
Modified: Catalyst-Plugin-SmartURI/1.000/trunk/t/02-c-a-rest-compat.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/02-c-a-rest-compat.t 2008-03-12 16:09:16 UTC (rev 7490)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/02-c-a-rest-compat.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -21,7 +21,7 @@
# should break if request_class is not set correctly
$c->req->accepted_content_types;
- $c->res->redirect($c->uri_for('/foo'));
+ $c->res->output($c->req->uri_with({foo => 'bar'}));
}
__PACKAGE__->setup();
@@ -29,8 +29,8 @@
use Catalyst::Test 'TestApp';
-is(request('/foo')->header('location'), '/foo',
- 'redirect location from C::A::REST');
+is(get('/foo'), '/foo?foo=bar',
+ 'C::A::REST and SmartURI are both functional');
}
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/README
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/README (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/README 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,3 @@
+These are all stolen from the URI test suite.
+I just did a perl -pi -e 's/URI(::)?/Catalyst::SmartURI$1/g' *.t *.pl
+Left out urn-isbn.t, which is incompatible with the latest Business::ISBN.
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/abs.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/abs.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/abs.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,171 @@
+#!perl -w
+
+print "1..45\n";
+
+# This test the resolution of abs path for all examples given
+# in the "Uniform Resource Identifiers (Catalyst::SmartURI): Generic Syntax" document.
+
+use Catalyst::SmartURI;
+$base = "http://a/b/c/d;p?q";
+$testno = 1;
+
+while (<DATA>) {
+ #next if 1 .. /^C\.\s+/;
+ #last if /^D\.\s+/;
+ next unless /\s+(\S+)\s*=\s*(.*)/;
+ my $uref = $1;
+ my $expect = $2;
+ $expect =~ s/\(current document\)/$base/;
+ #print "$uref => $expect\n";
+
+ my $bad;
+ my $u = Catalyst::SmartURI->new($uref, $base);
+ if ($u->abs($base)->as_string ne $expect) {
+ $bad++;
+ my $abs = $u->abs($base)->as_string;
+ print qq(Catalyst::SmartURI->new("$uref")->abs("$base") ==> "$abs"\n);
+ }
+
+ # Let's test another version of the same thing
+ $u = Catalyst::SmartURI->new($uref);
+ my $b = Catalyst::SmartURI->new($base);
+ if ($u->abs($b,1) ne $expect && $uref !~ /^http:/) {
+ $bad++;
+ print qq(Catalyst::SmartURI->new("$uref")->abs(Catalyst::SmartURI->new("$base"), 1)\n);
+ }
+
+ # Let's try the other way
+ $u = Catalyst::SmartURI->new($expect)->rel($base)->as_string;
+ if ($u ne $uref) {
+ push(@rel_fail, qq($testno: Catalyst::SmartURI->new("$expect", "$base")->rel ==> "$u" (not "$uref")\n));
+ }
+
+ print "not " if $bad;
+ print "ok ", $testno++, "\n";
+}
+
+if (@rel_fail) {
+ print "\n\nIn the following cases we did not get back to where we started with rel()\n";
+ print @rel_fail;
+}
+
+
+
+__END__
+
+Network Working Group T. Berners-Lee, MIT/LCS
+INTERNET-DRAFT R. Fielding, U.C. Irvine
+draft-fielding-uri-syntax-02 L. Masinter, Xerox Corporation
+Expires six months after publication date March 4, 1998
+
+
+ Uniform Resource Identifiers (Catalyst::SmartURI): Generic Syntax
+
+[...]
+
+C. Examples of Resolving Relative Catalyst::SmartURI References
+
+ Within an object with a well-defined base Catalyst::SmartURI of
+
+ http://a/b/c/d;p?q
+
+ the relative Catalyst::SmartURIs would be resolved as follows:
+
+C.1. Normal Examples
+
+ g:h = g:h
+ g = http://a/b/c/g
+ ./g = http://a/b/c/g
+ g/ = http://a/b/c/g/
+ /g = http://a/g
+ //g = http://g
+ ?y = http://a/b/c/d;p?y
+ g?y = http://a/b/c/g?y
+ #s = (current document)#s
+ g#s = http://a/b/c/g#s
+ g?y#s = http://a/b/c/g?y#s
+ ;x = http://a/b/c/;x
+ g;x = http://a/b/c/g;x
+ g;x?y#s = http://a/b/c/g;x?y#s
+ . = http://a/b/c/
+ ./ = http://a/b/c/
+ .. = http://a/b/
+ ../ = http://a/b/
+ ../g = http://a/b/g
+ ../.. = http://a/
+ ../../ = http://a/
+ ../../g = http://a/g
+
+C.2. Abnormal Examples
+
+ Although the following abnormal examples are unlikely to occur in
+ normal practice, all Catalyst::SmartURI parsers should be capable of resolving them
+ consistently. Each example uses the same base as above.
+
+ An empty reference refers to the start of the current document.
+
+ <> = (current document)
+
+ Parsers must be careful in handling the case where there are more
+ relative path ".." segments than there are hierarchical levels in
+ the base Catalyst::SmartURI's path. Note that the ".." syntax cannot be used to
+ change the authority component of a Catalyst::SmartURI.
+
+ ../../../g = http://a/../g
+ ../../../../g = http://a/../../g
+
+ In practice, some implementations strip leading relative symbolic
+ elements (".", "..") after applying a relative Catalyst::SmartURI calculation, based
+ on the theory that compensating for obvious author errors is better
+ than allowing the request to fail. Thus, the above two references
+ will be interpreted as "http://a/g" by some implementations.
+
+ Similarly, parsers must avoid treating "." and ".." as special when
+ they are not complete components of a relative path.
+
+ /./g = http://a/./g
+ /../g = http://a/../g
+ g. = http://a/b/c/g.
+ .g = http://a/b/c/.g
+ g.. = http://a/b/c/g..
+ ..g = http://a/b/c/..g
+
+ Less likely are cases where the relative Catalyst::SmartURI uses unnecessary or
+ nonsensical forms of the "." and ".." complete path segments.
+
+ ./../g = http://a/b/g
+ ./g/. = http://a/b/c/g/
+ g/./h = http://a/b/c/g/h
+ g/../h = http://a/b/c/h
+ g;x=1/./y = http://a/b/c/g;x=1/y
+ g;x=1/../y = http://a/b/c/y
+
+ All client applications remove the query component from the base Catalyst::SmartURI
+ before resolving relative Catalyst::SmartURIs. However, some applications fail to
+ separate the reference's query and/or fragment components from a
+ relative path before merging it with the base path. This error is
+ rarely noticed, since typical usage of a fragment never includes the
+ hierarchy ("/") character, and the query component is not normally
+ used within relative references.
+
+ g?y/./x = http://a/b/c/g?y/./x
+ g?y/../x = http://a/b/c/g?y/../x
+ g#s/./x = http://a/b/c/g#s/./x
+ g#s/../x = http://a/b/c/g#s/../x
+
+ Some parsers allow the scheme name to be present in a relative Catalyst::SmartURI
+ if it is the same as the base Catalyst::SmartURI scheme. This is considered to be
+ a loophole in prior specifications of partial Catalyst::SmartURIs [RFC1630]. Its
+ use should be avoided.
+
+ http:g = http:g
+ http: = http:
+
+
+==========================================================================
+
+Some extra tests for good measure...
+
+ #foo? = (current document)#foo?
+ ?#foo = http://a/b/c/d;p?#foo
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/clone.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/clone.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/clone.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,22 @@
+#!perl -w
+
+print "1..2\n";
+
+use strict;
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::URL;
+
+my $b = Catalyst::SmartURI::URL->new("http://www/");
+
+my $u1 = Catalyst::SmartURI::URL->new("foo", $b);
+my $u2 = $u1->clone;
+
+$u1->base("http://yyy/");
+
+#use Data::Dump; Data::Dump::dump($b, $u1, $u2);
+
+print "not " unless $u1->abs->as_string eq "http://yyy/foo";
+print "ok 1\n";
+
+print "not " unless $u2->abs->as_string eq "http://www/foo";
+print "ok 2\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/data.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/data.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/data.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,108 @@
+#!perl -w
+
+eval {
+ require MIME::Base64;
+};
+if ($@) {
+ print "1..0\n";
+ print $@;
+ exit;
+}
+
+print "1..21\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new("data:,A%20brief%20note");
+print "not " unless $u->scheme eq "data" && $u->opaque eq ",A%20brief%20note";
+print "ok 1\n";
+
+print "not " unless $u->media_type eq "text/plain;charset=US-ASCII" &&
+ $u->data eq "A brief note";
+print "ok 2\n";
+
+$old = $u->data("Får-i-kål er tingen!");
+print "not " unless $old eq "A brief note" && $u eq "data:,F%E5r-i-k%E5l%20er%20tingen!";
+print "ok 3\n";
+
+$old = $u->media_type("text/plain;charset=iso-8859-1");
+print "not " unless $old eq "text/plain;charset=US-ASCII" &&
+ $u eq "data:text/plain;charset=iso-8859-1,F%E5r-i-k%E5l%20er%20tingen!";
+print "ok 4\n";
+
+
+$u = Catalyst::SmartURI->new("data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAwAAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFzByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSpa/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJlZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uisF81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PHhhx4dbgYKAAA7");
+
+print "not " unless $u->media_type eq "image/gif";
+print "ok 5\n";
+
+if ($ENV{DISPLAY} && $ENV{XV}) {
+ open(XV, "| $ENV{XV} -") || die;
+ print XV $u->data;
+ close(XV);
+}
+print "not " unless length($u->data) == 273;
+print "ok 6\n";
+
+$u = Catalyst::SmartURI->new("data:text/plain;charset=iso-8859-7,%be%fg%be"); # %fg
+print "not " unless $u->data eq "\xBE%fg\xBE";
+print "ok 7\n";
+
+$u = Catalyst::SmartURI->new("data:application/vnd-xxx-query,select_vcount,fcol_from_fieldtable/local");
+print "not " unless $u->data eq "select_vcount,fcol_from_fieldtable/local";
+print "ok 8\n";
+$u->data("");
+print "not " unless $u eq "data:application/vnd-xxx-query,";
+print "ok 9\n";
+
+$u->data("a,b"); $u->media_type(undef);
+print "not " unless $u eq "data:,a,b";
+print "ok 10\n";
+
+# Test automatic selection of Catalyst::SmartURI/BASE64 encoding
+$u = Catalyst::SmartURI->new("data:");
+$u->data("");
+print "not " unless $u eq "data:,";
+print "ok 11\n";
+
+$u->data(">");
+print "not " unless $u eq "data:,%3E" && $u->data eq ">";
+print "ok 12\n";
+
+$u->data(">>>>>");
+print "not " unless $u eq "data:,%3E%3E%3E%3E%3E";
+print "ok 13\n";
+
+$u->data(">>>>>>");
+print "not " unless $u eq "data:;base64,Pj4+Pj4+";
+print "ok 14\n";
+
+$u->media_type("text/plain;foo=bar");
+print "not " unless $u eq "data:text/plain;foo=bar;base64,Pj4+Pj4+";
+print "ok 15\n";
+
+$u->media_type("foo");
+print "not " unless $u eq "data:foo;base64,Pj4+Pj4+";
+print "ok 16\n";
+
+$u->data(">" x 3000);
+print "not " unless $u eq ("data:foo;base64," . ("Pj4+" x 1000)) &&
+ $u->data eq (">" x 3000);
+print "ok 17\n";
+
+$u->media_type(undef);
+$u->data(undef);
+print "not " unless $u eq "data:,";
+print "ok 18\n";
+
+$u = Catalyst::SmartURI->new("data:foo");
+print "not " unless $u->media_type("bar,båz") eq "foo";
+print "ok 19\n";
+
+print "not " unless $u->media_type eq "bar,båz";
+print "ok 20\n";
+
+$old = $u->data("new");
+print "not " unless $old eq "" && $u eq "data:bar%2Cb%E5z,new";
+print "ok 21\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/escape.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/escape.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/escape.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,49 @@
+#!perl -w
+
+print "1..9\n";
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::Escape;
+
+print "not " unless uri_escape("|abcå") eq "%7Cabc%E5";
+print "ok 1\n";
+
+print "not " unless uri_escape("abc", "b-d") eq "a%62%63";
+print "ok 2\n";
+
+print "not " if defined(uri_escape(undef));
+print "ok 3\n";
+
+print "not " unless uri_unescape("%7Cabc%e5") eq "|abcå";
+print "ok 4\n";
+
+print "not " unless join(":", uri_unescape("%40A%42", "CDE", "F%47H")) eq
+ '@AB:CDE:FGH';
+print "ok 5\n";
+
+
+use Catalyst::SmartURI::Escape qw(%escapes);
+
+print "not" unless $escapes{"%"} eq "%25";
+print "ok 6\n";
+
+
+use Catalyst::SmartURI::Escape qw(uri_escape_utf8);
+
+print "not " unless uri_escape_utf8("|abcå") eq "%7Cabc%C3%A5";
+print "ok 7\n";
+
+if ($] < 5.008) {
+ print "ok 8 # skip perl-5.8 required\n";
+ print "ok 9 # skip perl-5.8 required\n";
+}
+else {
+ eval { print uri_escape("abc" . chr(300)) };
+ print "not " unless $@ && $@ =~ /^Can\'t escape \\x{012C}, try uri_escape_utf8\(\) instead/;
+ print "ok 8\n";
+
+ print "not " unless uri_escape_utf8(chr(0xFFF)) eq "%E0%BF%BF";
+ print "ok 9\n";
+}
+
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/file.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/file.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/file.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,63 @@
+#!perl -w
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::file;
+
+ at tests = (
+[ "file", "unix", "win32", "mac" ],
+#---------------- ------------ --------------- --------------
+[ "file://localhost/foo/bar",
+ "!/foo/bar", "!\\foo\\bar", "!foo:bar", ],
+[ "file:///foo/bar",
+ "/foo/bar", "\\foo\\bar", "!foo:bar", ],
+[ "file:/foo/bar", "!/foo/bar", "!\\foo\\bar", "foo:bar", ],
+[ "foo/bar", "foo/bar", "foo\\bar", ":foo:bar",],
+[ "file://foo/bar","!//foo/bar", "!\\\\foo\\bar", "!foo:bar"],
+[ "file://a:/", "!//a:/", "!A:\\", undef],
+[ "file:///A:/", "/A:/", "A:\\", undef],
+[ "file:///", "/", "\\", undef],
+[ ".", ".", ".", ":"],
+[ "..", "..", "..", "::"],
+[ "%2E", "!.", "!.", ":."],
+[ "../%2E%2E", "!../..", "!..\\..", "::.."],
+);
+
+ at os = @{shift @tests};
+shift @os; # file
+
+my $num = @tests;
+print "1..$num\n";
+
+$testno = 1;
+
+for $t (@tests) {
+ my @t = @$t;
+ my $file = shift @t;
+ my $err;
+
+ my $u = Catalyst::SmartURI->new($file, "file");
+ my $i = 0;
+ for $os (@os) {
+ my $f = $u->file($os);
+ my $expect = $t[$i];
+ $f = "<undef>" unless defined $f;
+ $expect = "<undef>" unless defined $expect;
+ my $loose;
+ $loose++ if $expect =~ s/^!//;
+ if ($expect ne $f) {
+ print "Catalyst::SmartURI->new('$file', 'file')->file('$os') ne $expect, but $f\n";
+ $err++;
+ }
+ if (defined($t[$i]) && !$loose) {
+ $u2 = Catalyst::SmartURI::file->new($t[$i], $os);
+ unless ($u2->as_string eq $file) {
+ print "Catalyst::SmartURI::file->new('$t[$i]', '$os') ne $file, but $u2\n";
+ $err++;
+ }
+ }
+ $i++;
+ }
+ print "not " if $err;
+ print "ok $testno\n";
+ $testno++;
+}
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ftp.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ftp.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ftp.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,53 @@
+#!perl -w
+
+print "1..13\n";
+
+use strict;
+use Catalyst::SmartURI;
+my $uri;
+
+$uri = Catalyst::SmartURI->new("ftp://ftp.example.com/path");
+
+print "not " unless $uri->scheme eq "ftp";
+print "ok 1\n";
+
+print "not " unless $uri->host eq "ftp.example.com";
+print "ok 2\n";
+
+print "not " unless $uri->port eq 21;
+print "ok 3\n";
+
+print "not " unless $uri->user eq "anonymous";
+print "ok 4\n";
+
+print "not " unless $uri->password eq 'anonymous@';
+print "ok 5\n";
+
+$uri->userinfo("gisle\@aas.no");
+
+print "not " unless $uri eq "ftp://gisle%40aas.no\@ftp.example.com/path";
+print "ok 6\n";
+
+print "not " unless $uri->user eq "gisle\@aas.no";
+print "ok 7\n";
+
+print "not " if defined($uri->password);
+print "ok 8\n";
+
+$uri->password("secret");
+
+print "not " unless $uri eq "ftp://gisle%40aas.no:secret\@ftp.example.com/path";
+print "ok 9\n";
+
+$uri = Catalyst::SmartURI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path");
+print "not " unless $uri eq "ftp://gisle\@aas.no:secret\@ftp.example.com/path";
+print "ok 10\n";
+
+print "not " unless $uri->userinfo eq "gisle\@aas.no:secret";
+print "ok 11\n";
+
+print "not " unless $uri->user eq "gisle\@aas.no";
+print "ok 12\n";
+
+print "not " unless $uri->password eq "secret";
+print "ok 13\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/generic.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/generic.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/generic.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,218 @@
+#!perl -w
+
+print "1..48\n";
+
+use Catalyst::SmartURI;
+
+$foo = Catalyst::SmartURI->new("Foo:opaque#frag");
+
+print "not " unless ref($foo) eq "Catalyst::SmartURI::_foreign";
+print "ok 1\n";
+
+print "not " unless $foo->as_string eq "Foo:opaque#frag";
+print "ok 2\n";
+
+print "not " unless "$foo" eq "Foo:opaque#frag";
+print "ok 3\n";
+
+# Try accessors
+print "not " unless $foo->_scheme eq "Foo" && $foo->scheme eq "foo";
+print "ok 4\n";
+
+print "not " unless $foo->opaque eq "opaque";
+print "ok 5\n";
+
+print "not " unless $foo->fragment eq "frag";
+print "ok 6\n";
+
+print "not " unless $foo->canonical eq "foo:opaque#frag";
+print "ok 7\n";
+
+# Try modificators
+$old = $foo->scheme("bar");
+
+print "not " unless $old eq "foo" && $foo eq "bar:opaque#frag";
+print "ok 8\n";
+
+$old = $foo->scheme("");
+print "not " unless $old eq "bar" && $foo eq "opaque#frag";
+print "ok 9\n";
+
+$old = $foo->scheme("foo");
+$old = $foo->scheme(undef);
+
+print "not " unless $old eq "foo" && $foo eq "opaque#frag";
+print "ok 10\n";
+
+$foo->scheme("foo");
+
+
+$old = $foo->opaque("xxx");
+print "not " unless $old eq "opaque" && $foo eq "foo:xxx#frag";
+print "ok 11\n";
+
+$old = $foo->opaque("");
+print "not " unless $old eq "xxx" && $foo eq "foo:#frag";
+print "ok 12\n";
+
+$old = $foo->opaque(" #?/");
+$old = $foo->opaque(undef);
+print "not " unless $old eq "%20%23?/" && $foo eq "foo:#frag";
+print "ok 13\n";
+
+$foo->opaque("opaque");
+
+
+$old = $foo->fragment("x");
+print "not " unless $old eq "frag" && $foo eq "foo:opaque#x";
+print "ok 14\n";
+
+$old = $foo->fragment("");
+print "not " unless $old eq "x" && $foo eq "foo:opaque#";
+print "ok 15\n";
+
+$old = $foo->fragment(undef);
+print "not " unless $old eq "" && $foo eq "foo:opaque";
+print "ok 16\n";
+
+
+# Compare
+print "not " unless $foo->eq("Foo:opaque") &&
+ $foo->eq(Catalyst::SmartURI->new("FOO:opaque")) &&
+ $foo->eq("foo:opaque");
+print "ok 17\n";
+
+print "not " if $foo->eq("Bar:opaque") ||
+ $foo->eq("foo:opaque#");
+print "ok 18\n";
+
+
+# Try hierarchal unknown URLs
+
+$foo = Catalyst::SmartURI->new("foo://host:80/path?query#frag");
+
+print "not " unless "$foo" eq "foo://host:80/path?query#frag";
+print "ok 19\n";
+
+# Accessors
+print "not " unless $foo->scheme eq "foo";
+print "ok 20\n";
+
+print "not " unless $foo->authority eq "host:80";
+print "ok 21\n";
+
+print "not " unless $foo->path eq "/path";
+print "ok 22\n";
+
+print "not " unless $foo->query eq "query";
+print "ok 23\n";
+
+print "not " unless $foo->fragment eq "frag";
+print "ok 24\n";
+
+# Modificators
+$old = $foo->authority("xxx");
+print "not " unless $old eq "host:80" && $foo eq "foo://xxx/path?query#frag";
+print "ok 25\n";
+
+$old = $foo->authority("");
+print "not " unless $old eq "xxx" && $foo eq "foo:///path?query#frag";
+print "ok 26\n";
+
+$old = $foo->authority(undef);
+print "not " unless $old eq "" && $foo eq "foo:/path?query#frag";
+print "ok 27\n";
+
+$old = $foo->authority("/? #;@&");
+print "not " unless !defined($old) && $foo eq "foo://%2F%3F%20%23;@&/path?query#frag";
+print "ok 28\n";
+
+$old = $foo->authority("host:80");
+print "not " unless $old eq "%2F%3F%20%23;@&" && $foo eq "foo://host:80/path?query#frag";
+print "ok 29\n";
+
+
+$old = $foo->path("/foo");
+print "not " unless $old eq "/path" && $foo eq "foo://host:80/foo?query#frag";
+print "ok 30\n";
+
+$old = $foo->path("bar");
+print "not " unless $old eq "/foo" && $foo eq "foo://host:80/bar?query#frag";
+print "ok 31\n";
+
+$old = $foo->path("");
+print "not " unless $old eq "/bar" && $foo eq "foo://host:80?query#frag";
+print "ok 32\n";
+
+$old = $foo->path(undef);
+print "not " unless $old eq "" && $foo eq "foo://host:80?query#frag";
+print "ok 33\n";
+
+$old = $foo->path("@;/?#");
+print "not " unless $old eq "" && $foo eq "foo://host:80/@;/%3F%23?query#frag";
+print "ok 34\n";
+
+$old = $foo->path("path");
+print "not " unless $old eq "/@;/%3F%23" && $foo eq "foo://host:80/path?query#frag";
+print "ok 35\n";
+
+
+$old = $foo->query("foo");
+print "not " unless $old eq "query" && $foo eq "foo://host:80/path?foo#frag";
+print "ok 36\n";
+
+$old = $foo->query("");
+print "not " unless $old eq "foo" && $foo eq "foo://host:80/path?#frag";
+print "ok 37\n";
+
+$old = $foo->query(undef);
+print "not " unless $old eq "" && $foo eq "foo://host:80/path#frag";
+print "ok 38\n";
+
+$old = $foo->query("/?&=# ");
+print "not " unless !defined($old) && $foo eq "foo://host:80/path?/?&=%23%20#frag";
+print "ok 39\n";
+
+$old = $foo->query("query");
+print "not " unless $old eq "/?&=%23%20" && $foo eq "foo://host:80/path?query#frag";
+print "ok 40\n";
+
+# Some buildup trics
+$foo = Catalyst::SmartURI->new("");
+$foo->path("path");
+$foo->authority("auth");
+
+print "not " unless $foo eq "//auth/path";
+print "ok 41\n";
+
+$foo = Catalyst::SmartURI->new("", "http:");
+$foo->query("query");
+$foo->authority("auth");
+print "not " unless $foo eq "//auth?query";
+print "ok 42\n";
+
+$foo->path("path");
+print "not " unless $foo eq "//auth/path?query";
+print "ok 43\n";
+
+$foo = Catalyst::SmartURI->new("");
+$old = $foo->path("foo");
+print "not " unless $old eq "" && $foo eq "foo";
+print "ok 44\n";
+
+$old = $foo->path("bar");
+print "not " unless $old eq "foo" && $foo eq "bar";
+print "ok 45\n";
+
+$old = $foo->opaque("foo");
+print "not " unless $old eq "bar" && $foo eq "foo";
+print "ok 46\n";
+
+$old = $foo->path("");
+print "not " unless $old eq "foo" && $foo eq "";
+print "ok 47\n";
+
+$old = $foo->query("q");
+print "not " unless !defined($old) && $foo eq "?q";
+print "ok 48\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/heuristic.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/heuristic.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/heuristic.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,97 @@
+#!perl -w
+
+if (-f "OFFLINE") {
+ print "1..0";
+ exit;
+}
+
+print "1..15\n";
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::Heuristic qw(uf_urlstr uf_url);
+if (shift) {
+ $URI::Heuristic::DEBUG++;
+ open(STDERR, ">&STDOUT"); # redirect STDERR
+}
+
+print "not " unless uf_urlstr("http://www.sn.no/") eq "http://www.sn.no/";
+print "ok 1\n";
+
+if ($^O eq "MacOS") {
+ print "not " unless uf_urlstr("etc:passwd") eq "file:/etc/passwd";
+} else {
+print "not " unless uf_urlstr("/etc/passwd") eq "file:/etc/passwd";
+}
+print "ok 2\n";
+
+if ($^O eq "MacOS") {
+ print "not " unless uf_urlstr(":foo.txt") eq "file:./foo.txt";
+} else {
+print "not " unless uf_urlstr("./foo.txt") eq "file:./foo.txt";
+}
+print "ok 3\n";
+
+print "not " unless uf_urlstr("ftp.aas.no/lwp.tar.gz") eq "ftp://ftp.aas.no/lwp.tar.gz";
+print "ok 4\n";
+
+if($^O eq "MacOS") {
+# its a weird, but valid, MacOS path, so it can't be left alone
+ print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:/C/%5CCONFIG.SYS";
+} else {
+print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:C:\\CONFIG.SYS";
+}
+print "ok 5\n";
+
+if (gethostbyname("www.netscape.com")) {
+ # DNS probably work, lets run test 6..8
+
+ $URI::Heuristic::MY_COUNTRY = "bv";
+ print "not " unless uf_urlstr("perl/camel.gif") eq "http://www.perl.com/camel.gif";
+ print "ok 6\n";
+
+ $URI::Heuristic::MY_COUNTRY = "uk";
+ print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,;
+ print "ok 7\n";
+
+ $ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com";
+ print "not " unless uf_urlstr("perl") eq "http://www.perl.org";
+ print "ok 8\n";
+
+} else {
+ # don't make the inocent worry
+ print "Skipping test 6-8 because DNS does not work\n";
+ for (6..8) { print "ok $_\n"; }
+
+}
+
+{
+local $ENV{URL_GUESS_PATTERN} = "";
+print "not " unless uf_urlstr("perl") eq "http://perl";
+print "ok 9\n";
+
+print "not " unless uf_urlstr("http:80") eq "http:80";
+print "ok 10\n";
+
+print "not " unless uf_urlstr("mailto:gisle\@aas.no") eq "mailto:gisle\@aas.no";
+print "ok 11\n";
+
+print "not " unless uf_urlstr("gisle\@aas.no") eq "mailto:gisle\@aas.no";
+print "ok 12\n";
+
+print "not " unless uf_urlstr("Gisle.Aas\@aas.perl.org") eq "mailto:Gisle.Aas\@aas.perl.org";
+print "ok 13\n";
+
+print "not " unless uf_url("gopher.sn.no")->scheme eq "gopher";
+print "ok 14\n";
+
+print "not " unless uf_urlstr("123.3.3.3:8080/foo") eq "http://123.3.3.3:8080/foo";
+print "ok 15\n";
+}
+
+#
+#print "not " unless uf_urlstr("some-site") eq "http://www.some-site.com";
+#print "ok 15\n";
+#
+#print "not " unless uf_urlstr("some-site.com") eq "http://some-site.com";
+#print "ok 16\n";
+#
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/http.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/http.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/http.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,57 @@
+#!perl -w
+
+print "1..13\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new("<http://www.perl.com/path?q=fôo>");
+
+#print "$u\n";
+print "not " unless $u eq "http://www.perl.com/path?q=f%F4o";
+print "ok 1\n";
+
+print "not " unless $u->port == 80;
+print "ok 2\n";
+
+# play with port
+$old = $u->port(8080);
+print "not " unless $old == 80 && $u eq "http://www.perl.com:8080/path?q=f%F4o";
+print "ok 3\n";
+
+$u->port(80);
+print "not " unless $u eq "http://www.perl.com:80/path?q=f%F4o";
+print "ok 4\n";
+
+$u->port("");
+print "not " unless $u eq "http://www.perl.com:/path?q=f%F4o" && $u->port == 80;
+print "ok 5\n";
+
+$u->port(undef);
+print "not " unless $u eq "http://www.perl.com/path?q=f%F4o";
+print "ok 6\n";
+
+ at q = $u->query_form;
+print "not " unless @q == 2 && "@q" eq "q fôo";
+print "ok 7\n";
+
+$u->query_form(foo => "bar", bar => "baz");
+print "not " unless $u->query eq "foo=bar&bar=baz";
+print "ok 8\n";
+
+print "not " unless $u->host eq "www.perl.com";
+print "ok 9\n";
+
+print "not " unless $u->path eq "/path";
+print "ok 10\n";
+
+$u->scheme("https");
+print "not " unless $u->port == 443;
+print "ok 11\n";
+
+print "not " unless $u eq "https://www.perl.com/path?foo=bar&bar=baz";
+print "ok 12\n";
+
+$u = Catalyst::SmartURI->new("http://%77%77%77%2e%70%65%72%6c%2e%63%6f%6d/%70%75%62/%61/%32%30%30%31/%30%38/%32%37/%62%6a%6f%72%6e%73%74%61%64%2e%68%74%6d%6c");
+print "not " unless $u->canonical eq "http://www.perl.com/pub/a/2001/08/27/bjornstad.html";
+print "ok 13\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ldap.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ldap.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/ldap.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,114 @@
+#!perl -w
+
+print "1..22\n";
+
+use strict;
+use Catalyst::SmartURI;
+
+my $uri;
+
+$uri = Catalyst::SmartURI->new("ldap://host/dn=base?cn,sn?sub?objectClass=*");
+
+print "not " unless $uri->host eq "host";
+print "ok 1\n";
+
+print "not " unless $uri->dn eq "dn=base";
+print "ok 2\n";
+
+print "not " unless join("-",$uri->attributes) eq "cn-sn";
+print "ok 3\n";
+
+print "not " unless $uri->scope eq "sub";
+print "ok 4\n";
+
+print "not " unless $uri->filter eq "objectClass=*";
+print "ok 5\n";
+
+$uri = Catalyst::SmartURI->new("ldap:");
+$uri->dn("o=University of Michigan,c=US");
+
+print "not " unless "$uri" eq "ldap:o=University%20of%20Michigan,c=US" &&
+ $uri->dn eq "o=University of Michigan,c=US";
+print "ok 6\n";
+
+$uri->host("ldap.itd.umich.edu");
+print "not " unless $uri->as_string eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US";
+print "ok 7\n";
+
+# check defaults
+print "not " unless $uri->_scope eq "" &&
+ $uri->scope eq "base" &&
+ $uri->_filter eq "" &&
+ $uri->filter eq "(objectClass=*)";
+print "ok 8\n";
+
+# attribute
+$uri->attributes("postalAddress");
+print "not " unless $uri eq "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US?postalAddress";
+print "ok 9\n";
+
+# does attribute escapeing work as it should
+$uri->attributes($uri->attributes, "foo", ",", "*", "?", "#", "\0");
+
+print "not " unless $uri->attributes eq "postalAddress,foo,%2C,*,%3F,%23,%00" &&
+ join("-", $uri->attributes) eq "postalAddress-foo-,-*-?-#-\0";
+print "ok 10\n";
+$uri->attributes("");
+
+$uri->scope("sub?#");
+print "not " unless $uri->query eq "?sub%3F%23" &&
+ $uri->scope eq "sub?#";
+print "ok 11\n";
+$uri->scope("");
+
+$uri->filter("f=?,#");
+print "not " unless $uri->query eq "??f=%3F,%23" &&
+ $uri->filter eq "f=?,#";
+
+$uri->filter("(int=\\00\\00\\00\\04)");
+print "not " unless $uri->query eq "??(int=%5C00%5C00%5C00%5C04)";
+print "ok 12\n";
+
+
+print "ok 13\n";
+$uri->filter("");
+
+$uri->extensions("!bindname" => "cn=Manager,co=Foo");
+my %ext = $uri->extensions;
+
+print "not " unless $uri->query eq "???!bindname=cn=Manager%2Cco=Foo" &&
+ keys %ext == 1 &&
+ $ext{"!bindname"} eq "cn=Manager,co=Foo";
+print "ok 14\n";
+
+$uri = Catalyst::SmartURI->new("ldap://LDAP-HOST:389/o=University%20of%20Michigan,c=US?postalAddress?base?ObjectClass=*?FOO=Bar,bindname=CN%3DManager%CO%3dFoo");
+
+print "not " unless $uri->canonical eq "ldap://ldap-host/o=University%20of%20Michigan,c=US?postaladdress???foo=Bar,bindname=CN=Manager%CO=Foo";
+print "ok 15\n";
+
+print "$uri\n";
+print $uri->canonical, "\n";
+
+$uri = Catalyst::SmartURI->new("ldaps://host/dn=base?cn,sn?sub?objectClass=*");
+
+print "not " unless $uri->host eq "host";
+print "ok 16\n";
+print "not " unless $uri->port eq 636;
+print "ok 17\n";
+print "not " unless $uri->dn eq "dn=base";
+print "ok 18\n";
+
+$uri = Catalyst::SmartURI->new("ldapi://%2Ftmp%2Fldap.sock/????x-mod=-w--w----");
+print "not " unless $uri->authority eq "%2Ftmp%2Fldap.sock";
+print "ok 19\n";
+print "not " unless $uri->un_path eq "/tmp/ldap.sock";
+print "ok 20\n";
+
+$uri->un_path("/var/x\@foo:bar/");
+print "not " unless $uri eq "ldapi://%2Fvar%2Fx%40foo%3Abar%2F/????x-mod=-w--w----";
+print "ok 21\n";
+
+%ext = $uri->extensions;
+print "not " unless $ext{"x-mod"} eq "-w--w----";
+print "ok 22\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mailto.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mailto.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mailto.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,47 @@
+#!perl -w
+
+print "1..7\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new('mailto:gisle at aas.no');
+
+print "not " unless $u->to eq 'gisle at aas.no' &&
+ $u eq 'mailto:gisle at aas.no';
+print "ok 1\n";
+
+$old = $u->to('larry at wall.org');
+print "not " unless $old eq 'gisle at aas.no' &&
+ $u->to eq 'larry at wall.org' &&
+ $u eq 'mailto:larry at wall.org';
+print "ok 2\n";
+
+$u->to("?/#");
+print "not " unless $u->to eq "?/#" &&
+ $u eq 'mailto:%3F/%23';
+print "ok 3\n";
+
+ at h = $u->headers;
+print "not " unless @h == 2 && "@h" eq "to ?/#";
+print "ok 4\n";
+
+$u->headers(to => 'gisle at aas.no',
+ cc => 'gisle at ActiveState.com,larry at wall.org',
+ Subject => 'How do you do?',
+ garbage => '/;?#=&',
+);
+
+ at h = $u->headers;
+print "not " unless $u->to eq 'gisle at aas.no' &&
+ @h == 8 &&
+ "@h" eq 'to gisle at aas.no cc gisle at ActiveState.com,larry at wall.org Subject How do you do? garbage /;?#=&';
+print "ok 5\n";
+
+#print "$u\n";
+print "not " unless $u eq 'mailto:gisle at aas.no?cc=gisle%40ActiveState.com%2Clarry%40wall.org&Subject=How+do+you+do%3F&garbage=%2F%3B%3F%23%3D%26';
+print "ok 6\n";
+
+$u = Catalyst::SmartURI->new("mailto:");
+$u->to("gisle");
+print "not " unless $u eq 'mailto:gisle';
+print "ok 7\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mix.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mix.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mix.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,79 @@
+#!perl -w
+
+print "1..6\n";
+
+# Test mixing of Catalyst::SmartURI and Catalyst::SmartURI::WithBase objects
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::WithBase;
+use Catalyst::SmartURI::URL;
+
+$str = "http://www.sn.no/";
+$rel = "path/img.gif";
+
+$u = Catalyst::SmartURI->new($str);
+$uw = Catalyst::SmartURI::WithBase->new($str, "http:");
+$uu = Catalyst::SmartURI::URL->new($str);
+
+sub Dump
+{
+ require Data::Dumper;
+ print Data::Dumper->Dump([$a, $b, $c, $d], [qw(a b c d)]);
+}
+
+$a = Catalyst::SmartURI->new($rel, $u);
+$b = Catalyst::SmartURI->new($rel, $uw);
+$c = Catalyst::SmartURI->new($rel, $uu);
+$d = Catalyst::SmartURI->new($rel, $str);
+
+#Dump();
+print "not " unless $a->isa("Catalyst::SmartURI") &&
+ ref($b) eq ref($uw) &&
+ ref($c) eq ref($uu) &&
+ $d->isa("Catalyst::SmartURI");
+print "ok 1\n";
+
+print "not " if $b->base && $c->base;
+print "ok 2\n";
+
+$a = Catalyst::SmartURI::URL->new($rel, $u);
+$b = Catalyst::SmartURI::URL->new($rel, $uw);
+$c = Catalyst::SmartURI::URL->new($rel, $uu);
+$d = Catalyst::SmartURI::URL->new($rel, $str);
+
+print "not " unless ref($a) eq "Catalyst::SmartURI::URL" &&
+ ref($b) eq "Catalyst::SmartURI::URL" &&
+ ref($c) eq "Catalyst::SmartURI::URL" &&
+ ref($d) eq "Catalyst::SmartURI::URL";
+print "ok 3\n";
+
+print "not " unless ref($b->base) eq ref($uw) &&
+ $b->base eq $uw &&
+ ref($c->base) eq ref($uu) &&
+ $c->base eq $uu &&
+ $d->base eq $str;
+print "ok 4\n";
+
+
+
+$a = Catalyst::SmartURI->new($uu, $u);
+$b = Catalyst::SmartURI->new($uu, $uw);
+$c = Catalyst::SmartURI->new($uu, $uu);
+$d = Catalyst::SmartURI->new($uu, $str);
+
+#Dump();
+print "not " unless ref($a) eq ref($b) &&
+ ref($b) eq ref($c) &&
+ ref($c) eq ref($d) &&
+ ref($d) eq ref($u);
+print "ok 5\n";
+
+$a = Catalyst::SmartURI::URL->new($u, $u);
+$b = Catalyst::SmartURI::URL->new($u, $uw);
+$c = Catalyst::SmartURI::URL->new($u, $uu);
+$d = Catalyst::SmartURI::URL->new($u, $str);
+
+print "not " unless ref($a) eq "Catalyst::SmartURI::URL" &&
+ ref($b) eq "Catalyst::SmartURI::URL" &&
+ ref($c) eq "Catalyst::SmartURI::URL" &&
+ ref($d) eq "Catalyst::SmartURI::URL";
+print "ok 6\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mms.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mms.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/mms.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,37 @@
+#!perl -w
+
+print "1..8\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new("<mms://66.250.188.13/KFOG_FM>");
+
+#print "$u\n";
+print "not " unless $u eq "mms://66.250.188.13/KFOG_FM";
+print "ok 1\n";
+
+print "not " unless $u->port == 1755;
+print "ok 2\n";
+
+# play with port
+$old = $u->port(8755);
+print "not " unless $old == 1755 && $u eq "mms://66.250.188.13:8755/KFOG_FM";
+print "ok 3\n";
+
+$u->port(1755);
+print "not " unless $u eq "mms://66.250.188.13:1755/KFOG_FM";
+print "ok 4\n";
+
+$u->port("");
+print "not " unless $u eq "mms://66.250.188.13:/KFOG_FM" && $u->port == 1755;
+print "ok 5\n";
+
+$u->port(undef);
+print "not " unless $u eq "mms://66.250.188.13/KFOG_FM";
+print "ok 6\n";
+
+print "not " unless $u->host eq "66.250.188.13";
+print "ok 7\n";
+
+print "not " unless $u->path eq "/KFOG_FM";
+print "ok 8\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/news.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/news.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/news.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,50 @@
+#!perl -w
+
+print "1..7\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new("news:comp.lang.perl.misc");
+
+print "not " unless $u->group eq "comp.lang.perl.misc" &&
+ !defined($u->message) &&
+ $u->port == 119 &&
+ $u eq "news:comp.lang.perl.misc";
+print "ok 1\n";
+
+
+$u->host("news.online.no");
+print "not " unless $u->group eq "comp.lang.perl.misc" &&
+ $u->port == 119 &&
+ $u eq "news://news.online.no/comp.lang.perl.misc";
+print "ok 2\n";
+
+$u->group("no.perl", 1 => 10);
+print "not " unless $u eq "news://news.online.no/no.perl/1-10";
+print "ok 3\n";
+
+ at g = $u->group;
+#print "G: @g\n";
+print "not " unless @g == 3 && "@g" eq "no.perl 1 10";
+print "ok 4\n";
+
+$u->message('42 at g.aas.no');
+#print "$u\n";
+print "not " unless $u->message eq '42 at g.aas.no' &&
+ !defined($u->group) &&
+ $u eq 'news://news.online.no/42@g.aas.no';
+print "ok 5\n";
+
+
+$u = Catalyst::SmartURI->new("nntp:no.perl");
+print "not " unless $u->group eq "no.perl" &&
+ $u->port == 119;
+print "ok 6\n";
+
+$u = Catalyst::SmartURI->new("snews://snews.online.no/no.perl");
+
+print "not " unless $u->group eq "no.perl" &&
+ $u->host eq "snews.online.no" &&
+ $u->port == 563;
+print "ok 7\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-absconf.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-absconf.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-absconf.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,38 @@
+#!perl -w
+
+print "1..6\n";
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::URL qw(url);
+
+# Test configuration via some global variables.
+
+$URI::URL::ABS_REMOTE_LEADING_DOTS = 1;
+$URI::URL::ABS_ALLOW_RELATIVE_SCHEME = 1;
+
+$u1 = url("../../../../abc", "http://web/a/b");
+
+print "not " unless $u1->abs->as_string eq "http://web/abc";
+print "ok 1\n";
+
+{
+ local $URI::URL::ABS_REMOTE_LEADING_DOTS;
+ print "not " unless $u1->abs->as_string eq "http://web/../../../abc";
+ print "ok 2\n";
+}
+
+
+$u1 = url("http:../../../../abc", "http://web/a/b");
+print "not " unless $u1->abs->as_string eq "http://web/abc";
+print "ok 3\n";
+
+{
+ local $URI::URL::ABS_ALLOW_RELATIVE_SCHEME;
+ print "not " unless $u1->abs->as_string eq "http:../../../../abc";
+ print "ok 4\n";
+ print "not " unless $u1->abs(undef,1)->as_string eq "http://web/abc";
+ print "ok 5\n";
+}
+
+print "not " unless $u1->abs(undef,0)->as_string eq "http:../../../../abc";
+print "ok 6\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-base.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-base.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-base.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,1026 @@
+#!/local/bin/perl -w
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::URL qw(url);
+use Catalyst::SmartURI::Escape qw(uri_escape uri_unescape);
+
+# want compatiblity
+use Catalyst::SmartURI::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})#;
+ next if $x =~ /CODE\(/;
+ 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 Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::URL 'xxx', $url;
+$newurl->foo;
+$url = new Catalyst::SmartURI::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 at 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 at ics.uci.edu'
+ => { 'address' => 'libwww-perl at ics.uci.edu',
+ 'encoded822addr'=> 'libwww-perl at ics.uci.edu',
+# 'user' => 'libwww-perl',
+# 'host' => 'ics.uci.edu',
+ 'as_string' => 'mailto:libwww-perl at ics.uci.edu', },
+
+ 'news:*'
+ => { 'groupart'=>'*', 'group'=>'*', as_string=>'news:*' },
+ 'news:comp.lang.perl'
+ => { 'group'=>'comp.lang.perl' },
+ 'news:perl-faq/module-list-1-794455075 at ig.co.uk'
+ => { 'article'=>
+ 'perl-faq/module-list-1-794455075 at 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 Catalyst::SmartURI::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 Catalyst::SmartURI::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 at a.sn.no>');
+ $url->_expect('as_string' => 'news:1234 at 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 at a.sn.no');
+# $url->address('foo at 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 at 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 Catalyst::SmartURI::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 at 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 at 0:0');
+ $url->host(undef);
+ $url->_expect('netloc' => '0:0@:0');
+ $url->host('h');
+ $url->user(undef);
+ $url->_expect('netloc' => ':0 at h:0');
+ $url->user('');
+ $url->_expect('netloc' => ':0 at 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 at 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 = Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::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 at 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 Catalyst::SmartURI::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 Catalyst::SmartURI::URL 'file://h/test?ing';
+ $url->_expect('path', '/test?ing');
+
+ $url = new Catalyst::SmartURI::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 Catalyst::SmartURI::URL $str;
+ die "URL changed" if $str ne $url->as_string;
+
+ $url = new Catalyst::SmartURI::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 Catalyst::SmartURI::URL;
+ my $ss = $isMSWin32 ? '//' : (($dir =~ m,^/,) ? '' : '///' );
+ $url->_expect('as_string', Catalyst::SmartURI::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 Catalyst::SmartURI::URL '/usr/';
+ $url->_expect('as_string', 'file:/usr/');
+
+ # absolute file
+ $url = newlocal Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::URL '0';
+ $url->_expect('as_string', "file:$ss${dir}0");
+ }
+
+ # Test access methods for file URLs
+ $url = new Catalyst::SmartURI::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 Catalyst::SmartURI::URL 'file:/foo/bar';
+ $url->_expect('unix_path', '/foo/bar');
+ $url->_expect('mac_path', 'foo:bar');
+
+ # Some edge cases
+# $url = new Catalyst::SmartURI::URL 'file:';
+# $url->_expect('unix_path', '/');
+ $url = new Catalyst::SmartURI::URL 'file:/';
+ $url->_expect('unix_path', '/');
+ $url = new Catalyst::SmartURI::URL 'file:.';
+ $url->_expect('unix_path', '.');
+ $url = new Catalyst::SmartURI::URL 'file:./foo';
+ $url->_expect('unix_path', './foo');
+ $url = new Catalyst::SmartURI::URL 'file:0';
+ $url->_expect('unix_path', '0');
+ $url = new Catalyst::SmartURI::URL 'file:../../foo';
+ $url->_expect('unix_path', '../../foo');
+ $url = new Catalyst::SmartURI::URL 'file:foo/../bar';
+ $url->_expect('unix_path', 'foo/../bar');
+
+ # Relative files
+ $url = new Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::URL $abs;
+ my $abs_str = $abs_url->as_string;
+
+ printf(" %-10s + $base => %s\n", $rel, $abs);
+ my $u = new Catalyst::SmartURI::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 at gems.vcu.edu>
+ $base = new Catalyst::SmartURI::URL 'http://host/directory/file';
+ my $relative = new Catalyst::SmartURI::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 Catalyst::SmartURI::URL 'http://host/dir1/../dir2/file';
+ $relative = new Catalyst::SmartURI::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 at sn.no', "news:comp.lang.perl.misc", 'news:/123 at sn.no'],
+ ['no.perl', 'news:123 at sn.no', 'news:/no.perl'],
+ ['mailto:aas at a.sn.no', "http://www.sn.no/", 'mailto:aas at 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 Catalyst::SmartURI::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 = Catalyst::SmartURI::URL->new($abs, $base)->rel;
+ $rel->_expect('as_string', $expect);
+ }
+ print "relative test ok\n";
+}
+
+
+sub eq_test
+{
+ my $u1 = new Catalyst::SmartURI::URL 'http://abc.com:80/~smith/home.html';
+ my $u2 = new Catalyst::SmartURI::URL 'http://ABC.com/%7Esmith/home.html';
+ my $u3 = new Catalyst::SmartURI::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 Catalyst::SmartURI::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 Catalyst::SmartURI::URL 'mailto:AAS at SN.no';
+# $u5->eq('mailto:aas at sn.no') or die "9: $u5";
+
+ # Test reserved char
+ my $u6 = new Catalyst::SmartURI::URL 'ftp://ftp/%2Fetc';
+ $u6->eq("ftp://ftp/%2fetc") or die "10: $u6";
+ $u6->eq("ftp://ftp://etc") and die "11: $u6";
+}
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-file.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-file.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-file.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,81 @@
+#!perl -w
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::file;
+$URI::file::DEFAULT_AUTHORITY = undef;
+
+ at tests = (
+[ "file", "unix", "win32", "mac" ],
+#---------------- ------------ --------------- --------------
+[ "file://localhost/foo/bar",
+ "!/foo/bar", "!\\foo\\bar", "!foo:bar", ],
+[ "file:///foo/bar",
+ "!/foo/bar", "!\\foo\\bar", "!foo:bar", ],
+[ "file:/foo/bar", "/foo/bar", "\\foo\\bar", "foo:bar", ],
+[ "foo/bar", "foo/bar", "foo\\bar", ":foo:bar",],
+[ "file://foo/bar","!//foo/bar", "\\\\foo\\bar", "!foo:bar"],
+[ "file://a:/", "!//a:/", "!A:\\", undef],
+[ "file:/", "/", "\\", undef],
+[ "file://A:relative/", "!//A:relative/", "A:", undef],
+[ ".", ".", ".", ":"],
+[ "..", "..", "..", "::"],
+[ "%2E", "!.", "!.", ":."],
+[ "../%2E%2E", "!../..", "!..\\..", "::.."],
+);
+if ($^O eq "MacOS") {
+ at extratests = (
+[ "../..", "../..", "..\\..", ":::"],
+[ "../../", "../../", "..\\..\\", "!:::"],
+[ "file:./foo.bar", "!./foo.bar", "!.\\foo.bar", "!:foo.bar"],
+[ "file:/%2Ffoo/bar", undef, undef, "/foo:bar"],
+[ "file:/.%2Ffoo/bar", undef, undef, "./foo:bar"],
+[ "file:/fee/.%2Ffoo%2Fbar", undef, undef, "fee:./foo/bar"],
+[ "file:/.%2Ffoo%2Fbar/", undef, undef, "./foo/bar:"],
+[ "file:/.%2Ffoo%2Fbar", undef, undef, "!./foo/bar:"],
+[ "file:/%2E%2E/foo", "!/../foo", "!\\..\\foo" , "..:foo"],
+[ "file:/bar/%2E/foo", "!/bar/./foo", "!\\bar\\.\\foo", "bar:.:foo"],
+[ "file:/foo/../bar", "/foo/../bar", "\\foo\\..\\bar", "foo::bar"],
+[ "file:/a/b/../../c/d", "/a/b/../../c/d", "\\a\\b\\..\\..\\c\\d", "a:b:::c:d"],
+);
+ push(@tests, at extratests);
+}
+
+ at os = @{shift @tests};
+shift @os; # file
+
+my $num = @tests;
+print "1..$num\n";
+
+$testno = 1;
+
+for $t (@tests) {
+ my @t = @$t;
+ my $file = shift @t;
+ my $err;
+
+ my $u = Catalyst::SmartURI->new($file, "file");
+ my $i = 0;
+ for $os (@os) {
+ my $f = $u->file($os);
+ my $expect = $t[$i];
+ $f = "<undef>" unless defined $f;
+ $expect = "<undef>" unless defined $expect;
+ my $loose;
+ $loose++ if $expect =~ s/^!//;
+ if ($expect ne $f) {
+ print "Catalyst::SmartURI->new('$file', 'file')->file('$os') ne $expect, but $f\n";
+ $err++;
+ }
+ if (defined($t[$i]) && !$loose) {
+ $u2 = Catalyst::SmartURI::file->new($t[$i], $os);
+ unless ($u2->as_string eq $file) {
+ print "Catalyst::SmartURI::file->new('$t[$i]', '$os') ne $file, but $u2\n";
+ $err++;
+ }
+ }
+ $i++;
+ }
+ print "not " if $err;
+ print "ok $testno\n";
+ $testno++;
+}
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-relbase.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-relbase.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/old-relbase.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,37 @@
+#!perl -w
+
+print "1..5\n";
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::URL;
+
+# We used to have problems with URLs that used a base that was
+# not absolute itself.
+
+$u1 = url("/foo/bar", "http://www.acme.com/");
+$u2 = url("../foo/", $u1);
+$u3 = url("zoo/foo", $u2);
+
+$a1 = $u1->abs->as_string;
+$a2 = $u2->abs->as_string;
+$a3 = $u3->abs->as_string;
+
+print "$a1\n$a2\n$a3\n";
+
+print "not " unless $a1 eq "http://www.acme.com/foo/bar";
+print "ok 1\n";
+print "not " unless $a2 eq "http://www.acme.com/foo/";
+print "ok 2\n";
+print "not " unless $a3 eq "http://www.acme.com/foo/zoo/foo";
+print "ok 3\n";
+
+# We used to have problems with URI::URL as the base class :-(
+$u4 = url("foo", "URI::URL");
+$a4 = $u4->abs;
+print "$a4\n";
+print "not " unless $u4 eq "foo" && $a4 eq "uri:/foo";
+print "ok 4\n";
+
+# Test new_abs for Catalyst::SmartURI::URL objects
+print "not " unless Catalyst::SmartURI::URL->new_abs("foo", "http://foo/bar") eq "http://foo/foo";
+print "ok 5\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/pop.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/pop.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/pop.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,49 @@
+#!perl -w
+
+print "1..8\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new('pop://aas@pop.sn.no');
+
+print "not " unless $u->user eq "aas" &&
+ !defined($u->auth) &&
+ $u->host eq "pop.sn.no" &&
+ $u->port == 110 &&
+ $u eq 'pop://aas@pop.sn.no';
+print "ok 1\n";
+
+$u->auth("+APOP");
+print "not " unless $u->auth eq "+APOP" &&
+ $u eq 'pop://aas;AUTH=+APOP@pop.sn.no';
+print "ok 2\n";
+
+$u->user("gisle");
+print "not " unless $u->user eq "gisle" &&
+ $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no';
+print "ok 3\n";
+
+$u->port(4000);
+print "not " unless $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no:4000';
+print "ok 4\n";
+
+$u = Catalyst::SmartURI->new("pop:");
+$u->host("pop.sn.no");
+$u->user("aas");
+$u->auth("*");
+print "not " unless $u eq 'pop://aas;AUTH=*@pop.sn.no';
+print "ok 5\n";
+
+$u->auth(undef);
+print "not " unless $u eq 'pop://aas@pop.sn.no';
+print "ok 6\n";
+
+$u->user(undef);
+print "not " unless $u eq 'pop://pop.sn.no';
+print "ok 7\n";
+
+# Try some funny characters too
+$u->user('får;k at l');
+print "not " unless $u->user eq 'får;k at l' &&
+ $u eq 'pop://f%E5r%3Bk%40l@pop.sn.no';
+print "ok 8\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query-param.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query-param.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query-param.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,87 @@
+#!perl -w
+
+print "1..18\n";
+
+use strict;
+
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::QueryParam;
+
+my $u = Catalyst::SmartURI->new("http://www.sol.no?foo=4&bar=5&foo=5");
+
+my $h = $u->query_form_hash;
+print "not " unless $h->{foo}[0] eq "4" && $h->{foo}[1] eq "5" && $h->{bar} eq "5";
+print "ok 1\n";
+
+$u->query_form_hash({ a => 1, b => 2});
+print "not " unless $u->query eq "a=1&b=2" || $u->query eq "b=2&a=1";
+print "ok 2\n";
+
+$u->query("a=1&b=2&a=3&b=4&a=5");
+print "not " unless $u->query_param == 2 && join(":", $u->query_param) eq "a:b";
+print "ok 3\n";
+
+print "not " unless $u->query_param("a") eq "1" &&
+ join(":", $u->query_param("a")) eq "1:3:5";
+print "ok 4\n";
+
+print "not " unless $u->query_param(a => 11 .. 14) eq "1";
+print "ok 5\n";
+
+print "not " unless $u->query eq "a=11&b=2&a=12&b=4&a=13&a=14";
+print "ok 6\n";
+
+print "not " unless join(":", $u->query_param(a => 11)) eq "11:12:13:14";
+print "ok 7\n";
+
+print "not " unless $u->query eq "a=11&b=2&b=4";
+print "ok 8\n";
+
+print "not " unless $u->query_param_delete("a") eq "11";
+print "ok 9\n";
+
+print "not " unless $u->query eq "b=2&b=4";
+print "ok 10\n";
+
+$u->query_param_append(a => 1, 3, 5);
+$u->query_param_append(b => 6);
+
+print "not " unless $u->query eq "b=2&b=4&a=1&a=3&a=5&b=6";
+print "ok 11\n";
+
+$u->query_param(a => []); # same as $u->query_param_delete("a");
+
+print "not " unless $u->query eq "b=2&b=4&b=6";
+print "ok 12\n";
+
+$u->query(undef);
+$u->query_param(a => 1, 2, 3);
+$u->query_param(b => 1);
+
+print "not " unless $u->query eq 'a=3&a=2&a=1&b=1';
+print "ok 13\n";
+
+$u->query_param_delete('a');
+$u->query_param_delete('b');
+
+print "not " if $u->query;
+print "ok 14\n";
+
+print "not " unless $u->as_string eq 'http://www.sol.no';
+print "ok 15\n";
+
+$u->query(undef);
+$u->query_param(a => 1, 2, 3);
+$u->query_param(b => 1);
+
+print "not " unless $u->query eq 'a=3&a=2&a=1&b=1';
+print "ok 16\n";
+
+$u->query_param('a' => []);
+$u->query_param('b' => []);
+
+print "not " if $u->query;
+print "ok 17\n";
+
+print "not " unless $u->as_string eq 'http://www.sol.no';
+print "ok 18\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/query.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,87 @@
+#!perl -w
+
+print "1..18\n";
+
+use strict;
+use Catalyst::SmartURI ();
+my $u = Catalyst::SmartURI->new("", "http");
+my @q;
+
+$u->query_form(a => 3, b => 4);
+
+print "not " unless $u eq "?a=3&b=4";
+print "ok 1\n";
+
+$u->query_form(a => undef);
+print "not " unless $u eq "?a=";
+print "ok 2\n";
+
+$u->query_form("a[=&+#] " => " [=&+#]");
+print "not " unless $u eq "?a%5B%3D%26%2B%23%5D+=+%5B%3D%26%2B%23%5D";
+print "ok 3\n";
+
+ at q = $u->query_form;
+print "not " unless join(":", @q) eq "a[=&+#] : [=&+#]";
+print "ok 4\n";
+
+ at q = $u->query_keywords;
+print "not " if @q;
+print "ok 5\n";
+
+$u->query_keywords("a", "b");
+print "not " unless $u eq "?a+b";
+print "ok 6\n";
+
+$u->query_keywords(" ", "+", "=", "[", "]");
+print "not " unless $u eq "?%20+%2B+%3D+%5B+%5D";
+print "ok 7\n";
+
+ at q = $u->query_keywords;
+print "not " unless join(":", @q) eq " :+:=:[:]";
+print "ok 8\n";
+
+ at q = $u->query_form;
+print "not " if @q;
+print "ok 9\n";
+
+$u->query(" +?=#");
+print "not " unless $u eq "?%20+?=%23";
+print "ok 10\n";
+
+$u->query_keywords([qw(a b)]);
+print "not " unless $u eq "?a+b";
+print "ok 11\n";
+
+$u->query_keywords([]);
+print "not " unless $u eq "";
+print "ok 12\n";
+
+$u->query_form({ a => 1, b => 2 });
+print "not " unless $u eq "?a=1&b=2" || $u eq "?b=2&a=1";
+print "ok 13\n";
+
+$u->query_form([ a => 1, b => 2 ]);
+print "not " unless $u eq "?a=1&b=2";
+print "ok 14\n";
+
+$u->query_form({});
+print "not " unless $u eq "";
+print "ok 15\n";
+
+$u->query_form([a => [1..4]]);
+print "not " unless $u eq "?a=1&a=2&a=3&a=4";
+print "ok 16\n";
+
+$u->query_form([]);
+print "not " unless $u eq "";
+print "ok 17\n";
+
+$u->query_form(a => { foo => 1 });
+print "not " unless "$u" =~ /^\?a=HASH\(/;
+print "ok 18\n";
+
+__END__
+# Some debugging while writing new tests
+print "\@q='", join(":", @q), "'\n";
+print "\$u='$u'\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rel.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rel.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rel.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,21 @@
+#!/usr/bin/perl -w
+
+print "1..4\n";
+
+use strict;
+use Catalyst::SmartURI;
+
+my $uri = Catalyst::SmartURI->new("http://www.example.com/foo/bar/");
+
+print "not " unless $uri->rel("http://www.example.com/foo/bar/") eq "./";
+print "ok 1\n";
+
+print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM/foo/bar/") eq "./";
+print "ok 2\n";
+
+print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM/FOO/BAR/") eq "../../foo/bar/";
+print "ok 3\n";
+
+print "not " unless $uri->rel("HTTP://WWW.EXAMPLE.COM:80/foo/bar/") eq "./";
+print "ok 4\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rfc2732.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rfc2732.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rfc2732.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,46 @@
+#!perl -w
+
+print "1..9\n";
+
+use strict;
+use Catalyst::SmartURI;
+my $uri = Catalyst::SmartURI->new("http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html");
+
+print "not " unless $uri->as_string eq "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html";
+print "ok 1\n";
+
+print "not " unless $uri->host eq "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]";
+print "ok 2\n";
+
+print "not " unless $uri->host_port eq "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80";
+print "ok 3\n";
+
+print "not " unless $uri->port eq "80";
+print "ok 4\n";
+
+$uri->host("host");
+print "not " unless $uri->as_string eq "http://host:80/index.html";
+print "ok 5\n";
+
+$uri = Catalyst::SmartURI->new("ftp://ftp:@[3ffe:2a00:100:7031::1]");
+print "not " unless $uri->as_string eq "ftp://ftp:@[3ffe:2a00:100:7031::1]";
+print "ok 6\n";
+
+print "not " unless $uri->port eq "21" && !$uri->_port;
+print "ok 7\n";
+
+print "not " unless $uri->host("ftp") eq "[3ffe:2a00:100:7031::1]";
+print "ok 8\n";
+
+print "not " unless $uri eq "ftp://ftp:\@ftp";
+print "ok 9\n";
+
+__END__
+
+ http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html
+ http://[1080:0:0:0:8:800:200C:417A]/index.html
+ http://[3ffe:2a00:100:7031::1]
+ http://[1080::8:800:200C:417A]/foo
+ http://[::192.9.5.5]/ipng
+ http://[::FFFF:129.144.52.38]:80/index.html
+ http://[2010:836B:4179::836B:4179]
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roy-test.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roy-test.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roy-test.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,50 @@
+#!perl -w
+
+print "1..102\n";
+
+if (-d "t") {
+ chdir("t") || die "Can't chdir 't': $!";
+ # fix all relative library locations
+ foreach (@INC) {
+ $_ = "../$_" unless m,^/,;
+ }
+}
+
+use Catalyst::SmartURI;
+$no = 1;
+
+for $i (1..5) {
+ my $file = "uri/roytest$i.html";
+
+ open(FILE, $file) || die "Can't open $file: $!";
+ print "# $file\n";
+ $base = undef;
+ while (<FILE>) {
+ if (/^<BASE href="([^"]+)">/) {
+ $base = Catalyst::SmartURI->new($1);
+ } elsif (/^<a href="([^"]*)">.*<\/a>\s*=\s*(\S+)/) {
+ die "Missing base at line $." unless $base;
+ $link = $1;
+ $exp = $2;
+ $exp = $base if $exp =~ /current/; # special case test 22
+
+ # rfc2396bis restores the rfc1808 behaviour
+ if ($no == 7) {
+ $exp = "http://a/b/c/d;p?y";
+ }
+ elsif ($no == 48) {
+ $exp = "http://a/b/c/d;p?y";
+ }
+
+ $abs = Catalyst::SmartURI->new($link)->abs($base);
+ unless ($abs eq $exp) {
+ print "$file:$.: Expected: $exp\n";
+ print qq( abs("$link","$base") ==> "$abs"\n);
+ print "not ";
+ }
+ print "ok $no\n";
+ $no++;
+ }
+ }
+ close(FILE);
+}
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest1.html
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest1.html (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest1.html 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,194 @@
+<HTML><HEAD>
+<TITLE>Examples of Resolving Relative URLs</TITLE>
+<BASE href="http://a/b/c/d;p?q">
+</HEAD><BODY>
+<H1>Examples of Resolving Relative URLs</H1>
+
+This document has an embedded base URL of
+<PRE>
+ Content-Base: http://a/b/c/d;p?q
+</PRE>
+the relative URLs should be resolved as shown below.
+<P>
+I will need your help testing the examples on multiple browsers.
+What you need to do is point to the example anchor and compare it to the
+resolved URL in your browser (most browsers have a feature by which you
+can see the resolved URL at the bottom of the window/screen when the anchor
+is active).
+
+<H2>Tested Clients and Client Libraries</H2>
+
+<DL COMPACT>
+<DT>[R]
+<DD>RFC 2396 (the right way to parse)
+<DT>[X]
+<DD>RFC 1808
+<DT>[1]
+<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
+<DT>[2]
+<DD>Lynx/2.7.1 libwww-FM/2.14
+<DT>[3]
+<DD>MSIE 3.01; Windows 95
+<DT>[4]
+<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
+<DT>[5]
+<DD>libwww-perl/5.14 [Martijn Koster]
+</DL>
+
+<H2>Normal Examples</H2>
+<PRE>
+ RESULTS from
+
+<a href="g:h">g:h</a> = g:h [R,X,2,3,4,5]
+ http://a/b/c/g:h [1]
+
+<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4,5]
+
+<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4,5]
+
+<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4,5]
+
+<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4,5]
+
+<a href="//g">//g</a> = http://g [R,X,1,2,3,4,5]
+
+<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4]
+ http://a/b/c/d;p?y [X,5]
+
+<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4,5]
+
+<a name="s" href="#s">#s</a> = (current document)#s [R,2,4]
+ http://a/b/c/d;p?q#s [X,1,3,5]
+
+<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4,5]
+
+<a href="g?y#s">g?y#s</a> = http://a/b/c/g?y#s [R,X,1,2,3,4,5]
+
+<a href=";x">;x</a> = http://a/b/c/;x [R,1,2,3,4]
+ http://a/b/c/d;x [X,5]
+
+<a href="g;x">g;x</a> = http://a/b/c/g;x [R,X,1,2,3,4,5]
+
+<a href="g;x?y#s">g;x?y#s</a> = http://a/b/c/g;x?y#s [R,X,1,2,3,4,5]
+
+<a href=".">.</a> = http://a/b/c/ [R,X,2,5]
+ http://a/b/c/. [1]
+ http://a/b/c [3,4]
+
+<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4,5]
+
+<a href="..">..</a> = http://a/b/ [R,X,2,5]
+ http://a/b [1,3,4]
+
+<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4,5]
+
+<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4,5]
+
+<a href="../..">../..</a> = http://a/ [R,X,2,5]
+ http://a [1,3,4]
+
+<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4,5]
+
+<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4,5]
+</PRE>
+
+<H2>Abnormal Examples</H2>
+
+Although the following abnormal examples are unlikely to occur in
+normal practice, all URL parsers should be capable of resolving them
+consistently. Each example uses the same base as above.<P>
+
+An empty reference refers to the start of the current document.
+<PRE>
+<a href=""><></a> = (current document) [R,2,4]
+ http://a/b/c/d;p?q [X,3,5]
+ http://a/b/c/ [1]
+</PRE>
+Parsers must be careful in handling the case where there are more
+relative path ".." segments than there are hierarchical levels in the
+base URL's path. Note that the ".." syntax cannot be used to change
+the site component of a URL.
+<PRE>
+<a href="../../../g">../../../g</a> = http://a/../g [R,X,2,4,5]
+ http://a/g [R,1,3]
+
+<a href="../../../../g">../../../../g</a> = http://a/../../g [R,X,2,4,5]
+ http://a/g [R,1,3]
+</PRE>
+In practice, some implementations strip leading relative symbolic
+elements (".", "..") after applying a relative URL calculation, based
+on the theory that compensating for obvious author errors is better
+than allowing the request to fail. Thus, the above two references
+will be interpreted as "http://a/g" by some implementations.
+<P>
+Similarly, parsers must avoid treating "." and ".." as special when
+they are not complete components of a relative path.
+<PRE>
+<a href="/./g">/./g</a> = http://a/./g [R,X,2,3,4,5]
+ http://a/g [1]
+
+<a href="/../g">/../g</a> = http://a/../g [R,X,2,3,4,5]
+ http://a/g [1]
+
+<a href="g.">g.</a> = http://a/b/c/g. [R,X,1,2,3,4,5]
+
+<a href=".g">.g</a> = http://a/b/c/.g [R,X,1,2,3,4,5]
+
+<a href="g..">g..</a> = http://a/b/c/g.. [R,X,1,2,3,4,5]
+
+<a href="..g">..g</a> = http://a/b/c/..g [R,X,1,2,3,4,5]
+</PRE>
+Less likely are cases where the relative URL uses unnecessary or
+nonsensical forms of the "." and ".." complete path segments.
+<PRE>
+<a href="./../g">./../g</a> = http://a/b/g [R,X,1,2,5]
+ http://a/b/c/../g [3,4]
+
+<a href="./g/.">./g/.</a> = http://a/b/c/g/ [R,X,2,5]
+ http://a/b/c/g/. [1]
+ http://a/b/c/g [3,4]
+
+<a href="g/./h">g/./h</a> = http://a/b/c/g/h [R,X,1,2,3,4,5]
+
+<a href="g/../h">g/../h</a> = http://a/b/c/h [R,X,1,2,3,4,5]
+
+<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/g;x=1/y [R,1,2,3,4]
+ http://a/b/c/g;x=1/./y [X,5]
+
+<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/y [R,1,2,3,4]
+ http://a/b/c/g;x=1/../y [X,5]
+
+</PRE>
+All client applications remove the query component from the base URL
+before resolving relative URLs. However, some applications fail to
+separate the reference's query and/or fragment components from a
+relative path before merging it with the base path. This error is
+rarely noticed, since typical usage of a fragment never includes the
+hierarchy ("/") character, and the query component is not normally
+used within relative references.
+<PRE>
+<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X,5]
+ http://a/b/c/g?y/x [1,2,3,4]
+
+<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X,5]
+ http://a/b/c/x [1,2,3,4]
+
+<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4,5]
+ http://a/b/c/g#s/x [1]
+
+<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4,5]
+ http://a/b/c/x [1]
+</PRE>
+ Some parsers allow the scheme name to be present in a relative URI if
+ it is the same as the base URI scheme. This is considered to be a
+ loophole in prior specifications of partial URI [RFC1630]. Its use
+ should be avoided.
+<PRE>
+<a href="http:g">http:g</a> = http:g [R,X,5]
+ | http://a/b/c/g [1,2,3,4] (ok for compat.)
+
+<a href="http:">http:</a> = http: [R,X,5]
+ http://a/b/c/ [1]
+ http://a/b/c/d;p?q [2,3,4]
+</PRE>
+</BODY></HTML>
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest2.html
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest2.html (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest2.html 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,100 @@
+<HTML><HEAD>
+<TITLE>Examples of Resolving Relative URLs, Part 2</TITLE>
+<BASE href="http://a/b/c/d;p?q=1/2">
+</HEAD><BODY>
+<H1>Examples of Resolving Relative URLs, Part 2</H1>
+
+This document has an embedded base URL of
+<PRE>
+ Content-Base: http://a/b/c/d;p?q=1/2
+</PRE>
+the relative URLs should be resolved as shown below. In this test page,
+I am particularly interested in testing whether "/" in query information
+is or is not treated as part of the path hierarchy.
+<P>
+I will need your help testing the examples on multiple browsers.
+What you need to do is point to the example anchor and compare it to the
+resolved URL in your browser (most browsers have a feature by which you
+can see the resolved URL at the bottom of the window/screen when the anchor
+is active).
+
+<H2>Tested Clients and Client Libraries</H2>
+
+<DL COMPACT>
+<DT>[R]
+<DD>RFC 2396 (the right way to parse)
+<DT>[X]
+<DD>RFC 1808
+<DT>[1]
+<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
+<DT>[2]
+<DD>Lynx/2.7.1 libwww-FM/2.14
+<DT>[3]
+<DD>MSIE 3.01; Windows 95
+<DT>[4]
+<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
+</DL>
+
+<H3>Synopsis</H3>
+
+RFC 1808 specified that the "/" character within query information
+does not affect the hierarchy within URL parsing. It would appear that
+it does in current practice, but only within the relative path after
+it is attached to the base path. In other words, the base URL's query
+information is being stripped off before any relative resolution, but
+some parsers fail to separate the query information from the relative
+path.<P>
+
+We have decided that this behavior is due to an oversight in the original
+libwww implementation, and it is better to correct the oversight in future
+parsers than it is to make a nonsensical standard. A note has been added
+to the URI draft to account for the differences in implementations. This should
+have no impact on current practice since unescaped "/" is rarely (if ever)
+used within the query part of a URL, and query parts themselves are rarely
+used with relative URLs.
+
+<H2>Examples</H2>
+<PRE>
+ RESULTS from
+
+<a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4]
+
+<a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4]
+
+<a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4]
+
+<a href="/g">/g</a> = http://a/g [R,X,1,2,3,4]
+
+<a href="//g">//g</a> = http://g [R,X,1,2,3,4]
+
+<a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4]
+ http://a/b/c/d;p?y [X]
+
+<a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4]
+
+<a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X]
+ http://a/b/c/g?y/x [1,2,3,4]
+
+<a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X]
+ http://a/b/c/x [1,2,3,4]
+
+<a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4]
+
+<a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4]
+ http://a/b/c/g#s/x [1]
+
+<a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4]
+ http://a/b/c/x [1]
+
+<a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4]
+
+<a href="../">../</a> = http://a/b/ [R,X,1,2,3,4]
+
+<a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4]
+
+<a href="../../">../../</a> = http://a/ [R,X,1,2,3,4]
+
+<a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4]
+
+</PRE>
+</BODY></HTML>
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest3.html
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest3.html (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest3.html 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,89 @@
+<HTML><HEAD>
+<TITLE>Examples of Resolving Relative URLs, Part 3</TITLE>
+<BASE href="http://a/b/c/d;p=1/2?q">
+</HEAD><BODY>
+<H1>Examples of Resolving Relative URLs, Part 3</H1>
+
+This document has an embedded base URL of
+<PRE>
+ Content-Base: http://a/b/c/d;p=1/2?q
+</PRE>
+the relative URLs should be resolved as shown below. For this test page,
+I am particularly interested in testing whether "/" in parameters is or is not
+treated as part of the path hierarchy.
+<P>
+I will need your help testing the examples on multiple browsers.
+What you need to do is point to the example anchor and compare it to the
+resolved URL in your browser (most browsers have a feature by which you
+can see the resolved URL at the bottom of the window/screen when the anchor
+is active).
+
+<H2>Tested Clients and Client Libraries</H2>
+
+<DL COMPACT>
+<DT>[R]
+<DD>RFC 2396 (the right way to parse)
+<DT>[X]
+<DD>RFC 1808
+<DT>[1]
+<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
+<DT>[2]
+<DD>Lynx/2.7.1 libwww-FM/2.14
+<DT>[3]
+<DD>MSIE 3.01; Windows 95
+<DT>[4]
+<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12
+</DL>
+
+<H3>Synopsis</H3>
+
+RFC 1808 specified that the "/" character within parameter information
+does not affect the hierarchy within URL parsing. It would appear that
+it does in current practice. This implies that the parameters should
+be part of each path segment and not outside the path. The URI draft has
+been written accordingly.
+
+<H2>Examples</H2>
+<PRE>
+ RESULTS from
+
+<a href="g">g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4]
+ http://a/b/c/g [X]
+
+<a href="./g">./g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4]
+ http://a/b/c/g [X]
+
+<a href="g/">g/</a> = http://a/b/c/d;p=1/g/ [R,1,2,3,4]
+ http://a/b/c/g/ [X]
+
+<a href="g?y">g?y</a> = http://a/b/c/d;p=1/g?y [R,1,2,3,4]
+ http://a/b/c/g?y [X]
+
+<a href=";x">;x</a> = http://a/b/c/d;p=1/;x [R,1,2,3,4]
+ http://a/b/c/d;x [X]
+
+<a href="g;x">g;x</a> = http://a/b/c/d;p=1/g;x [R,1,2,3,4]
+ http://a/b/c/g;x [X]
+
+<a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/d;p=1/g;x=1/y [R,1,2,3,4]
+ http://a/b/c/g;x=1/./y [X]
+
+<a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/d;p=1/y [R,1,2,3,4]
+ http://a/b/c/g;x=1/../y [X]
+
+<a href="./">./</a> = http://a/b/c/d;p=1/ [R,1,2,3,4]
+ http://a/b/c/ [X]
+
+<a href="../">../</a> = http://a/b/c/ [R,1,2,3,4]
+ http://a/b/ [X]
+
+<a href="../g">../g</a> = http://a/b/c/g [R,1,2,3,4]
+ http://a/b/g [X]
+
+<a href="../../">../../</a> = http://a/b/ [R,1,2,3,4]
+ http://a/ [X]
+
+<a href="../../g">../../g</a> = http://a/b/g [R,1,2,3,4]
+ http://a/g [X]
+</PRE>
+</BODY></HTML>
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest4.html
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest4.html (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest4.html 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,98 @@
+<HTML><HEAD>
+<TITLE>Examples of Resolving Relative URLs, Part 4</TITLE>
+<BASE href="fred:///s//a/b/c">
+</HEAD><BODY>
+<H1>Examples of Resolving Relative URLs, Part 4</H1>
+
+This document has an embedded base URL of
+<PRE>
+ Content-Base: fred:///s//a/b/c
+</PRE>
+in order to test a notion that Tim Berners-Lee mentioned regarding
+the ability of URIs to have a triple-slash (or even more slashes)
+to indicate higher levels of hierarchy than those already used by URLs.
+
+<H2>Tested Clients and Client Libraries</H2>
+
+<DL COMPACT>
+<DT>[R]
+<DD>RFC 2396 (the right way to parse)
+<DT>Tim
+<DD>Tim Berners-Lee's proposed interpretation
+<DT>[1]
+<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
+<DT>[2]
+<DD>Lynx/2.7.1 libwww-FM/2.14
+<DT>[3]
+<DD>MSIE 3.01; Windows 95
+<DT>[4]
+<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)
+</DL>
+
+<H3>Synopsis</H3>
+
+RFC 1808 specified that the highest level for relative URLs is indicated
+by a double-slash "//", and therefore that any triple-slash would be
+considered a null site component, rather than a higher-level component
+than the site component (as proposed by Tim).<P>
+
+The URI draft assumes that a triple-slash means an empty site component.
+Netscape Navigator behaves irrationally, apparently because their parser
+is scheme-dependent and therefore doesn't do the hierarchical parsing that
+would be expected. Oddly, Lynx seems to straddle both sides.
+
+<H2>Examples</H2>
+<PRE>
+ RESULTS from
+
+<a href="g:h">g:h</a> = g:h [R,Tim,2,3]
+ fred:///s//a/b/g:h [1]
+
+<a href="g">g</a> = fred:///s//a/b/g [R,Tim,1,2,3]
+
+<a href="./g">./g</a> = fred:///s//a/b/g [R,Tim,2,3]
+ fred:///s//a/b/./g [1]
+
+<a href="g/">g/</a> = fred:///s//a/b/g/ [R,Tim,1,2,3]
+
+<a href="/g">/g</a> = fred:///g [R,1,2,3]
+ fred:///s//a/g [Tim]
+
+<a href="//g">//g</a> = fred://g [R,1,2,3]
+ fred:///s//g [Tim]
+
+<a href="//g/x">//g/x</a> = fred://g/x [R,1,2,3]
+ fred:///s//g/x [Tim]
+
+<a href="///g">///g</a> = fred:///g [R,Tim,1,2,3]
+
+<a href="./">./</a> = fred:///s//a/b/ [R,Tim,2,3]
+ fred:///s//a/b/./ [1]
+
+<a href="../">../</a> = fred:///s//a/ [R,Tim,2,3]
+ fred:///s//a/b/../ [1]
+
+<a href="../g">../g</a> = fred:///s//a/g [R,Tim,2,3]
+ fred:///s//a/b/../g [1]
+
+<a href="../../">../../</a> = fred:///s// [R]
+ fred:///s//a/../ [Tim,2]
+ fred:///s//a/b/../../ [1]
+ fred:///s//a/ [3]
+
+<a href="../../g">../../g</a> = fred:///s//g [R]
+ fred:///s//a/../g [Tim,2]
+ fred:///s//a/b/../../g [1]
+ fred:///s//a/g [3]
+
+<a href="../../../g">../../../g</a> = fred:///s/g [R]
+ fred:///s//a/../../g [Tim,2]
+ fred:///s//a/b/../../../g [1]
+ fred:///s//a/g [3]
+
+<a href="../../../../g">../../../../g</a> = fred:///g [R]
+ fred:///s//a/../../../g [Tim,2]
+ fred:///s//a/b/../../../../g [1]
+ fred:///s//a/g [3]
+</PRE>
+</BODY></HTML>
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest5.html
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest5.html (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/roytest5.html 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,92 @@
+<HTML><HEAD>
+<TITLE>Examples of Resolving Relative URLs, Part 5</TITLE>
+<BASE href="http:///s//a/b/c">
+</HEAD><BODY>
+<H1>Examples of Resolving Relative URLs, Part 5</H1>
+
+This document has an embedded base URL of
+<PRE>
+ Content-Base: http:///s//a/b/c
+</PRE>
+in order to test a notion that Tim Berners-Lee mentioned regarding
+the ability of URIs to have a triple-slash (or even more slashes)
+to indicate higher levels of hierarchy than those already used by URLs.
+This is the same as Part 4, except that the scheme "fred" is replaced
+with "http" for clients that stupidly change their parsing behavior
+based on the scheme name.
+
+<H2>Tested Clients and Client Libraries</H2>
+
+<DL COMPACT>
+<DT>[R]
+<DD>RFC 2396 (the right way to parse)
+<DT>Tim
+<DD>Tim Berners-Lee's proposed interpretation
+<DT>[1]
+<DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav)
+<DT>[2]
+<DD>Lynx/2.7.1 libwww-FM/2.14
+<DT>[3]
+<DD>MSIE 3.01; Windows 95
+<DT>[4]
+<DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m)
+</DL>
+
+<H3>Synopsis</H3>
+
+RFC 1808 specified that the highest level for relative URLs is indicated
+by a double-slash "//", and therefore that any triple-slash would be
+considered a null site component, rather than a higher-level component
+than the site component (as proposed by Tim).<P>
+
+Draft 09 assumes that a triple-slash means an empty site component,
+as does Netscape Navigator if the scheme is known.
+Oddly, Lynx seems to straddle both sides.
+
+<H2>Examples</H2>
+<PRE>
+ RESULTS from
+
+<a href="g:h">g:h</a> = g:h [R,Tim,2,3]
+ http:///s//a/b/g:h [1]
+
+<a href="g">g</a> = http:///s//a/b/g [R,Tim,1,2,3]
+
+<a href="./g">./g</a> = http:///s//a/b/g [R,Tim,1,2,3]
+
+<a href="g/">g/</a> = http:///s//a/b/g/ [R,Tim,1,2,3]
+
+<a href="/g">/g</a> = http:///g [R,1,2,3]
+ http:///s//a/g [Tim]
+
+<a href="//g">//g</a> = http://g [R,1,2,3]
+ http:///s//g [Tim]
+
+<a href="//g/x">//g/x</a> = http://g/x [R,1,2,3]
+ http:///s//g/x [Tim]
+
+<a href="///g">///g</a> = http:///g [R,Tim,1,2,3]
+
+<a href="./">./</a> = http:///s//a/b/ [R,Tim,1,2,3]
+
+<a href="../">../</a> = http:///s//a/ [R,Tim,1,2,3]
+
+<a href="../g">../g</a> = http:///s//a/g [R,Tim,1,2,3]
+
+<a href="../../">../../</a> = http:///s// [R,1]
+ http:///s//a/../ [Tim,2]
+ http:///s//a/ [3]
+
+<a href="../../g">../../g</a> = http:///s//g [R,1]
+ http:///s//a/../g [Tim,2]
+ http:///s//a/g [3]
+
+<a href="../../../g">../../../g</a> = http:///s/g [R,1]
+ http:///s//a/../../g [Tim,2]
+ http:///s//a/g [3]
+
+<a href="../../../../g">../../../../g</a> = http:///g [R,1]
+ http:///s//a/../../../g [Tim,2]
+ http:///s//a/g [3]
+</PRE>
+</BODY></HTML>
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rsync.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rsync.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rsync.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,23 @@
+#!perl -w
+
+print "1..4\n";
+
+use strict;
+use Catalyst::SmartURI;
+
+my $u = Catalyst::SmartURI->new('rsync://gisle@perl.com/foo/bar');
+
+print "not " unless $u->user eq "gisle";
+print "ok 1\n";
+
+print "not " unless $u->port eq 873;
+print "ok 2\n";
+
+print "not " unless $u->path eq "/foo/bar";
+print "ok 3\n";
+
+$u->port(8730);
+
+print "not " unless $u eq 'rsync://gisle@perl.com:8730/foo/bar';
+print "ok 4\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rtsp.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rtsp.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/rtsp.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,42 @@
+#!perl -w
+
+print "1..9\n";
+
+use Catalyst::SmartURI;
+
+$u = Catalyst::SmartURI->new("<rtsp://media.perl.com/fôo.smi/>");
+
+#print "$u\n";
+print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/";
+print "ok 1\n";
+
+print "not " unless $u->port == 554;
+print "ok 2\n";
+
+# play with port
+$old = $u->port(8554);
+print "not " unless $old == 554 && $u eq "rtsp://media.perl.com:8554/f%F4o.smi/";
+print "ok 3\n";
+
+$u->port(554);
+print "not " unless $u eq "rtsp://media.perl.com:554/f%F4o.smi/";
+print "ok 4\n";
+
+$u->port("");
+print "not " unless $u eq "rtsp://media.perl.com:/f%F4o.smi/" && $u->port == 554;
+print "ok 5\n";
+
+$u->port(undef);
+print "not " unless $u eq "rtsp://media.perl.com/f%F4o.smi/";
+print "ok 6\n";
+
+print "not " unless $u->host eq "media.perl.com";
+print "ok 7\n";
+
+print "not " unless $u->path eq "/f%F4o.smi/";
+print "ok 8\n";
+
+$u->scheme("rtspu");
+print "not " unless $u->scheme eq "rtspu";
+print "ok 9\n";
+
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/sip.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/sip.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/sip.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,70 @@
+#!perl -w
+
+print "1..11\n";
+
+use Catalyst::SmartURI;
+use strict;
+
+my $u = Catalyst::SmartURI->new('sip:phone at domain.ext');
+
+print "not " unless $u->user eq 'phone' &&
+ $u->host eq 'domain.ext' &&
+ $u->port eq '5060' &&
+ $u eq 'sip:phone at domain.ext';
+print "ok 1\n";
+
+$u->host_port('otherdomain.int:9999');
+print "not " unless $u->host eq 'otherdomain.int' &&
+ $u->port eq '9999' &&
+ $u eq 'sip:phone at otherdomain.int:9999';
+print "ok 2\n";
+
+$u->port('5060');
+$u = $u->canonical;
+print "not " unless $u->host eq 'otherdomain.int' &&
+ $u->port eq '5060' &&
+ $u eq 'sip:phone at otherdomain.int';
+print "ok 3\n";
+
+$u->user('voicemail');
+print "not " unless $u->user eq 'voicemail' &&
+ $u eq 'sip:voicemail at otherdomain.int';
+print "ok 4\n";
+
+$u = Catalyst::SmartURI->new('sip:phone at domain.ext?Subject=Meeting&Priority=Urgent');
+print "not " unless $u->host eq 'domain.ext' &&
+ $u->query eq 'Subject=Meeting&Priority=Urgent';
+print "ok 5\n";
+
+$u->query_form(Subject => 'Lunch', Priority => 'Low');
+my @q = $u->query_form;
+print "not " unless $u->host eq 'domain.ext' &&
+ $u->query eq 'Subject=Lunch&Priority=Low' &&
+ @q == 4 && "@q" eq "Subject Lunch Priority Low";
+print "ok 6\n";
+
+$u = Catalyst::SmartURI->new('sip:phone at domain.ext;maddr=127.0.0.1;ttl=16');
+print "not " unless $u->host eq 'domain.ext' &&
+ $u->params eq 'maddr=127.0.0.1;ttl=16';
+print "ok 7\n";
+
+$u = Catalyst::SmartURI->new('sip:phone at domain.ext?Subject=Meeting&Priority=Urgent');
+$u->params_form(maddr => '127.0.0.1', ttl => '16');
+my @p = $u->params_form;
+print "not " unless $u->host eq 'domain.ext' &&
+ $u->query eq 'Subject=Meeting&Priority=Urgent' &&
+ $u->params eq 'maddr=127.0.0.1;ttl=16' &&
+ @p == 4 && "@p" eq "maddr 127.0.0.1 ttl 16";
+
+print "ok 8\n";
+
+$u = Catalyst::SmartURI->new_abs('sip:phone at domain.ext', 'sip:foo at domain2.ext');
+print "not " unless $u eq 'sip:phone at domain.ext';
+print "ok 9\n";
+
+$u = Catalyst::SmartURI->new('sip:phone at domain.ext');
+print "not " unless $u eq $u->abs('http://www.cpan.org/');
+print "ok 10\n";
+
+print "not " unless $u eq $u->rel('http://www.cpan.org/');
+print "ok 11\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/split.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/split.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/split.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,60 @@
+#!perl -w
+
+print "1..17\n";
+
+use strict;
+use Catalyst::SmartURI;
+use Catalyst::SmartURI::Split qw(uri_split uri_join);
+
+sub j { join("-", map { defined($_) ? $_ : "<undef>" } @_) }
+
+print "not " unless j(uri_split("p")) eq "<undef>-<undef>-p-<undef>-<undef>";
+print "ok 1\n";
+
+print "not " unless j(uri_split("p?q")) eq "<undef>-<undef>-p-q-<undef>";
+print "ok 2\n";
+
+print "not " unless j(uri_split("p#f")) eq "<undef>-<undef>-p-<undef>-f";
+print "ok 3\n";
+
+print "not " unless j(uri_split("p?q/#f/?")) eq "<undef>-<undef>-p-q/-f/?";
+print "ok 4\n";
+
+print "not " unless j(uri_split("s://a/p?q#f")) eq "s-a-/p-q-f";
+print "ok 5\n";
+
+print "not " unless uri_join("s", "a", "/p", "q", "f") eq "s://a/p?q#f";
+print "ok 6\n";
+
+print "not " unless uri_join("s", "a", "p", "q", "f") eq "s://a/p?q#f";
+print "ok 7\n";
+
+print "not " unless uri_join(undef, undef, "", undef, undef) eq "";
+print "ok 8\n";
+
+print "not " unless uri_join(undef, undef, "p", undef, undef) eq "p";
+print "ok 9\n";
+
+print "not " unless uri_join("s", undef, "p") eq "s:p";
+print "ok 10\n";
+
+print "not " unless uri_join("s") eq "s:";
+print "ok 11\n";
+
+print "not " unless uri_join() eq "";
+print "ok 12\n";
+
+print "not " unless uri_join("s", "a") eq "s://a";
+print "ok 13\n";
+
+print "not " unless uri_join("s", "a/b") eq "s://a%2Fb";
+print "ok 14\n";
+
+print "not " unless uri_join("s", ":/?#", ":/?#", ":/?#", ":/?#") eq "s://:%2F%3F%23/:/%3F%23?:/?%23#:/?#";
+print "ok 15\n";
+
+print "not " unless uri_join(undef, undef, "a:b") eq "a%3Ab";
+print "ok 16\n";
+
+print "not " unless uri_join("s", undef, "//foo//bar") eq "s:////foo//bar";
+print "ok 17\n";
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable-test.pl
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable-test.pl (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable-test.pl 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,28 @@
+#!perl -w
+
+use strict;
+use Storable;
+
+if (@ARGV && $ARGV[0] eq "store") {
+ use Catalyst::SmartURI;
+ require Catalyst::SmartURI::URL;
+ my $a = {
+ u => new Catalyst::SmartURI('http://search.cpan.org/'),
+ };
+ print "# store\n";
+ store [Catalyst::SmartURI->new("http://search.cpan.org")], 'urls.sto';
+} else {
+ print "# retrieve\n";
+ my $a = retrieve 'urls.sto';
+ my $u = $a->[0];
+ #use Data::Dumper; print Dumper($a);
+
+ print "not " unless $u eq "http://search.cpan.org";
+ print "ok 1\n";
+
+ print "not " unless $u->scheme eq "http";
+ print "ok 2\n";
+
+ print "not " unless ref($u) eq "Catalyst::SmartURI::http";
+ print "ok 3\n";
+}
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/storable.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,15 @@
+#!perl -w
+
+eval {
+ require Storable;
+ print "1..3\n";
+};
+if ($@) {
+ print "1..0 # skipped: Needs the Storable module installed\n";
+ exit;
+}
+
+system($^X, "-Iblib/lib", "t/uri/storable-test.pl", "store");
+system($^X, "-Iblib/lib", "t/uri/storable-test.pl", "retrieve");
+
+unlink('urls.sto');
Added: Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/urn-oid.t
===================================================================
--- Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/urn-oid.t (rev 0)
+++ Catalyst-Plugin-SmartURI/1.000/trunk/t/uri/urn-oid.t 2008-03-13 05:48:22 UTC (rev 7491)
@@ -0,0 +1,24 @@
+#!perl -w
+
+print "1..4\n";
+
+use strict;
+use Catalyst::SmartURI;
+
+my $u = Catalyst::SmartURI->new("urn:oid");
+
+$u->oid(1..10);
+
+#print "$u\n";
+
+print "not " unless $u eq "urn:oid:1.2.3.4.5.6.7.8.9.10";
+print "ok 1\n";
+
+print "not " unless $u->oid eq "1.2.3.4.5.6.7.8.9.10";
+print "ok 2\n";
+
+print "not " unless $u->scheme eq "urn" && $u->nid eq "oid";
+print "ok 3\n";
+
+print "not " unless $u->oid eq $u->nss;
+print "ok 4\n";
More information about the Catalyst-commits
mailing list