First revision.

MANIFEST

@@ -0,0 +1,4 @@
+MANIFEST
+Makefile.PL
+URI.pm
+URI/_generic.pm

MANIFEST.SKIP

@@ -0,0 +1,11 @@
+^blib/
+\.old$
+\.bak$
+Makefile$
+^MANIFEST.SKIP$
+^#
+/#
+~$
+\b(RCS|CVS)/[^/]+$
+\.cvsignore$
+pm_to_blib$

Makefile.PL

@@ -0,0 +1,11 @@
+require 5.004;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    'NAME'	   => 'URI',
+    'VERSION_FROM' => 'URI.pm',
+    'PREREQ_PM'    => {	
+	                 'URI::Escape' => 0,
+		      },
+    dist           => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+);

URI.pm

@@ -0,0 +1,227 @@
+package URI;
+
+use strict;
+use vars qw($DEFAULT_SCHEME $STRICT_URL $DEBUG);
+
+$DEFAULT_SCHEME ||= "http";
+#$STRICT_URL = 0;
+#$DEBUG = 0;
+$DEBUG = 1;
+
+my %implements;  # mapping from scheme to implementor class
+
+# official character classes
+my $reserved   = q(;/?:@&=+$,);
+my $mark       = q(-_.!~*'());                                    #';
+my $unreserved = "A-Za-z0-9\Q$mark\E";
+
+use vars qw($uric $pchar $achar $ppchar);
+$uric  = "\Q$reserved\E$unreserved%";
+$pchar = $uric;  $pchar =~ s,\\[/?;],,g;
+
+$achar = $uric;   $achar =~ s,\\[/?],,g;
+$ppchar = $uric;  $ppchar =~ s,\\?,,g;
+
+
+my $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
+
+#print "$uric\n$achar\n$pchar\n";
+
+use Carp ();
+use URI::Escape ();
+
+sub new
+{
+    my($class, $url, $base) = @_;
+    my $self;
+    if (ref $url) {
+	$self = $url->clone;
+	$self->base($base) if $base
+    } else {
+	$url = "" unless defined $url;
+        # RFC 1738 appendix suggest that we just ignore extra whitespace
+        $url =~ s/^\s+//;
+	$url =~ s/\s+$//;
+        # Also get rid of any <URL: > wrapper
+        $url =~ s/^<(?:URL:)?(.*)>$/$1/;
+
+	# We need a scheme to determine which class to use
+        my $scheme;
+        $scheme = $1 if $url =~ m/^($scheme_re):/o;
+	unless ($scheme) {
+            if (ref $base){
+                $scheme = $base->scheme;
+	    } elsif ($base && $base =~ m/^($scheme_re):/o) {
+                $scheme = $1;
+	    } elsif ($DEFAULT_SCHEME && !$STRICT_URL) {
+		$scheme = $DEFAULT_SCHEME;
+	    } else {
+		Carp::croak("Unable to determine scheme for '$url'");
+	    }
+        }
+	my $impclass = implementor($scheme);
+        unless ($impclass) {
+            Carp::croak("URI scheme '$scheme' is not supported")
+		if $STRICT_URL;
+            # use generic as fallback
+            require URI::_generic;
+            $impclass = 'URI::_generic';
+            implementor($scheme, $impclass);  # register it
+        }
+        # hand-off to scheme specific implementation sub-class
+        $self = $impclass->_init($url, $base, $scheme);
+    }
+    $self;
+}
+
+sub _init
+{
+    my $class = shift;
+    my($str, $base, $scheme) = @_;
+    my $self = bless {}, $class;
+    $self->{'_scheme'} = $scheme;
+    $self->{'_orig_uri'} = $str if $DEBUG;
+    $self->base($base) if $base;
+    $self->_parse($str);
+    $self;
+}
+
+sub _parse
+{
+    my($self, $str) = @_;
+    # <scheme>:<scheme-specific-part>
+    $self->{'scheme'} = $1 if $str =~ s/^($scheme_re)://o;
+    $self->{'fragment'}   = $1 if $str =~ s/\#(.*)//s;
+    $self->{'specific'} = $str;
+}
+
+
+sub implementor
+{
+    my($scheme, $impclass) = @_;
+    unless (defined $scheme) {
+        require URI::_generic;
+        return 'URI::_generic';
+    }
+    $scheme = lc($scheme);
+
+    if ($impclass) {
+	# Set the implementor class for a given scheme
+        my $old = $implements{$scheme};
+        $impclass->_init_implementor($scheme);
+        $implements{$scheme} = $impclass;
+        return $old;
+    }
+
+    my $ic = $implements{$scheme};
+    return $ic if $ic;
+
+    # scheme not yet known, look for internal or
+    # preloaded (with 'use') implementation
+    $ic = "URI::$scheme";  # default location
+    no strict 'refs';
+    # check we actually have one for the scheme:
+    unless (defined @{"${ic}::ISA"}) {
+        # Try to load it
+        eval "require $ic";
+        die $@ if $@ && $@ !~ /Can\'t locate/;
+        return unless defined @{"${ic}::ISA"};
+    }
+
+    $ic->_init_implementor($scheme);
+    $implements{$scheme} = $ic;
+    $ic;
+}
+
+sub _init_implementor
+{
+    my($class, $scheme) = @_;
+    # Remember that one implementor class may actually
+    # serve to implement several URL schemes.
+}
+
+sub clone
+{
+    my $self = shift;
+    # this work as long as none of the components are references themselves
+    bless { %$self }, ref $self;
+}
+
+sub _elem
+{
+    my $self = shift;
+    my $elem = shift;
+    my $old = $self->{$elem};
+    if (@_) {
+	$self->{$elem} = shift;
+	$self->{'_str'} = '';        # void cached string
+    }
+    $old;
+}
+
+
+sub scheme
+{
+    my $self = shift;
+    my $old = $self->{'scheme'};
+    if (@_) {
+	my $new_scheme = shift;
+	if (defined($new_scheme) && length($new_scheme)) {
+	    # reparse URI with new scheme
+	    my $str = $self->as_string;
+	    $str =~ s/^$scheme_re://o;
+	    my $newself = URI->new("$new_scheme:$str");
+	    %$self = %$newself;  # copy content
+	    bless $self, ref($newself);
+	} else {
+	    $self->{'scheme'} = undef;
+	}
+    }
+    $old;
+}
+
+sub fragment
+{
+    shift->_elem("fragment", @_);
+}
+
+
+sub as_string
+{
+    my $self = shift;
+    if (my $str = $self->{'_str'}) {
+	return $str;  # cached
+    }
+    $self->{'_str'} = $self->_as_string;  # set cache and return
+}
+
+sub _as_string
+{
+    my $self = shift;
+    my $str = "";
+    my($scheme, $specific, $fragment) = @{$self}{qw(scheme specific fragment)};
+    $str = "$scheme:" if $scheme;
+    $specific =~ s/([^$uric])/$URI::Escape::escapes{$1}/go;
+    $str .= $specific;
+    if (defined $fragment) {
+	$fragment =~ s/([^$uric])/$URI::Escape::escapes{$1}/go;
+	$str .= "#$fragment";
+    }
+    $str;
+}
+
+# generic-URI accessor methods
+sub authority;
+sub userinfo;
+sub host;
+sub port;
+sub abs_path;
+sub path;
+sub path_segments;
+sub query;
+
+# generic-URI transformation methods
+sub abs { shift->clone; }
+sub rel { shift->clone; }
+
+1;