_generic.pm

ARM上的如果你对底层感兴趣

#####################################################################
#
#       Internal pre-defined generic scheme support
#
# In this implementation all schemes are subclassed from
# URI::URL::_generic. This turns out to have reasonable mileage.
# See also draft-ietf-uri-relative-url-06.txt

package URI::URL::_generic;           # base support for generic-RL's
require URI::URL;
@ISA = qw(URI::URL);

use URI::Escape qw(uri_escape uri_unescape %escapes);


sub new {                               # inherited by subclasses
    my($class, $init, $base) = @_;
    my $url = bless { }, $class;        # create empty object
    $url->_parse($init);                # parse $init into components
    $url->base($base) if $base;
    $url;
}


# Generic-RL parser
# See draft-ietf-uri-relative-url-06.txt Section 2

sub _parse {
    my($self, $u, @comps) = @_;
    return unless defined $u;

    # Deside which components to parse (scheme & path is manatory)
    @comps = qw(netloc query params frag) unless (@comps);
    my %parse = map {$_ => 1} @comps;

    # This parsing code is based on
    #   draft-ietf-uri-relative-url-06.txt Section 2.4

    # 2.4.1
    $self->{'frag'} = uri_unescape($1)
      if $parse{'frag'} && $u =~ s/#(.*)$//;
    # 2.4.2
    $self->{'scheme'} = lc($1) if $u =~ s/^\s*([\w\+\.\-]+)://;
    # 2.4.3
    $self->netloc("$1")	# passing $1 directly fails if netloc is autoloaded
      if $parse{'netloc'} && $u =~ s!^//([^/]*)!!;
    # 2.4.4
    $self->{'query'} = $1
      if $parse{'query'} && $u =~ s/\?(.*)//;
    # 2.4.5
    $self->{'params'} = $1
      if $parse{'params'} && $u =~ s/;(.*)//;

    # 2.4.6
    #
    # RFC 1738 says:
    #
    #     Note that the "/" between the host (or port) and the
    #     url-path is NOT part of the url-path.
    #
    # however, RFC 1808, 2.4.6. says:
    #
    #    Even though the initial slash is not part of the URL path,
    #    the parser must remember whether or not it was present so
    #    that later processes can differentiate between relative
    #    and absolute paths.  Often this is done by simply storing
    #    he preceding slash along with the path.
    #
    # In version < 4.01 of URI::URL we used to strip the leading
    # "/" when asked for $self->path().  This created problems for
    # the consitency of the interface, so now we just consider the
    # slash to be part of the path and we also make an empty path
    # default to "/".

    # we don't test for $parse{path} becase it is mandatory
    $self->{'path'} = $u;
}


# Generic-RL stringify
#
sub as_string
{
    my $self = shift;
    return $self->{'_str'} if $self->{'_str'};

    my($scheme, $netloc, $frag) = @{$self}{qw(scheme netloc frag)};

    my $u = $self->full_path(1);  # path+params+query

    # rfc 1808 says:
    #    Note that the fragment identifier (and the "#" that precedes
    #    it) is not considered part of the URL.  However, since it is
    #    commonly used within the same string context as a URL, a parser
    #    must be able to recognize the fragment when it is present and
    #    set it aside as part of the parsing process.
    $u .= "#" . uri_escape($frag, $URI::URL::unsafe) if defined $frag;

    $u = "//$netloc$u" if defined $netloc;
    $u = "$scheme:$u" if $scheme;
    # Inline: uri_escape($u, $URI::URL::unsafe);
    $u =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
    $self->{'_str'} = $u;  # set cache and return
}

# Generic-RL stringify full path "path;params?query"
#
sub full_path
{
    my($self, $dont_escape)  = @_;
    my($path, $params, $query) = @{$self}{'path', 'params', 'query'};
    my $p = '';
    $p .= $path if defined $path;
    # see comment in _parse 2.4.6 about the next line
    $p = "/$p" if defined($self->{netloc}) && $p !~ m:^/:;
    $p .= ";$params" if defined $params;
    $p .= "?$query"  if defined $query;
    return $p if $dont_escape;
    # Inline: URI::Escape::uri_escape($p, $URI::URL::unsafe);
    $p =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
    $p;
}

