home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / URI / URL / _generic.pm next >
Encoding:
Perl POD Document  |  1998-04-17  |  14.6 KB  |  512 lines
  1. #####################################################################
  2. #
  3. #       Internal pre-defined generic scheme support
  4. #
  5. # In this implementation all schemes are subclassed from
  6. # URI::URL::_generic. This turns out to have reasonable mileage.
  7. # See also draft-ietf-uri-relative-url-06.txt
  8.  
  9. package URI::URL::_generic;           # base support for generic-RL's
  10. require URI::URL;
  11. @ISA = qw(URI::URL);
  12.  
  13. use URI::Escape qw(uri_escape uri_unescape %escapes);
  14.  
  15.  
  16. sub new {                               # inherited by subclasses
  17.     my($class, $init, $base) = @_;
  18.     my $url = bless { }, $class;        # create empty object
  19.     $url->_parse($init);                # parse $init into components
  20.     $url->base($base) if $base;
  21.     $url;
  22. }
  23.  
  24.  
  25. # Generic-RL parser
  26. # See draft-ietf-uri-relative-url-06.txt Section 2
  27.  
  28. sub _parse {
  29.     my($self, $u, @comps) = @_;
  30.     return unless defined $u;
  31.  
  32.     # Deside which components to parse (scheme & path is manatory)
  33.     @comps = qw(netloc query params frag) unless (@comps);
  34.     my %parse = map {$_ => 1} @comps;
  35.  
  36.     # This parsing code is based on
  37.     #   draft-ietf-uri-relative-url-06.txt Section 2.4
  38.  
  39.     # 2.4.1
  40.     $self->{'frag'} = uri_unescape($1)
  41.       if $parse{'frag'} && $u =~ s/#(.*)$//;
  42.     # 2.4.2
  43.     $self->{'scheme'} = lc($1) if $u =~ s/^\s*([\w\+\.\-]+)://;
  44.     # 2.4.3
  45.     $self->netloc("$1")    # passing $1 directly fails if netloc is autoloaded
  46.       if $parse{'netloc'} && $u =~ s!^//([^/]*)!!;
  47.     # 2.4.4
  48.     $self->{'query'} = $1
  49.       if $parse{'query'} && $u =~ s/\?(.*)//;
  50.     # 2.4.5
  51.     $self->{'params'} = $1
  52.       if $parse{'params'} && $u =~ s/;(.*)//;
  53.  
  54.     # 2.4.6
  55.     #
  56.     # RFC 1738 says:
  57.     #
  58.     #     Note that the "/" between the host (or port) and the
  59.     #     url-path is NOT part of the url-path.
  60.     #
  61.     # however, RFC 1808, 2.4.6. says:
  62.     #
  63.     #    Even though the initial slash is not part of the URL path,
  64.     #    the parser must remember whether or not it was present so
  65.     #    that later processes can differentiate between relative
  66.     #    and absolute paths.  Often this is done by simply storing
  67.     #    he preceding slash along with the path.
  68.     #
  69.     # In version < 4.01 of URI::URL we used to strip the leading
  70.     # "/" when asked for $self->path().  This created problems for
  71.     # the consitency of the interface, so now we just consider the
  72.     # slash to be part of the path and we also make an empty path
  73.     # default to "/".
  74.  
  75.     # we don't test for $parse{path} becase it is mandatory
  76.     $self->{'path'} = $u;
  77. }
  78.  
  79.  
  80. # Generic-RL stringify
  81. #
  82. sub as_string
  83. {
  84.     my $self = shift;
  85.     return $self->{'_str'} if $self->{'_str'};
  86.  
  87.     my($scheme, $netloc, $frag) = @{$self}{qw(scheme netloc frag)};
  88.  
  89.     my $u = $self->full_path(1);  # path+params+query
  90.  
  91.     # rfc 1808 says:
  92.     #    Note that the fragment identifier (and the "#" that precedes
  93.     #    it) is not considered part of the URL.  However, since it is
  94.     #    commonly used within the same string context as a URL, a parser
  95.     #    must be able to recognize the fragment when it is present and
  96.     #    set it aside as part of the parsing process.
  97.     $u .= "#" . uri_escape($frag, $URI::URL::unsafe) if defined $frag;
  98.  
  99.     $u = "//$netloc$u" if defined $netloc;
  100.     $u = "$scheme:$u" if $scheme;
  101.     # Inline: uri_escape($u, $URI::URL::unsafe);
  102.     $u =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
  103.     $self->{'_str'} = $u;  # set cache and return
  104. }
  105.  
  106. # Generic-RL stringify full path "path;params?query"
  107. #
  108. sub full_path
  109. {
  110.     my($self, $dont_escape)  = @_;
  111.     my($path, $params, $query) = @{$self}{'path', 'params', 'query'};
  112.     my $p = '';
  113.     $p .= $path if defined $path;
  114.     # see comment in _parse 2.4.6 about the next line
  115.     $p = "/$p" if defined($self->{netloc}) && $p !~ m:^/:;
  116.     $p .= ";$params" if defined $params;
  117.     $p .= "?$query"  if defined $query;
  118.     return $p if $dont_escape;
  119.     # Inline: URI::Escape::uri_escape($p, $URI::URL::unsafe);
  120.     $p =~ s/([$URI::URL::unsafe])/$escapes{$1}/go;
  121.     $p;
  122. }
  123.  
  124. # default_port()
  125. #
  126. # subclasses will usually want to override this
  127. #
  128. sub default_port { undef; }
  129.  
  130.  
  131. #####################################################################
  132. #
  133. # Methods to handle URL's elements
  134.  
  135. # These methods always return the current value,
  136. # so you can use $url->path to read the current value.
  137. # If a new value is passed, e.g. $url->path('foo'),
  138. # it also sets the new value, and returns the previous value.
  139. # Use $url->path(undef) to set the value to undefined.
  140.  
  141. sub netloc {
  142.     my $self = shift;
  143.     my $old = $self->_elem('netloc', @_);
  144.     return $old unless @_;
  145.  
  146.     # update fields derived from netloc
  147.     my $nl = $self->{'netloc'} || '';
  148.     if ($nl =~ s/^([^:@]*):?(.*?)@//){
  149.     $self->{'user'}     = uri_unescape($1);
  150.     $self->{'password'} = uri_unescape($2) if $2 ne '';
  151.     }
  152.     if ($nl =~ /^([^:]*):?(\d*)$/){
  153.     my $port = $2;
  154.     # Since this happes so frequently, we inline this call:
  155.     #    my $host = uri_unescape($1);
  156.     my $host = $1;
  157.     $host =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg;
  158.     $self->{'host'} = $host;
  159.     if ($port ne '') {
  160.         $self->{'port'} = $port;
  161.         if ($self->default_port == $port) {
  162.         $self->{'netloc'} =~ s/:\d+//;
  163.         }
  164.     } elsif (defined $self->{'netloc'}) {
  165.         $self->{'netloc'} =~ s/:$//;  # handle empty port spec
  166.     }
  167.     }
  168.     $self->{'_str'} = '';
  169.     $old;
  170. }
  171.  
  172.  
  173. # A U T O  L O A D E R
  174. # Don't remove this comment, it keeps AutoSplit happy!!
  175. # @ISA = qw(AutoLoader)
  176. #
  177. # The rest of the methods are only loaded on demand.  Stubs are neccesary
  178. # for inheritance to work.
  179.  
  180. #sub netloc;  # because netloc is used by the _parse()
  181. sub user;
  182. sub password;
  183. sub host;
  184. sub port;
  185. sub _netloc_elem;
  186. sub epath;
  187. sub path;
  188. sub path_components;
  189. sub eparams;
  190. sub params;
  191. sub equery;
  192. sub query;
  193. sub frag;
  194. sub crack;
  195. sub abs;
  196. sub rel;
  197. sub eq;
  198.  
  199. # 1;
  200. # __END__
  201.  
  202.  
  203. # Fields derived from generic netloc:
  204. sub user     { shift->_netloc_elem('user',    @_); }
  205. sub password { shift->_netloc_elem('password',@_); }
  206. sub host     { shift->_netloc_elem('host',    @_); }
  207.  
  208. sub port {
  209.     my $self = shift;
  210.     my $old = $self->_netloc_elem('port', @_);
  211.     defined($old) ? $old : $self->default_port;
  212. }
  213.  
  214. sub _netloc_elem {
  215.     my($self, $elem, @val) = @_;
  216.     my $old = $self->_elem($elem, @val);
  217.     return $old unless @val;
  218.  
  219.     # update the 'netloc' element
  220.     my $nl = '';
  221.     my $host = $self->{'host'};
  222.     if (defined $host) {  # can't be any netloc without any host
  223.     my $user = $self->{'user'};
  224.     $nl .= uri_escape($user, $URI::URL::reserved) if defined $user;
  225.     $nl .= ":" . uri_escape($self->{'password'}, $URI::URL::reserved)
  226.       if defined($user) and defined($self->{'password'});
  227.     $nl .= '@' if length $nl;
  228.     $nl .= uri_escape($host, $URI::URL::reserved);
  229.     my $port = $self->{'port'};
  230.     $nl .= ":$port" if defined($port) && $port != $self->default_port;
  231.     }
  232.     $self->{'netloc'} = $nl;
  233.     $self->{'_str'} = '';
  234.     $old;
  235. }
  236.  
  237. sub epath {
  238.      my $self = shift;
  239.      my $old = $self->_elem('path', @_);
  240.      return '/' if !defined($old) || !length($old);
  241.      return "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  242.      $old;
  243. }
  244.  
  245. sub path {
  246.     my $self = shift;
  247.     my $old = $self->_elem('path',
  248.               map uri_escape($_, $URI::URL::reserved_no_slash), @_);
  249.     return unless defined wantarray;
  250.     return '/' if !defined($old) || !length($old);
  251.     Carp::croak("Path components contain '/' (you must call epath)")
  252.     if $old =~ /%2[fF]/ and !@_;
  253.     $old = "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  254.     return uri_unescape($old);
  255. }
  256.  
  257. sub path_components {
  258.     my $self = shift;
  259.     my $old = $self->{'path'};
  260.     $old = '' unless defined $old;
  261.     $old = "/$old" if $old !~ m|^/| && defined $self->{'netloc'};
  262.     if (@_) {
  263.     $self->_elem('path',
  264.              join("/", map { uri_escape($_,
  265.                         $URI::URL::reserved.".")
  266.                    } @_));
  267.     }
  268.     map { uri_unescape($_) } split("/", $old, -1);
  269. }
  270.  
  271. sub eparams  { shift->_elem('params',  @_); }
  272.  
  273. sub params {
  274.     my $self = shift;
  275.     my $old = $self->_elem('params', map {uri_escape($_,$URI::URL::reserved_no_form)} @_);
  276.     return uri_unescape($old) if defined $old;
  277.     undef;
  278. }
  279.  
  280. sub equery   { shift->_elem('query',   @_); }
  281.  
  282. sub query {
  283.     my $self = shift;
  284.     my $old = $self->_elem('query', map { uri_escape($_, $URI::URL::reserved_no_form) } @_);
  285.     if (defined(wantarray) && defined($old)) {
  286.     if ($old =~ /%(?:26|2[bB]|3[dD])/) {  # contains escaped '=' '&' or '+'
  287.         my $mess;
  288.         for ($old) {
  289.         $mess = "Query contains both '+' and '%2B'"
  290.           if /\+/ && /%2[bB]/;
  291.         $mess = "Form query contains escaped '=' or '&'"
  292.           if /=/  && /%(?:3[dD]|26)/;
  293.         }
  294.         if ($mess) {
  295.         Carp::croak("$mess (you must call equery)");
  296.         }
  297.     }
  298.     # Now it should be safe to unescape the string without loosing
  299.     # information
  300.     return uri_unescape($old);
  301.     }
  302.     undef;
  303.  
  304. }
  305.  
  306. # No efrag method because the fragment is always stored unescaped
  307. sub frag     { shift->_elem('frag', @_); }
  308.  
  309. sub crack
  310. {
  311.     my $self = shift;
  312.     return $self unless wantarray;
  313.     my @c = @{$self}{qw(scheme user password host port path params query frag)};
  314.     if (!$c[0]) {
  315.     # try to determine scheme
  316.     my $base = $self->base;
  317.     $c[0] = $base->scheme if $base;
  318.     $c[0] ||= 'http';  # last resort, default in URI::URL::new
  319.     }
  320.     $c[4] ||= $self->default_port;
  321.     @c;
  322. }
  323.  
  324. # Generic-RL: Resolving Relative URL into an Absolute URL
  325. #
  326. # Based on RFC1808 section 4
  327. #
  328. sub abs
  329. {
  330.     my($self, $base, $allow_scheme_in_relative_urls) = @_;
  331.     my $embed = $self->clone;
  332.  
  333.     $base = $self->base unless $base;      # default to default base
  334.     return $embed unless $base;            # we have no base (step1)
  335.  
  336.     $base = new URI::URL $base unless ref $base; # make obj if needed
  337.  
  338.     my($scheme, $host, $path, $params, $query, $frag) =
  339.     @{$embed}{qw(scheme host path params query frag)};
  340.  
  341.     # just use base if we are empty             (2a)
  342.     return $base->clone
  343.       unless grep(defined($_) && $_ ne '',
  344.           $scheme,$host,$port,$path,$params,$query,$frag);
  345.  
  346.     # if we have a scheme we must already be absolute   (2b),
  347.     #
  348.     # but sec. 5.2 also says: Some older parsers allow the scheme name
  349.     # to be present in a relative URL if it is the same as the base
  350.     # URL scheme.  This is considered to be a loophole in prior
  351.     # specifications of the partial URLs and should be avoided by
  352.     # future parsers.
  353.     #
  354.     # The old behavoir can be enabled by passing a TRUE value to the
  355.     # $allow_scheme_in_relative_urls parameter.
  356.     return $embed if $scheme &&
  357.       (!$allow_scheme_in_relative_urls || $scheme ne $base->{'scheme'});
  358.  
  359.     $embed->{'_str'} = '';                      # void cached string
  360.     $embed->{'scheme'} = $base->{'scheme'};     # (2c)
  361.  
  362.     return $embed if $embed->{'netloc'};        # (3)
  363.     $embed->netloc($base->{'netloc'});          # (3)
  364.  
  365.     return $embed if $path =~ m:^/:;            # (4)
  366.  
  367.     if ($path eq '') {                          # (5)
  368.     $embed->{'path'} = $base->{'path'};     # (5)
  369.  
  370.     return $embed if defined $embed->{'params'}; # (5a)
  371.     $embed->{'params'} = $base->{'params'};      # (5a)
  372.  
  373.     return $embed if defined $embed->{'query'};  # (5b)
  374.     $embed->{'query'} = $base->{'query'};        # (5b)
  375.  
  376.     return $embed;
  377.     }
  378.  
  379.     # (Step 6)  # draft 6 suggests stack based approach
  380.  
  381.     my $basepath = $base->{'path'};
  382.     my $relpath  = $embed->{'path'};
  383.  
  384.     $basepath =~ s!^/!!;
  385.     $basepath =~ s!/$!/.!;                # prevent empty segment
  386.     my @path = split('/', $basepath);     # base path into segments
  387.     pop(@path);                           # remove last segment
  388.  
  389.     $relpath =~ s!/$!/.!;                 # prevent empty segment
  390.  
  391.     push(@path, split('/', $relpath));    # append relative segments
  392.  
  393.     my @newpath = ();
  394.     my $isdir = 0;
  395.     my $segment;
  396.  
  397.     foreach $segment (@path) {            # left to right
  398.     if ($segment eq '.') {            # ignore "same" directory
  399.         $isdir = 1;
  400.     }
  401.     elsif ($segment eq '..') {
  402.         $isdir = 1;
  403.         my $last = pop(@newpath);
  404.         if (!defined $last) {         # nothing to pop
  405.         push(@newpath, $segment); # so must append
  406.         }
  407.         elsif ($last eq '..') {       # '..' cannot match '..'
  408.         # so put back again, and append
  409.         push(@newpath, $last, $segment);
  410.         }
  411.         #else
  412.         # it was a component,
  413.         # keep popped
  414.     } else {
  415.         $isdir = 0;
  416.         push(@newpath, $segment);
  417.     }
  418.     }
  419.  
  420.     $embed->{'path'} = '/' . join('/', @newpath) .
  421.     ($isdir && @newpath ? '/' : '');
  422.  
  423.     $embed;
  424. }
  425.  
  426. # The oposite of $url->abs.  Return a URL as much relative as possible
  427. sub rel {
  428.     my($self, $base) = @_;
  429.     my $rel = $self->clone;
  430.     $base = $self->base unless $base;
  431.     return $rel unless $base;
  432.     $base = new URI::URL $base unless ref $base;
  433.     $rel->base($base);
  434.  
  435.     my($scheme, $netloc, $path) = @{$rel}{qw(scheme netloc path)};
  436.     if (!defined($scheme) && !defined($netloc)) {
  437.     # it is already relative
  438.     return $rel;
  439.     }
  440.     $path = "/" if $path eq '';
  441.     
  442.     my($bscheme, $bnetloc, $bpath) = @{$base}{qw(scheme netloc path)};
  443.     for ($bscheme, $bnetloc, $netloc) { $_ = '' unless defined }
  444.  
  445.     unless ($scheme eq $bscheme && $netloc eq $bnetloc) {
  446.     # different location, can't make it relative
  447.     return $rel;
  448.     }
  449.     $bpath = "/" if $bpath eq '';
  450.  
  451.     # Make it relative by eliminating scheme and netloc
  452.     $rel->{'scheme'} = undef;
  453.     $rel->netloc(undef);
  454.  
  455.     # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
  456.     # First we calculate common initial path components length ($li).
  457.     my $li = 1;
  458.     while (1) {
  459.     my $i = index($path, '/', $li);
  460.     last if $i < 0 ||
  461.                 $i != index($bpath, '/', $li) ||
  462.             substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
  463.     $li=$i+1;
  464.     }
  465.     # then we nuke it from both paths
  466.     substr($path, 0,$li) = '';
  467.     substr($bpath,0,$li) = '';
  468.  
  469.     if ($path eq $bpath && defined($rel->frag) && !defined($rel->equery)) {
  470.         $rel->epath('');
  471.     } else {
  472.         # Add one "../" for each path component left in the base path
  473.         $path = ('../' x $bpath =~ tr|/|/|) . $path;
  474.     $path = "./" if $path eq "";
  475.         $rel->epath($path);
  476.     }
  477.  
  478.     $rel;
  479. }
  480.  
  481.  
  482. # Compare two URLs
  483. sub eq {
  484.     my($self, $other) = @_;
  485.     local($^W) = 0; # avoid warnings if we compare undef values
  486.     $other = URI::URL->new($other, $self) unless ref $other;
  487.  
  488.     # Compare scheme and netloc
  489.     return 0 if ref($self) ne ref($other);                # must be same class
  490.     return 0 if $self->scheme ne $other->scheme;          # Always lower case
  491.     return 0 if lc($self->netloc) ne lc($other->netloc);  # Case-insensitive
  492.  
  493.     # Compare full_path:
  494.     # According to <draft-ietf-http-v11-spec-05>:
  495.     # Characters other than those in the "reserved" and "unsafe" sets
  496.     # are equivalent to their %XX encodings.
  497.     my $fp1 = $self->full_path;
  498.     my $fp2 = $other->full_path;
  499.     for ($fp1, $fp2) {
  500.     s,%([\dA-Fa-f]{2}),
  501.       my $x = $1;
  502.       my $c = chr(hex($x));
  503.       $c =~ /^[;\/?:\@&=+\"\#%<>\0-\040\177]/ ? "%\L$x" : $c;
  504.     ,eg;
  505.     }
  506.     return 0 if $fp1 ne $fp2;
  507.     return 0 if $self->frag ne $other->frag;
  508.     1;
  509. }
  510.  
  511. 1;
  512.