"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/URI/_generic.pm" (10 Mar 2019, 5822 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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