home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / URI / _generic.pm < prev    next >
Text File  |  2006-11-29  |  6KB  |  250 lines
  1. package URI::_generic;
  2. require URI;
  3. require URI::_query;
  4. @ISA=qw(URI URI::_query);
  5.  
  6. use strict;
  7. use URI::Escape qw(uri_unescape);
  8. use Carp ();
  9.  
  10. my $ACHAR = $URI::uric;  $ACHAR =~ s,\\[/?],,g;
  11. my $PCHAR = $URI::uric;  $PCHAR =~ s,\\[?],,g;
  12.  
  13. sub _no_scheme_ok { 1 }
  14.  
  15. sub authority
  16. {
  17.     my $self = shift;
  18.     $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
  19.  
  20.     if (@_) {
  21.     my $auth = shift;
  22.     $$self = $1;
  23.     my $rest = $3;
  24.     if (defined $auth) {
  25.         $auth =~ s/([^$ACHAR])/$URI::Escape::escapes{$1}/go;
  26.         $$self .= "//$auth";
  27.     }
  28.     _check_path($rest, $$self);
  29.     $$self .= $rest;
  30.     }
  31.     $2;
  32. }
  33.  
  34. sub path
  35. {
  36.     my $self = shift;
  37.     $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
  38.  
  39.     if (@_) {
  40.     $$self = $1;
  41.     my $rest = $3;
  42.     my $new_path = shift;
  43.     $new_path = "" unless defined $new_path;
  44.     $new_path =~ s/([^$PCHAR])/$URI::Escape::escapes{$1}/go;
  45.     _check_path($new_path, $$self);
  46.     $$self .= $new_path . $rest;
  47.     }
  48.     $2;
  49. }
  50.  
  51. sub path_query
  52. {
  53.     my $self = shift;
  54.     $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
  55.  
  56.     if (@_) {
  57.     $$self = $1;
  58.     my $rest = $3;
  59.     my $new_path = shift;
  60.     $new_path = "" unless defined $new_path;
  61.     $new_path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
  62.     _check_path($new_path, $$self);
  63.     $$self .= $new_path . $rest;
  64.     }
  65.     $2;
  66. }
  67.  
  68. sub _check_path
  69. {
  70.     my($path, $pre) = @_;
  71.     my $prefix;
  72.     if ($pre =~ m,/,) {  # authority present
  73.     $prefix = "/" if length($path) && $path !~ m,^[/?\#],;
  74.     }
  75.     else {
  76.     if ($path =~ m,^//,) {
  77.         Carp::carp("Path starting with double slash is confusing")
  78.         if $^W;
  79.     }
  80.     elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
  81.         Carp::carp("Path might look like scheme, './' prepended")
  82.         if $^W;
  83.         $prefix = "./";
  84.     }
  85.     }
  86.     substr($_[0], 0, 0) = $prefix if defined $prefix;
  87. }
  88.  
  89. sub path_segments
  90. {
  91.     my $self = shift;
  92.     my $path = $self->path;
  93.     if (@_) {
  94.     my @arg = @_;  # make a copy
  95.     for (@arg) {
  96.         if (ref($_)) {
  97.         my @seg = @$_;
  98.         $seg[0] =~ s/%/%25/g;
  99.         for (@seg) { s/;/%3B/g; }
  100.         $_ = join(";", @seg);
  101.         }
  102.         else {
  103.          s/%/%25/g; s/;/%3B/g;
  104.         }
  105.         s,/,%2F,g;
  106.     }
  107.     $self->path(join("/", @arg));
  108.     }
  109.     return $path unless wantarray;
  110.     map {/;/ ? $self->_split_segment($_)
  111.              : uri_unescape($_) }
  112.         split('/', $path, -1);
  113. }
  114.  
  115.  
  116. sub _split_segment
  117. {
  118.     my $self = shift;
  119.     require URI::_segment;
  120.     URI::_segment->new(@_);
  121. }
  122.  
  123.  
  124. sub abs
  125. {
  126.     my $self = shift;
  127.     my $base = shift || Carp::croak("Missing base argument");
  128.  
  129.     if (my $scheme = $self->scheme) {
  130.     return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
  131.     $base = URI->new($base) unless ref $base;
  132.     return $self unless $scheme eq $base->scheme;
  133.     }
  134.  
  135.     $base = URI->new($base) unless ref $base;
  136.     my $abs = $self->clone;
  137.     $abs->scheme($base->scheme);
  138.     return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
  139.     $abs->authority($base->authority);
  140.  
  141.     my $path = $self->path;
  142.     return $abs if $path =~ m,^/,;
  143.  
  144.     if (!length($path)) {
  145.     my $abs = $base->clone;
  146.     my $query = $self->query;
  147.     $abs->query($query) if defined $query;
  148.     $abs->fragment($self->fragment);
  149.     return $abs;
  150.     }
  151.  
  152.     my $p = $base->path;
  153.     $p =~ s,[^/]+$,,;
  154.     $p .= $path;
  155.     my @p = split('/', $p, -1);
  156.     shift(@p) if @p && !length($p[0]);
  157.     my $i = 1;
  158.     while ($i < @p) {
  159.     #print "$i ", join("/", @p), " ($p[$i])\n";
  160.     if ($p[$i-1] eq ".") {
  161.         splice(@p, $i-1, 1);
  162.         $i-- if $i > 1;
  163.     }
  164.     elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
  165.         splice(@p, $i-1, 2);
  166.         if ($i > 1) {
  167.         $i--;
  168.         push(@p, "") if $i == @p;
  169.         }
  170.     }
  171.     else {
  172.         $i++;
  173.     }
  174.     }
  175.     $p[-1] = "" if @p && $p[-1] eq ".";  # trailing "/."
  176.     if ($URI::ABS_REMOTE_LEADING_DOTS) {
  177.         shift @p while @p && $p[0] =~ /^\.\.?$/;
  178.     }
  179.     $abs->path("/" . join("/", @p));
  180.     $abs;
  181. }
  182.  
  183. # The oposite of $url->abs.  Return a URI which is as relative as possible
  184. sub rel {
  185.     my $self = shift;
  186.     my $base = shift || Carp::croak("Missing base argument");
  187.     my $rel = $self->clone;
  188.     $base = URI->new($base) unless ref $base;
  189.  
  190.     #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
  191.     my $scheme = $rel->scheme;
  192.     my $auth   = $rel->canonical->authority;
  193.     my $path   = $rel->path;
  194.  
  195.     if (!defined($scheme) && !defined($auth)) {
  196.     # it is already relative
  197.     return $rel;
  198.     }
  199.  
  200.     #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
  201.     my $bscheme = $base->scheme;
  202.     my $bauth   = $base->canonical->authority;
  203.     my $bpath   = $base->path;
  204.  
  205.     for ($bscheme, $bauth, $auth) {
  206.     $_ = '' unless defined
  207.     }
  208.  
  209.     unless ($scheme eq $bscheme && $auth eq $bauth) {
  210.     # different location, can't make it relative
  211.     return $rel;
  212.     }
  213.  
  214.     for ($path, $bpath) {  $_ = "/$_" unless m,^/,; }
  215.  
  216.     # Make it relative by eliminating scheme and authority
  217.     $rel->scheme(undef);
  218.     $rel->authority(undef);
  219.  
  220.     # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
  221.     # First we calculate common initial path components length ($li).
  222.     my $li = 1;
  223.     while (1) {
  224.     my $i = index($path, '/', $li);
  225.     last if $i < 0 ||
  226.                 $i != index($bpath, '/', $li) ||
  227.             substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
  228.     $li=$i+1;
  229.     }
  230.     # then we nuke it from both paths
  231.     substr($path, 0,$li) = '';
  232.     substr($bpath,0,$li) = '';
  233.  
  234.     if ($path eq $bpath &&
  235.         defined($rel->fragment) &&
  236.         !defined($rel->query)) {
  237.         $rel->path("");
  238.     }
  239.     else {
  240.         # Add one "../" for each path component left in the base path
  241.         $path = ('../' x $bpath =~ tr|/|/|) . $path;
  242.     $path = "./" if $path eq "";
  243.         $rel->path($path);
  244.     }
  245.  
  246.     $rel;
  247. }
  248.  
  249. 1;
  250.