home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / auto / URI / URL / _generic / abs.al < prev    next >
Text File  |  1997-11-28  |  3KB  |  107 lines
  1. # NOTE: Derived from ./blib/lib/URI/URL/_generic.pm.  Changes made here will be lost.
  2. package URI::URL::_generic;
  3.  
  4. # Generic-RL: Resolving Relative URL into an Absolute URL
  5. #
  6. # Based on RFC1808 section 4
  7. #
  8. sub abs
  9. {
  10.     my($self, $base, $allow_scheme_in_relative_urls) = @_;
  11.     my $embed = $self->clone;
  12.  
  13.     $base = $self->base unless $base;      # default to default base
  14.     return $embed unless $base;            # we have no base (step1)
  15.  
  16.     $base = new URI::URL $base unless ref $base; # make obj if needed
  17.  
  18.     my($scheme, $host, $path, $params, $query, $frag) =
  19.     @{$embed}{qw(scheme host path params query frag)};
  20.  
  21.     # just use base if we are empty             (2a)
  22.     return $base->clone
  23.       unless grep(defined($_) && $_ ne '',
  24.           $scheme,$host,$port,$path,$params,$query,$frag);
  25.  
  26.     # if we have a scheme we must already be absolute   (2b),
  27.     #
  28.     # but sec. 5.2 also says: Some older parsers allow the scheme name
  29.     # to be present in a relative URL if it is the same as the base
  30.     # URL scheme.  This is considered to be a loophole in prior
  31.     # specifications of the partial URLs and should be avoided by
  32.     # future parsers.
  33.     #
  34.     # The old behavoir can be enabled by passing a TRUE value to the
  35.     # $allow_scheme_in_relative_urls parameter.
  36.     return $embed if $scheme &&
  37.       (!$allow_scheme_in_relative_urls || $scheme ne $base->{'scheme'});
  38.  
  39.     $embed->{'_str'} = '';                      # void cached string
  40.     $embed->{'scheme'} = $base->{'scheme'};     # (2c)
  41.  
  42.     return $embed if $embed->{'netloc'};        # (3)
  43.     $embed->netloc($base->{'netloc'});          # (3)
  44.  
  45.     return $embed if $path =~ m:^/:;            # (4)
  46.  
  47.     if ($path eq '') {                          # (5)
  48.     $embed->{'path'} = $base->{'path'};     # (5)
  49.  
  50.     return $embed if defined $embed->{'params'}; # (5a)
  51.     $embed->{'params'} = $base->{'params'};      # (5a)
  52.  
  53.     return $embed if defined $embed->{'query'};  # (5b)
  54.     $embed->{'query'} = $base->{'query'};        # (5b)
  55.  
  56.     return $embed;
  57.     }
  58.  
  59.     # (Step 6)  # draft 6 suggests stack based approach
  60.  
  61.     my $basepath = $base->{'path'};
  62.     my $relpath  = $embed->{'path'};
  63.  
  64.     $basepath =~ s!^/!!;
  65.     $basepath =~ s!/$!/.!;                # prevent empty segment
  66.     my @path = split('/', $basepath);     # base path into segments
  67.     pop(@path);                           # remove last segment
  68.  
  69.     $relpath =~ s!/$!/.!;                 # prevent empty segment
  70.  
  71.     push(@path, split('/', $relpath));    # append relative segments
  72.  
  73.     my @newpath = ();
  74.     my $isdir = 0;
  75.     my $segment;
  76.  
  77.     foreach $segment (@path) {            # left to right
  78.     if ($segment eq '.') {            # ignore "same" directory
  79.         $isdir = 1;
  80.     }
  81.     elsif ($segment eq '..') {
  82.         $isdir = 1;
  83.         my $last = pop(@newpath);
  84.         if (!defined $last) {         # nothing to pop
  85.         push(@newpath, $segment); # so must append
  86.         }
  87.         elsif ($last eq '..') {       # '..' cannot match '..'
  88.         # so put back again, and append
  89.         push(@newpath, $last, $segment);
  90.         }
  91.         #else
  92.         # it was a component,
  93.         # keep popped
  94.     } else {
  95.         $isdir = 0;
  96.         push(@newpath, $segment);
  97.     }
  98.     }
  99.  
  100.     $embed->{'path'} = '/' . join('/', @newpath) .
  101.     ($isdir && @newpath ? '/' : '');
  102.  
  103.     $embed;
  104. }
  105.  
  106. 1;
  107.