URI-Nested
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/URI/Nested.pm view on Meta::CPAN
package URI::Nested;
use strict;
use 5.8.1;
our $VERSION = '0.10';
use overload '""' => 'as_string', fallback => 1;
sub prefix {
my $class = ref $_[0] || shift;
return (split /::/ => $class)[-1];
}
sub nested_class { undef }
sub new {
my ($class, $str, $base) = @_;
my $prefix = $class->prefix;
my $scheme;
if ($base) {
# Remove prefix and grab the scheme to use for the nested URI.
$base =~ s/^\Q$prefix://;
($scheme) = $base =~ /^($URI::scheme_re):/;
}
my $uri = URI->new($str, $base);
return $uri if $uri->isa(__PACKAGE__);
# Convert to a nested URI and assign the scheme, if needed.
$uri->scheme($scheme) if $scheme && !$uri->scheme;
if ( my $nested_class = $class->nested_class ) {
bless $uri => $nested_class unless $uri->isa($nested_class);
}
bless [ $prefix => $uri ] => $class;
}
sub new_abs {
my ($class, $uri, $base) = @_;
$uri = URI->new($uri);
# No change if already have a scheme.
return $uri if $uri->scheme;
$base = URI->new($base);
# Return non-nested absolute.
return $uri->abs($base) unless $base->isa(__PACKAGE__);
# Return nested absolute.
$uri = $uri->abs( $base->[1] ) if $base->[1];
$base->[1] = $uri;
return $base;
}
sub _init {
my ($class, $str, $scheme) = @_;
my $prefix = quotemeta $class->prefix;
if ($str =~ s/^($prefix)://i) {
$scheme = $1;
}
return $class->_nested_init($scheme, $str);
}
sub _nested_init {
my ($class, $scheme, $str) = @_;
my $uri = URI->new($str);
if ( my $nested_class = $class->nested_class ) {
bless $uri => $nested_class unless $uri->isa($nested_class);
}
bless [ $scheme, $uri ] => $class;
}
sub nested_uri { shift->[1] }
sub scheme {
my $self = shift;
return lc $self->[0] unless @_;
my $new = shift;
my $old = $self->[0];
# Cannot change $self from array ref to scalar ref, so reject other schemes.
Carp::croak('Cannot change ', ref $self, ' scheme' )
if lc $new ne $self->prefix;
$self->[0] = $new;
return $old;
}
sub as_string {
return join ':', @{ +shift };
}
sub clone {
my $self = shift;
bless [$self->[0], $self->[1]->clone], ref $self;
}
sub abs { shift }
sub rel { shift }
sub eq {
my ($self, $other) = @_;
$other = URI->new($other) unless ref $other;
return ref $self eq ref $other && $self->[1]->eq($other->[1]);
}
sub _init_implementor {}
# Hard-code common accessors and methods.
sub opaque { shift->[1]->opaque(@_) }
sub path { shift->[1]->path(@_) }
sub fragment { shift->[1]->fragment(@_) }
sub host { shift->[1]->host(@_) }
sub port { shift->[1]->port(@_) }
sub _port { shift->[1]->_port(@_) }
sub authority { shift->[1]->authority(@_) }
sub path_query { shift->[1]->path_query(@_) }
sub path_segments { shift->[1]->path_segments(@_) }
sub query { shift->[1]->query(@_) }
sub userinfo { shift->[1]->userinfo(@_) }
# Catch any missing methods.
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return if $method eq 'DESTROY';
$self->[1]->$method(@_);
}
sub can { # override UNIVERSAL::can
my $self = shift;
view all matches for this distributionview release on metacpan - search on metacpan
( run in 1.721 second using v1.00-cache-2.02-grep-82fe00e-cpan-48ebf85a1963 )