File Coverage

blib/lib/URI/_generic.pm

Criterion	Covered	Total	%
statement	171	177	96.6
branch	89	106	83.9
condition	35	44	79.5
subroutine	15	15	100.0
pod	6	6	100.0
total	316	348	90.8

package URI::_generic;

use strict;
use warnings;

use parent qw(URI URI::_query);

use URI::Escape qw(uri_unescape);
use Carp ();

our $VERSION = '5.21';

my $ACHAR = URI::HAS_RESERVED_SQUARE_BRACKETS ? $URI::uric : $URI::uric4host;  $ACHAR =~ s,\\[/?],,g;
my $PCHAR = $URI::uric;                                                        $PCHAR =~ s,\\[?],,g;

sub _no_scheme_ok { 1 }

our $IPv6_re;

sub _looks_like_raw_ip6_address {
  my $addr = shift;

  if ( !$IPv6_re ) { #-- lazy / runs once / use Regexp::IPv6 if installed
    eval {
      require Regexp::IPv6;
      Regexp::IPv6->import( qw($IPv6_re) );
      1;
    }  ||  do { $IPv6_re = qr/[:0-9a-f]{3,}/; }; #-- fallback: unambitious guess
  }

  return 0 unless $addr;
  return 0 if $addr =~ tr/:/:/ < 2;  #-- fallback must not create false positive for IPv4:Port = 0:0
  return 1 if $addr =~ /^$IPv6_re$/i;
  return 0;
}


sub authority
{
    my $self = shift;
    $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;

    if (@_) {
	my $auth = shift;
	$$self = $1;
	my $rest = $3;
	if (defined $auth) {
	    $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
            if ( my ($user, $host) = $auth =~ /^(.*@)?([^@]+)$/ ) { #-- special escape userinfo part
              $user ||= '';
              $user =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
              $user =~ s/%40$/\@/; # recover final '@'
              $host = "[$host]" if _looks_like_raw_ip6_address( $host );
              $auth = $user . $host;
            }
	    utf8::downgrade($auth);
	    $$self .= "//$auth";
	}
	_check_path($rest, $$self);
	$$self .= $rest;
    }
    $2;
}

sub path
{
    my $self = shift;
    $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;

    if (@_) {
	$$self = $1;
	my $rest = $3;
	my $new_path = shift;
	$new_path = "" unless defined $new_path;
	$new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
	utf8::downgrade($new_path);
	_check_path($new_path, $$self);
	$$self .= $new_path . $rest;
    }
    $2;
}

sub path_query
{
    my $self = shift;
    $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;

    if (@_) {
	$$self = $1;
	my $rest = $3;
	my $new_path = shift;
	$new_path = "" unless defined $new_path;
	$new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
	utf8::downgrade($new_path);
	_check_path($new_path, $$self);
	$$self .= $new_path . $rest;
    }
    $2;
}

sub _check_path
{
    my($path, $pre) = @_;
    my $prefix;
    if ($pre =~ m,/,) {  # authority present
	$prefix = "/" if length($path) && $path !~ m,^[/?\#],;
    }
    else {
	if ($path =~ m,^//,) {
	    Carp::carp("Path starting with double slash is confusing")
		if $^W;
	}
	elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
	    Carp::carp("Path might look like scheme, './' prepended")
		if $^W;
	    $prefix = "./";
	}
    }
    substr($_[0], 0, 0) = $prefix if defined $prefix;
}

sub path_segments
{
    my $self = shift;
    my $path = $self->path;
    if (@_) {
	my @arg = @_;  # make a copy
	for (@arg) {
	    if (ref($_)) {
		my @seg = @$_;
		$seg[0] =~ s/%/%25/g;
		for (@seg) { s/;/%3B/g; }
		$_ = join(";", @seg);
	    }
	    else {
		 s/%/%25/g; s/;/%3B/g;
	    }
	    s,/,%2F,g;
	}
	$self->path(join("/", @arg));
    }
    return $path unless wantarray;
    map {/;/ ? $self->_split_segment($_)
             : uri_unescape($_) }
        split('/', $path, -1);
}


sub _split_segment
{
    my $self = shift;
    require URI::_segment;
    URI::_segment->new(@_);
}


sub abs
{
    my $self = shift;
    my $base = shift || Carp::croak("Missing base argument");

    if (my $scheme = $self->scheme) {
	return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
	$base = URI->new($base) unless ref $base;
	return $self unless $scheme eq $base->scheme;
    }

    $base = URI->new($base) unless ref $base;
    my $abs = $self->clone;
    $abs->scheme($base->scheme);
    return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
    $abs->authority($base->authority);

    my $path = $self->path;
    return $abs if $path =~ m,^/,;

    if (!length($path)) {
	my $abs = $base->clone;
	my $query = $self->query;
	$abs->query($query) if defined $query;
	my $fragment = $self->fragment;
	$abs->fragment($fragment) if defined $fragment;
	return $abs;
    }

    my $p = $base->path;
    $p =~ s,[^/]+$,,;
    $p .= $path;
    my @p = split('/', $p, -1);
    shift(@p) if @p && !length($p[0]);
    my $i = 1;
    while ($i < @p) {
	#print "$i ", join("/", @p), " ($p[$i])\n";
	if ($p[$i-1] eq ".") {
	    splice(@p, $i-1, 1);
	    $i-- if $i > 1;
	}
	elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
	    splice(@p, $i-1, 2);
	    if ($i > 1) {
		$i--;
		push(@p, "") if $i == @p;
	    }
	}
	else {
	    $i++;
	}
    }
    $p[-1] = "" if @p && $p[-1] eq ".";  # trailing "/."
    if ($URI::ABS_REMOTE_LEADING_DOTS) {
        shift @p while @p && $p[0] =~ /^\.\.?$/;
    }
    $abs->path("/" . join("/", @p));
    $abs;
}

# The opposite of $url->abs.  Return a URI which is as relative as possible
sub rel {
    my $self = shift;
    my $base = shift || Carp::croak("Missing base argument");
    my $rel = $self->clone;
    $base = URI->new($base) unless ref $base;

    #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
    my $scheme = $rel->scheme;
    my $auth   = $rel->canonical->authority;
    my $path   = $rel->path;

    if (!defined($scheme) && !defined($auth)) {
	# it is already relative
	return $rel;
    }

    #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
    my $bscheme = $base->scheme;
    my $bauth   = $base->canonical->authority;
    my $bpath   = $base->path;

    for ($bscheme, $bauth, $auth) {
	$_ = '' unless defined
    }

    unless ($scheme eq $bscheme && $auth eq $bauth) {
	# different location, can't make it relative
	return $rel;
    }

    for ($path, $bpath) {  $_ = "/$_" unless m,^/,; }

    # Make it relative by eliminating scheme and authority
    $rel->scheme(undef);
    $rel->authority(undef);

    # This loop is based on code from Nicolai Langfeldt .
    # First we calculate common initial path components length ($li).
    my $li = 1;
    while (1) {
	my $i = index($path, '/', $li);
	last if $i < 0 ||
                $i != index($bpath, '/', $li) ||
	        substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
	$li=$i+1;
    }
    # then we nuke it from both paths
    substr($path, 0,$li) = '';
    substr($bpath,0,$li) = '';

    if ($path eq $bpath &&
        defined($rel->fragment) &&
        !defined($rel->query)) {
        $rel->path("");
    }
    else {
        # Add one "../" for each path component left in the base path
        $path = ('../' x $bpath =~ tr|/|/|) . $path;
	$path = "./" if $path eq "";
        $rel->path($path);
    }

    $rel;
}

1;