uri.pm

稀饭伊人相册系统继承了新天堂多用户相册系统的功能

####################################################################
#                     新天堂多用户相册系统V2.0 B                   #
#                     内部版本号：200601241006000                  #
#                       http://pic.sakuras.cn                      #
####################################################################
#             本程序仅授权于非赢利性质的个人站点免费使用.          #
#                 未经本人允许,不得用于任何商业用途                #
#             本程序为开源程序,你可以复制和传播                    #
#               尊重作者劳动！请保留版权信息，标示和图标！         #
####################################################################
package URI;  # $Date: 2002/09/03 03:35:23 $

use strict;
use vars qw($VERSION);
$VERSION = "1.22";

use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME);

my %implements;  # mapping from scheme to implementor class

# Some "official" character classes

use vars qw($reserved $mark $unreserved $uric $scheme_re);
$reserved   = q(;/?:@&=+$,[]);
$mark       = q(-_.!~*'());                                    #'; emacs
$unreserved = "A-Za-z0-9\Q$mark\E";
$uric       = quotemeta($reserved) . $unreserved . "%";

$scheme_re  = '[a-zA-Z][a-zA-Z0-9.+\-]*';

use Carp ();
use URI::Escape ();

use overload ('""'     => sub { ${$_[0]} },
              '=='     => sub { overload::StrVal($_[0]) eq
                                overload::StrVal($_[1])
                              },
              fallback => 1,
             );

sub new
{
    my($class, $uri, $scheme) = @_;

    $uri = defined ($uri) ? "$uri" : "";   # stringify
    # Get rid of potential wrapping
    $uri =~ s/^<(?:URL:)?(.*)>$/$1/;  #
    $uri =~ s/^"(.*)"$/$1/;
    $uri =~ s/^\s+//;
    $uri =~ s/\s+$//;

    my $impclass;
    if ($uri =~ m/^($scheme_re):/so) {
        $scheme = $1;
    } else {
        if (($impclass = ref($scheme))) {
            $scheme = $scheme->scheme;
        } elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
            $scheme = $1;
        }
    }
    $impclass ||= implementor($scheme) ||
        do {
            require URI::_foreign;
            $impclass = 'URI::_foreign';
        };

    return $impclass->_init($uri, $scheme);
}


sub new_abs
{
    my($class, $uri, $base) = @_;
    $uri = $class->new($uri, $base);
    $uri->abs($base);
}


