File Coverage

blib/lib/URI/PathAbstract.pm

Criterion	Covered	Total	%
statement	93	99	93.9
branch	37	44	84.0
condition	6	10	60.0
subroutine	20	22	90.9
pod	7	7	100.0
total	163	182	89.5

package URI::PathAbstract;

use strict;
use warnings;

=head1 NAME

URI::PathAbstract - A URI-like object with Path::Abstract capabilities

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

    my $uri = URI::PathAbstract->new("http://example.com?a=b")

    $uri->down("apple")
    # http://example.com/apple?a=b

    $uri->query("c=d&e=f")
    # http://example.com/apple?c=d&e=f

    $uri->path("grape/blueberry/pineapple")
    # http://example.com/grape/blueberry/pineapple?c=d&e=f

    $uri = $uri->parent
    # http://example.com/grape/blueberry?c=d&e=f

    $uri = $uri->child("xyzzy")
    # http://example.com/grape/blueberry/xyzzy?c=d&e=f

=head1 DESCRIPTION

URI::PathAbstract is a combination of the L and L classes. It is essentially a URI
class that delegates path-handling methods to Path::Abstract

Unfortunately, this is not true:

    URI::PathAbstract->new( http://example.com )->isa( URI )

URI::PathAbstract supports the L generic and common methods

=cut

use URI;
use Path::Abstract;
use Scalar::Util qw/blessed/;
use Carp;

use overload
    '""' => sub { $_[0]->{uri}->as_string },
    '==' => sub { overload::StrVal($_[0]) eq overload::StrVal($_[1]) },
    fallback => 1,
;

=head1 METHODS

=head2 URI::PathAbstract->new( , ... )

Create a new URI::PathAbstract object based on

 should be of the L class or some sort of URI-like string

=head2 URI::PathAbstract->new( , path => , ... )

Create a new URI::PathAbstract object based on  but overriding the path with

    URI::PathAbstract->new("http://example.com/cherry?a=b", path => "grape/lemon")
    # http://example.com/grape/lemon?a=b"

=head2 URI::PathAbstract->new( , child => , ... )

Create a new URI::PathAbstract object based on  but modifying the path by

    URI::PathAbstract->new("http://example.com/cherry?a=b", child => "grape/lemon")
    # http://example.com/cherry/grape/lemon?a=b"

=head2 URI::PathAbstract->new( ... )

Create a new URI::PathAbstract object based on the following:

    uri         The URI you want to represent

    base        A base URI for use with ->abs and ->rel

    path        A path that will override the path of the given uri
                (although the scheme, host, ... will remain the same)

    child       A path that will be appended to the path of the given uri

=cut

sub new {
    my $self = bless {}, shift;

    my %given;
    if (@_ == 1 ) {
        $self->uri(shift);
    }
    elsif (@_ % 2) {
        $self->uri(shift);
        %given = @_;
    }
    elsif (@_) {
        %given = @_;
        $self->uri(delete $given{uri});
    }
    else {
        $self->uri(URI->new);
    }

    if (%given) {
        $self->path($given{path}) if defined $given{path};
        $self->down($given{child}) if defined $given{child};
        $self->base($given{base}) if defined $given{base};
    }

    return $self;
}

=head2 $uri->uri

Returns a L object that is a copy (not a reference) of the URI object inside $uri

=cut

sub uri {
    my $self = shift;
    if (@_) {
        my $uri = shift;
        $uri = URI->new($uri) unless blessed $uri;
        $self->_path($uri->path);
        $self->{uri} = $uri->clone;
    }
    return unless defined wantarray;
    return $self->{uri}->clone unless @_;
}

=head2 $uri->path

Returns a L object that is a copy (not a reference) of the Path::Abstract object inside $uri

=head2 $uri->path(  )

Sets the path of $uri, completely overwriting what was there before

The rest of $uri (host, port, scheme, query, ...) does not change

=cut

sub path {
    my $self = shift;
    if (@_) {
        my $path = $self->_path(@_);
        $self->{uri}->path($path->get);
    }
    return unless defined wantarray;
    return $self->{path}->clone;
}

sub _path {
    my $self = shift;
    my @path = @_;
    @path = @{ $path[0] } if ref $path[0] eq "ARRAY";
    my $path = Path::Abstract->new(@path);
    $self->{path} = $path;
}

=head2 $uri->clone

Returns a URI::PathAbstract that is an exact clone of $uri

=cut

sub clone {
    my $self = shift;
    my $class = ref $self;
    return $class->new($self->uri);
}

=head2 $uri->base

Returns a L object that is a copy (not a reference) of the base for $uri

Returns undef if $uri does not have a base uri

=head2 $uri->base(  )

Sets the base of $uri to

=cut

sub base {
    my $self = shift;
    if (@_) {
        my $base = shift;
        if (defined $base) {
            my $class = ref $self;
            $base = $base->abs if blessed $base && ($base->isa(__PACKAGE__) || $base->isa('URI::WithBase'));
            $base = $class->new(uri => "$base") unless $base->isa(__PACKAGE__);
        }
        $self->{base} = $base;
    }
    return unless defined wantarray;
    return undef unless defined $self->{base};
    return $self->{base}->clone;
}

=head2 $uri->abs

=head2 $uri->abs( [  ] )

Returns a L object that is the absolute URI formed by combining $uri and

If  is not given, then $uri->base is used as the base

If  is not given and $uri->base does not exist, then a clone of $uri is returned

See L and L for more C information

=cut

sub abs {
    my $self = shift;
    my $class = ref $self;
    my $base = shift || $self->base || return $self->clone;
    return $class->new(uri => $self->uri->abs("$base", @_), base => $base);
}

=head2 $uri->rel

=head2 $uri->rel( [  ] )

Returns a L object that is the relative URI formed by comparing $uri and

If  is not given, then $uri->base is used as the base

If  is not given and $uri->base does not exist, then a clone of $uri is returned

See L and L for more C information

=cut

sub rel {
    my $self = shift;
    my $class = ref $self;
    my $base = shift || $self->base || return $self->clone;
    return $class->new(uri => $self->uri->rel("$base", @_), base => $base);
}

{

=head2 URI

See L for more information

=head2 ->scheme

=head2 ->fragment

=head2 ->as_string

=head2 ->canonical

=head2 ->eq

=head2 ->authority

=head2 ->query

=head2 ->query_form

=head2 ->query_keywords

=head2 ->userinfo

=head2 ->host

=head2 ->port

=head2 ->host_port

=head2 ->default_port

=cut

    no strict 'refs';

    for my $method (grep { ! /^\s*#/ } split m/\n/, <<_END_) {
scheme
fragment
as_string
canonical
eq
authority
query
query_form
query_keywords
userinfo
host
port
host_port
default_port
_END_
        *$method = sub {
            my $self = shift;
            return $self->{uri}->$method(@_);
        }
    }

#=head2 abs

#Returns a L object

#=head2 rel

#Returns a L object

#=cut

=head2 ->opaque

=head2 ->path_query

=head2 ->path_segments

=head2 Path::Abstract

See L for more information

=head2 ->child

=head2 ->parent

=cut

    for my $method (grep { ! /^\s*#/ } split m/\n/, <<_END_) {
child
parent
_END_
        *$method = sub {
            my $self = shift;
            my $path = $self->{path}->$method(@_);
            my $clone = $self->clone;
            $clone->path($path);
            return $clone;
        }
    }

=head2 ->up

=head2 ->pop

=head2 ->down

=head2 ->push

=head2 ->to_tree

=head2 ->to_branch

=cut

    for my $method (grep { ! /^\s*#/ } split m/\n/, <<_END_) {
up
pop
down
push
to_tree
to_branch
#set
_END_
        *$method = sub {
            my $self = shift;
            my $path = $self->{path};
            my @result;
            if (wantarray) {
                my @result = $path->$method(@_);
            }
            else {
                $result[0] = $path->$method(@_);
            }
            $self->path($$path);
            return wantarray ? @result : $result[0];
        }
    }

=head2 ->list

=head2 ->first

=head2 ->last

=head2 ->is_empty

=head2 ->is_nil

=head2 ->is_root

=head2 ->is_tree

=head2 ->is_branch

=cut

    for my $method (grep { ! /^\s*#/ } split m/\n/, <<_END_) {
#get
list
first
last
is_empty
is_nil
is_root
is_tree
is_branch
_END_
        *$method = sub {
            my $self = shift;
            return $self->{path}->$method(@_);
        }
    }
}

=head1 SEE ALSO

L

L

L

L

L

=head1 AUTHOR

Robert Krimen, C<<  >>

=head1 SOURCE

You can contribute or fork this project via GitHub:

L

    git clone git://github.com/robertkrimen/uri-pathabstract.git URI-PathAbstract

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc URI::PathAbstract


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2008 Robert Krimen, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of URI::PathAbstract