init III
This commit is contained in:
257
Perl OTRS/Kernel/cpan-lib/URI/_generic.pm
Normal file
257
Perl OTRS/Kernel/cpan-lib/URI/_generic.pm
Normal file
@@ -0,0 +1,257 @@
|
||||
package URI::_generic;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use parent qw(URI URI::_query);
|
||||
|
||||
use URI::Escape qw(uri_unescape);
|
||||
use Carp ();
|
||||
|
||||
our $VERSION = '1.71';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g;
|
||||
my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
|
||||
|
||||
sub _no_scheme_ok { 1 }
|
||||
|
||||
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;
|
||||
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 <janl@ifi.uio.no>.
|
||||
# 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;
|
||||
Reference in New Issue
Block a user