Mass Deface
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;
$abs->fragment($self->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