File Coverage

blib/lib/URI/Nested.pm

Criterion	Covered	Total	%
statement	62	77	80.5
branch	26	34	76.4
condition	5	9	55.5
subroutine	18	30	60.0
pod	7	22	31.8
total	118	172	68.6

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;
    $self->SUPER::can(@_) || (
        ref($self) ? $self->[1]->can(@_) : undef
    );
}

1;
__END__