local-lib5/lib/perl5/URI/_generic.pm

   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::escape_char($1)/ego;
  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::escape_char($1)/ego;
  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::escape_char($1)/ego;
  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;