#####################################################################                     新天堂多用戶相冊系統(tǒng)V2.0 B                   ##                     內(nèi)部版本號：200601241006000                  ##                       http://pic.sakuras.cn                      ######################################################################             本程序僅授權(quán)于非贏利性質(zhì)的個人站點免費使用.          ##                 未經(jīng)本人允許,不得用于任何商業(yè)用途                ##             本程序為開源程序,你可以復(fù)制和傳播                    ##               尊重作者勞動！請保留版權(quán)信息，標(biāo)示和圖標(biāo)！         #####################################################################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 classesuse 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;  # aliassub 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 implementationsub 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 methodssub abs { $_[0]; }sub rel { $_[0]; }1;__END__=head1 NAMEURI - 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 DESCRIPTIONThis module implements the C<URI> class.  Objects of this classrepresent "Uniform Resource Identifier references" as specified in RFC2396 (and updated by RFC 2732).A Uniform Resource Identifier is a compact string of characters foridentifying an abstract or physical resource.  A Uniform ResourceIdentifier can be further classified either a Uniform Resource Locator(URL) or a Uniform Resource Name (URN).  The distinction between URLand URN does not matter to the C<URI> class interface. A"URI-reference" is a URI that may have additional information attachedin the form of a fragment identifier.An absolute URI reference consists of three parts.  A I<scheme>, aI<scheme specific part> and a I<fragment> identifier.  A subset of URIreferences share a common syntax for hierarchical namespaces.  Forthese the scheme specific part is further broken down intoI<authority>, I<path> and I<query> components.  These URI can alsotake the form of relative URI references, where the scheme (andusually also the authority) component is missing, but implied by thecontext of the URI reference.  The three forms of URI referencesyntax 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 theI<scheme>.  The C<URI> class provides methods to get and set theindividual components.  The methods available for a specificC<URI> object depend on the scheme.=head1 CONSTRUCTORSThe following methods construct new C<URI> objects:=over 4=item $uri = URI->new( $str, [$scheme] )This class method constructs a new URI object.  The stringrepresentation of a URI is given as argument together with an optionalscheme specification.  Common URI wrappers like "" and <>, as well asleading and trailing white space, are automatically removed fromthe $str argument before it is processed further.The constructor determines the scheme, maps this to an appropriateURI subclass, constructs a new object of that class and returns it.The $scheme argument is only used when $str is arelative URI.  It can either be a simple string thatdenotes the scheme, a string containing an absolute URI reference oran absolute C<URI> object.  If no $scheme is specified for a relativeURI $str, then $str is simply treated as a generic URI (no schemespecific methods available).The set of characters available for building URI references isrestricted (see L<URI::Escape>).  Characters outside this set areautomatically escaped by the URI constructor.=item $uri = URI->new_abs( $str, $base_uri )This constructs a new absolute URI object.  The $str argument candenote a relative or absolute URI.  If relative, then it will beabsolutized using $base_uri as base. The $base_uri must be an absoluteURI.=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.  SeeL<URI::file>.=item $uri = URI::file->cwdThis returns the current working directory as a I<file> URI.  SeeL<URI::file>.=item $uri->cloneThis method returns a copy of the $uri.=back=head1 COMMON METHODSThe methods described in this section are available for all C<URI>objects.Methods that give access to components of a URI will always return theold value of the component.  The value returned will be C<undef> if thecomponent was not present.  There is generally a difference between acomponent that is empty (represented as C<"">) and a component that ismissing (represented as C<undef>).  If an accessor method is given anargument it will update the corresponding component in addition toreturning the old value of the component.  Passing an undefinedargument will remove the component (if possible).  The description ofthe various accessor methods will tell if the component is passed asan escaped or an unescaped string.  Components that can be futherdivided into sub-parts are usually passed escaped, as unescaping mightchange 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 isrelative, then $uri->scheme returns C<undef>.  If called with anargument, it will update the scheme of $uri, possibly changing theclass of $uri, and return the old scheme value.  The method croaksif the new scheme name is illegal; scheme names must begin with aletter and must consist of only US-ASCII letters, numbers, and a fewspecial marks: ".", "+", "-".  This restriction effectively meansthat scheme have to be passed unescaped.  Passing an undefinedargument to the scheme method will make the URI relative (if possible).Letter case does not matter for scheme names.  The stringreturned by $uri->scheme is always lowercase.  If you want the schemejust 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 URIsupports the generic syntax for hierarchical namespaces.In that case the generic method is overridden to set and returnthe part of the URI between the I<host name> and the I<fragment>.=item $uri->fragment( [$new_frag] )