# default_port()
#
# subclasses will usually want to override this
#
sub default_port { undef; }


#####################################################################
#
# Methods to handle URL's elements

# These methods always return the current value,
# so you can use $url->path to read the current value.
# If a new value is passed, e.g. $url->path('foo'),
# it also sets the new value, and returns the previous value.
# Use $url->path(undef) to set the value to undefined.

sub netloc {
    my $self = shift;
    my $old = $self->_elem('netloc', @_);
    return $old unless @_;

    # update fields derived from netloc
    my $nl = $self->{'netloc'} || '';
    if ($nl =~ s/^([^:@]*):?(.*?)@//){
	$self->{'user'}     = uri_unescape($1);
	$self->{'password'} = uri_unescape($2) if $2 ne '';
    }
    if ($nl =~ /^([^:]*):?(\d*)$/){
	my $port = $2;
	# Since this happes so frequently, we inline this call:
	#    my $host = uri_unescape($1);
	my $host = $1;
	$host =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg;
	$self->{'host'} = $host;
	if ($port ne '') {
	    $self->{'port'} = $port;
	    if ($self->default_port == $port) {
		$self->{'netloc'} =~ s/:\d+//;
	    }
	} elsif (defined $self->{'netloc'}) {
	    $self->{'netloc'} =~ s/:$//;  # handle empty port spec
	}
    }
    $self->{'_str'} = '';
    $old;
}


# A U T O  L O A D E R
# Don't remove this comment, it keeps AutoSplit happy!!
# @ISA = qw(AutoLoader)
#
# The rest of the methods are only loaded on demand.  Stubs are neccesary
# for inheritance to work.

#sub netloc;  # because netloc is used by the _parse()
sub user;
sub password;
sub host;
sub port;
sub _netloc_elem;
sub epath;
sub path;
sub path_components;
sub eparams;
sub params;
sub equery;
sub query;
sub frag;
sub crack;
sub abs;
sub rel;
sub eq;

1;
__END__


# Fields derived from generic netloc:
sub user     { shift->_netloc_elem('user',    @_); }
sub password { shift->_netloc_elem('password',@_); }
sub host     { shift->_netloc_elem('host',    @_); }

sub port {
    my $self = shift;
    my $old = $self->_netloc_elem('port', @_);
    defined($old) ? $old : $self->default_port;
}

sub _netloc_elem {
    my($self, $elem, @val) = @_;
    my $old = $self->_elem($elem, @val);
    return $old unless @val;

    # update the 'netloc' element
    my $nl = '';
    my $host = $self->{'host'};
    if (defined $host) {  # can't be any netloc without any host
	my $user = $self->{'user'};
	$nl .= uri_escape($user, $URI::URL::reserved) if defined $user;
	$nl .= ":" . uri_escape($self->{'password'}, $URI::URL::reserved)
	  if defined($user) and defined($self->{'password'});
	$nl .= '@' if length $nl;
	$nl .= uri_escape($host, $URI::URL::reserved);
	my $port = $self->{'port'};
	$nl .= ":$port" if defined($port) && $port != $self->default_port;
    }
    $self->{'netloc'} = $nl;
    $self->{'_str'} = '';
    $old;
}

sub epath {
     my $self = shift;
     my $old = $self->_elem('path', @_);
     return '/' if !defined($old) || !length($old);
     return "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
     $old;
}

sub path {
    my $self = shift;
    my $old = $self->_elem('path',
		      map uri_escape($_, $URI::URL::reserved_no_slash), @_);
    return unless defined wantarray;
    return '/' if !defined($old) || !length($old);
    Carp::croak("Path components contain '/' (you must call epath)")
	if $old =~ /%2[fF]/ and !@_;
    $old = "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
    return uri_unescape($old);
}

sub path_components {
    my $self = shift;