home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _5984fd0c97c32346cceeacb45fc56673 < prev    next >
Text File  |  2000-03-15  |  6KB  |  242 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.     } else {
  75.     if ($path =~ m,^//,) {
  76.         Carp::carp("Path starting with double slash is confusing")
  77.         if $^W;
  78.     } elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
  79.         Carp::carp("Path might look like scheme, './' prepended")
  80.         if $^W;
  81.         $prefix = "./";
  82.     }
  83.     }
  84.     substr($_[0], 0, 0) = $prefix if defined $prefix;
  85. }
  86.  
  87. sub path_segments
  88. {
  89.     my $self = shift;
  90.     my $path = $self->path;
  91.     if (@_) {
  92.     my @arg = @_;  # make a copy
  93.     for (@arg) {
  94.         if (ref($_)) {
  95.         my @seg = @$_;
  96.         $seg[0] =~ s/%/%25/g;
  97.         for (@seg) { s/;/%3B/g; }
  98.         $_ = join(";", @seg);
  99.         } else {
  100.          s/%/%25/g; s/;/%3B/g;
  101.         }
  102.         s,/,%2F,g;
  103.     }
  104.     $self->path(join("/", @arg));
  105.     }
  106.     return $path unless wantarray;
  107.     map {/;/ ? $self->_split_segment($_)
  108.              : uri_unescape($_) }
  109.         split('/', $path, -1);
  110. }
  111.  
  112.  
  113. sub _split_segment
  114. {
  115.     my $self = shift;
  116.     require URI::_segment;
  117.     URI::_segment->new(@_);
  118. }
  119.  
  120.  
  121. sub abs
  122. {
  123.     my $self = shift;
  124.     my $base = shift || Carp::croak("Missing base argument");
  125.  
  126.     if (my $scheme = $self->scheme) {
  127.     return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
  128.     $base = URI->new($base) unless ref $base;
  129.     return $self unless $scheme eq $base->scheme;
  130.     }
  131.  
  132.     $base = URI->new($base) unless ref $base;
  133.     my $abs = $self->clone;
  134.     $abs->scheme($base->scheme);
  135.     return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
  136.     $abs->authority($base->authority);
  137.  
  138.     my $path = $self->path;
  139.     return $abs if $path =~ m,^/,;
  140.  
  141.     if (!length($path) && !defined($self->query)) {
  142.     my $abs = $base->clone;
  143.     $abs->fragment($self->fragment);
  144.     return $abs;
  145.     }
  146.  
  147.     my $p = $base->path;
  148.     $p =~ s,[^/]+$,,;
  149.     $p .= $path;
  150.     my @p = split('/', $p, -1);
  151.     shift(@p) if @p && !length($p[0]);
  152.     my $i = 1;
  153.     while ($i < @p) {
  154.     #print "$i ", join("/", @p), " ($p[$i])\n";
  155.     if ($p[$i-1] eq ".") {
  156.         splice(@p, $i-1, 1);
  157.         $i-- if $i > 1;
  158.     } elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
  159.         splice(@p, $i-1, 2);
  160.         if ($i > 1) {
  161.         $i--;
  162.         push(@p, "") if $i == @p;
  163.         }
  164.     } else {
  165.         $i++;
  166.     }
  167.     }
  168.     $p[-1] = "" if @p && $p[-1] eq ".";  # trailing "/."
  169.     if ($URI::ABS_REMOTE_LEADING_DOTS) {
  170.         shift @p while @p && $p[0] =~ /^\.\.?$/;
  171.     }
  172.     $abs->path("/" . join("/", @p));
  173.     $abs;
  174. }
  175.  
  176. # The oposite of $url->abs.  Return a URI which is as relative as possible
  177. sub rel {
  178.     my $self = shift;
  179.     my $base = shift || Carp::croak("Missing base argument");
  180.     my $rel = $self->clone;
  181.     $base = URI->new($base) unless ref $base;
  182.  
  183.     #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
  184.     my $scheme = $rel->scheme;
  185.     my $auth   = $rel->authority;
  186.     my $path   = $rel->path;
  187.  
  188.     if (!defined($scheme) && !defined($auth)) {
  189.     # it is already relative
  190.     return $rel;
  191.     }
  192.  
  193.     #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
  194.     my $bscheme = $base->scheme;
  195.     my $bauth   = $base->authority;
  196.     my $bpath   = $base->path;
  197.  
  198.     for ($bscheme, $bauth, $auth) {
  199.     $_ = '' unless defined
  200.     }
  201.  
  202.     unless ($scheme eq $bscheme && $auth eq $bauth) {
  203.     # different location, can't make it relative
  204.     return $rel;
  205.     }
  206.  
  207.     for ($path, $bpath) {  $_ = "/$_" unless m,^/,; }
  208.  
  209.     # Make it relative by eliminating scheme and authority
  210.     $rel->scheme(undef);
  211.     $rel->authority(undef);
  212.  
  213.     # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
  214.     # First we calculate common initial path components length ($li).
  215.     my $li = 1;
  216.     while (1) {
  217.     my $i = index($path, '/', $li);
  218.     last if $i < 0 ||
  219.                 $i != index($bpath, '/', $li) ||
  220.             substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
  221.     $li=$i+1;
  222.     }
  223.     # then we nuke it from both paths
  224.     substr($path, 0,$li) = '';
  225.     substr($bpath,0,$li) = '';
  226.  
  227.     if ($path eq $bpath &&
  228.         defined($rel->fragment) &&
  229.         !defined($rel->query)) {
  230.         $rel->path("");
  231.     } else {
  232.         # Add one "../" for each path component left in the base path
  233.         $path = ('../' x $bpath =~ tr|/|/|) . $path;
  234.     $path = "./" if $path eq "";
  235.         $rel->path($path);
  236.     }
  237.  
  238.     $rel;
  239. }
  240.  
  241. 1;
  242.