sub _init
{
    my $class = shift;
    my($str, $scheme) = @_;
    $str =~ s/([^$uric\#])/$URI::Escape::escapes{$1}/go;
    $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
                                 $class->_no_scheme_ok;
    my $self = bless \$str, $class;
    $self;
}


sub implementor
{
    my($scheme, $impclass) = @_;
    if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
        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

    # turn scheme into a valid perl identifier by a simple tranformation...
    $ic =~ s/\+/_P/g;
    $ic =~ s/\./_O/g;
    $ic =~ s/\-/_/g;

    no strict 'refs';
    # check we actually have one for the scheme:
    unless (@{"${ic}::ISA"}) {
        # Try to load it
        eval "require $ic";
        die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
        return unless @{"${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 URI schemes.
}


sub clone
{
    my $self = shift;
    my $other = $$self;
    bless \$other, ref $self;
}


sub _no_scheme_ok { 0 }

sub _scheme
{
    my $self = shift;

    unless (@_) {
        return unless $$self =~ /^($scheme_re):/o;
        return $1;
    }

    my $old;
    my $new = shift;
    if (defined($new) && length($new)) {
        Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
        $old = $1 if $$self =~ s/^($scheme_re)://o;
        my $newself = URI->new("$new:$$self");
        $$self = $$newself;
        bless $self, ref($newself);
    } else {
        if ($self->_no_scheme_ok) {
            $old = $1 if $$self =~ s/^($scheme_re)://o;
            Carp::carp("Oops, opaque part now look like scheme")
                if $^W && $$self =~ m/^$scheme_re:/o
        } else {
            $old = $1 if $$self =~ m/^($scheme_re):/o;
        }
    }

    return $old;
}

sub scheme
{
    my $scheme = shift->_scheme(@_);
    return unless defined $scheme;
    lc($scheme);
}


sub opaque
{
    my $self = shift;

    unless (@_) {
        $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
        return $1;
    }

    $$self =~ /^($scheme_re:)?    # optional scheme
                ([^\#]*)          # opaque
                (\#.*)?           # optional fragment
              $/sx or die;

    my $old_scheme = $1;
    my $old_opaque = $2;
    my $old_frag   = $3;

    my $new_opaque = shift;
    $new_opaque = "" unless defined $new_opaque;
    $new_opaque =~ s/([^$uric])/$URI::Escape::escapes{$1}/go;

    $$self = defined($old_scheme) ? $old_scheme : "";
    $$self .= $new_opaque;
    $$self .= $old_frag if defined $old_frag;

    $old_opaque;
}

*path = \&opaque;  # alias


sub fragment
{
    my $self = shift;
    unless (@_) {
        return unless $$self =~ /\#(.*)/s;
        return $1;
    }

    my $old;
    $old = $1 if $$self =~ s/\#(.*)//s;

    my $new_frag = shift;
    if (defined $new_frag) {
        $new_frag =~ s/([^$uric])/$URI::Escape::escapes{$1}/go;
        $$self .= "#$new_frag";
    }
    $old;
}


sub as_string
{
    my $self = shift;
    $$self;
}


sub canonical
{
    my $self = shift;

    # Make sure scheme is lowercased
    my $scheme = $self->_scheme || "";
    my $uc_scheme = $scheme =~ /[A-Z]/;
    my $lc_esc    = $$self =~ /%(?:[a-f][a-fA-F0-9]|[A-F0-9][a-f])/;
    if ($uc_scheme || $lc_esc) {
        my $other = $self->clone;
        $other->_scheme(lc $scheme) if $uc_scheme;
        $$other =~ s/(%(?:[a-f][a-fA-F0-9]|[A-F0-9][a-f]))/uc($1)/ge
            if $lc_esc;
        return $other;
    }
    $self;
}

# Compare two URIs, subclasses will provide a more correct implementation
sub eq {
    my($self, $other) = @_;
    $self  = URI->new($self, $other) unless ref $self;
    $other = URI->new($other, $self) unless ref $other;
    ref($self) eq ref($other) &&                # same class
        $self->canonical->as_string eq $other->canonical->as_string;
}

# generic-URI transformation methods
sub abs { $_[0]; }
sub rel { $_[0]; }

1;

__END__

=head1 NAME

URI - Uniform Resource Identifiers (absolute and relative)

=head1 SYNOPSIS

 $u1 = URI->new("http://www.perl.com");
 $u2 = URI->new("foo", "http");
 $u3 = $u2->abs($u1);
 $u4 = $u3->clone;
 $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;

 $str = $u->as_string;
 $str = "$u";

 $scheme = $u->scheme;
 $opaque = $u->opaque;
 $path   = $u->path;
 $frag   = $u->fragment;

 $u->scheme("ftp");
 $u->host("ftp.perl.com");
 $u->path("cpan/");

=head1 DESCRIPTION

This module implements the C<URI> class.  Objects of this class
represent "Uniform Resource Identifier references" as specified in RFC
2396 (and updated by RFC 2732).

A Uniform Resource Identifier is a compact string of characters for
identifying an abstract or physical resource.  A Uniform Resource
Identifier can be further classified either a Uniform Resource Locator
(URL) or a Uniform Resource Name (URN).  The distinction between URL
and URN does not matter to the C<URI> class interface. A
"URI-reference" is a URI that may have additional information attached
in the form of a fragment identifier.

An absolute URI reference consists of three parts.  A I<scheme>, a
I<scheme specific part> and a I<fragment> identifier.  A subset of URI
references share a common syntax for hierarchical namespaces.  For
these the scheme specific part is further broken down into
I<authority>, I<path> and I<query> components.  These URI can also
take the form of relative URI references, where the scheme (and
usually also the authority) component is missing, but implied by the
context of the URI reference.  The three forms of URI reference
syntax are summarized as follows:

  <scheme>:<scheme-specific-part>#<fragment>
  <scheme>://<authority><path>?<query>#<fragment>
  <path>?<query>#<fragment>

The components that a URI reference can be divided into depend on the
I<scheme>.  The C<URI> class provides methods to get and set the
individual components.  The methods available for a specific
C<URI> object depend on the scheme.

=head1 CONSTRUCTORS

The following methods construct new C<URI> objects:

=over 4

=item $uri = URI->new( $str, [$scheme] )

This class method constructs a new URI object.  The string
representation of a URI is given as argument together with an optional
scheme specification.  Common URI wrappers like "" and <>, as well as
leading and trailing white space, are automatically removed from
the $str argument before it is processed further.

The constructor determines the scheme, maps this to an appropriate
URI subclass, constructs a new object of that class and returns it.

The $scheme argument is only used when $str is a
relative URI.  It can either be a simple string that
denotes the scheme, a string containing an absolute URI reference or
an absolute C<URI> object.  If no $scheme is specified for a relative
URI $str, then $str is simply treated as a generic URI (no scheme
specific methods available).

The set of characters available for building URI references is
restricted (see L<URI::Escape>).  Characters outside this set are
automatically escaped by the URI constructor.

=item $uri = URI->new_abs( $str, $base_uri )

This constructs a new absolute URI object.  The $str argument can
denote a relative or absolute URI.  If relative, then it will be
absolutized using $base_uri as base. The $base_uri must be an absolute
URI.

=item $uri = URI::file->new( $filename, [$os] )

This constructs a new I<file> URI from a file name.  See L<URI::file>.

=item $uri = URI::file->new_abs( $filename, [$os] )

This constructs a new absolute I<file> URI from a file name.  See
L<URI::file>.

=item $uri = URI::file->cwd

This returns the current working directory as a I<file> URI.  See
L<URI::file>.

=item $uri->clone

This method returns a copy of the $uri.

=back

=head1 COMMON METHODS

The methods described in this section are available for all C<URI>
objects.

Methods that give access to components of a URI will always return the
old value of the component.  The value returned will be C<undef> if the
component was not present.  There is generally a difference between a
component that is empty (represented as C<"">) and a component that is
missing (represented as C<undef>).  If an accessor method is given an
argument it will update the corresponding component in addition to
returning the old value of the component.  Passing an undefined
argument will remove the component (if possible).  The description of
the various accessor methods will tell if the component is passed as
an escaped or an unescaped string.  Components that can be futher
divided into sub-parts are usually passed escaped, as unescaping might
change its semantics.

The common methods available for all URI are:

=over 4

=item $uri->scheme( [$new_scheme] )

This method sets and returns the scheme part of the $uri.  If the $uri is
relative, then $uri->scheme returns C<undef>.  If called with an
argument, it will update the scheme of $uri, possibly changing the
class of $uri, and return the old scheme value.  The method croaks
if the new scheme name is illegal; scheme names must begin with a
letter and must consist of only US-ASCII letters, numbers, and a few
special marks: ".", "+", "-".  This restriction effectively means
that scheme have to be passed unescaped.  Passing an undefined
argument to the scheme method will make the URI relative (if possible).

Letter case does not matter for scheme names.  The string
returned by $uri->scheme is always lowercase.  If you want the scheme
just as it was written in the URI in its original case,
you can use the $uri->_scheme method instead.

=item $uri->opaque( [$new_opaque] )

This method sets and returns the scheme specific part of the $uri
(everything between the scheme and the fragment)
as an escaped string.

=item $uri->path( [$new_path] )

This method sets and returns the same value as $uri->opaque unless the URI
supports the generic syntax for hierarchical namespaces.
In that case the generic method is overridden to set and return
the part of the URI between the I<host name> and the I<fragment>.

=item $uri->fragment( [$new_frag] )