File Coverage

blib/lib/POEx/URI.pm

Criterion	Covered	Total	%
statement	208	229	90.8
branch	110	144	76.3
condition	28	48	58.3
subroutine	25	26	96.1
pod	14	14	100.0
total	385	461	83.5

package POEx::URI;

use strict;
use warnings;

use URI::Escape qw(uri_unescape);
use URI::_server;
use Carp;

use vars qw( @ISA $VERSION );
@ISA = qw(URI::_server);
$VERSION = '0.0301';

use overload '@{}' => \&as_array,
    fallback => 1;

##############################################
sub _init
{
    my( $class, $str, $scheme ) = @_;

    if( $str =~ m,^poe://[^/]+/[^/]+$, ) {
        $str .= '/';
    }
    $str = "$scheme:$str" unless $str =~ /^\Q$scheme:/;

    return $class->SUPER::_init($str, $scheme);
}

##############################################
sub default_port { 603 }

##############################################
sub kernel
{
    my $self = shift;
    my $old = $self->authority;
    if( @_ ) {
        my $tmp = $old;
        $tmp = "" unless defined $old;
        my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
        my $new = shift;
        $new = "" unless defined $new;
        if (length $new) {
            $new =~ s/[@]/%40/g;   # protect @
        }
        if( $ui or length $new ) {
            $self->authority( "$ui$new" );
        }
        else {
            $self->authority( undef );
        }
    }
    return undef unless defined $old;
    $old =~ s/.*@//;
    return uri_unescape($old);
}


##############################################
sub path
{
    my $self = shift;
    my $old = $self->SUPER::path;
    if( @_ ) {
        my $new = shift;
        if( $new =~ m,(.+)/(.+), ) {

            my $session = $1;
            my $event = $2;
            $session =~ s,^/+,,;
            $session =~ s,/,%2F,g;
            $new = join '/', $session, $event;
        }
        $self->SUPER::path( $new );
    }
    return $old;
}

##############################################
sub path_segments
{
    my $self = shift;

    my @seg = $self->SUPER::path_segments;
    if( @_ ) {
        my @new = @_;
        shift @new if $new[0] eq '';
        if( 2 <= @new ) {
            my $event = pop @new;
            @new = ( join( '/', @new ), $event );
        }
        $self->SUPER::path_segments( @new );
    }
    return @seg;
}

##############################################
sub session
{
    my $self = shift;
    my @seg = $self->path_segments;
    shift @seg if defined $seg[0] and $seg[0] eq '';
    my $event;
    if( 1==@seg ) {     # only an event?
        $event = $seg[0];
        @seg = ();
    }
    if( @seg >= 2 ) {   # session + event
        $event = pop @seg;
    }
    my $old = join '/', @seg[0..$#seg];

    if( @_ ) {
        my $new = shift;
        $new = '' unless defined $new;
        $self->path_segments( $new, (defined $event ? $event : '' ) );
    }

    return $old;
}

##############################################
sub event
{
    my $self = shift;
    my $old = ( $self->path_segments )[-1];
    $old = '' unless defined $old;
    if( @_ ) {
        my @seg = $self->path_segments;
        my $new = shift;
        if( @seg >= 2 ) {           # session/event
            $seg[-1] = $new||'';
        }
        elsif( @seg ) {             # session
            push @seg, $new||'';
        }
        else {                      # nothing
            if( $self->kernel and defined $new ) {
                carp "It makes no sense to set an event without a session";
            }
            @seg = ('', $new||'');
        }

        $self->path_segments( @seg );
    }
    return $old;
}

##############################################
sub _user
{
    my $self = shift;
    my $old = $self->userinfo;
    $old =~ s/:.*$//;
    return $old;
}
sub user
{
    my $self = shift;
    my $old = $self->userinfo;
    $old =~ s/:.*$//;

    if( @_ ) {
        my $pw = $self->_password;
        my $new = shift;
        my $ui = $new;
        if( defined $new ) {
            $new =~ s/:/%3A/g;
            $ui = $new;
            $ui .= ":$pw" if( defined $pw );
        }
        elsif( defined $pw ) {
            $ui = ":$pw";
        }
        $self->userinfo( $ui );
    }

    $old =~ s/%3A/:/g if $old;
    return $old;
}

##############################################
sub _password
{
    my $self = shift;
    my $old = $self->userinfo;
    undef( $old ) unless $old =~ s/^.*?://;
    return $old;
}
sub password
{
    my $self = shift;
    my $old = $self->userinfo;
    undef( $old ) unless $old =~ s/^.*?://;

    if( @_ ) {
        my $user = $self->_user;
        $user = '' unless defined $user;
        my $new = shift;
        if( defined $new ) {
            $new =~ s/:/%3A/g;
            $self->userinfo( "$user:$new" );
        }
        else {
            $self->userinfo( $user );
        }
    }
    $old =~ s/%3A/:/g if $old;
    return $old;
}

##############################################
sub _is_inet
{
    my $kernel = shift;
    return unless $kernel;
    return 1 if $kernel =~ /:\d*$/;
    return 1 if $kernel =~ /^\[[:0-9a-f]+\]$/i;     # [IPv6]
    return 1 if $kernel =~ /^\d+\.\d+\.\d+\.\d+/;   # IPv4 dotted quad
    return 1 if $kernel =~ /^[-\w.]+$/ and $kernel =~ /[.]/;
}

sub canonical
{
    my( $self ) = @_;
    my $other = $self->URI::_generic::canonical();


    my $kernel = $self->kernel;
    if( _is_inet( $kernel ) ) {
        $other = $other->clone if $other == $self;
        $other->kernel( lc $kernel );
    }
    my $port = $other->_port;
    if( defined($port) && ($port eq "" || $port == $self->default_port) ) {
        $other = $other->clone if $other == $self;
        $other->port(undef);
    }

    if( $other =~ m(poe:/[^/]) ) {
        $other = $other->clone if $other == $self;
        $$other =~ s(poe:/)(poe:);
    }

    my @seg = $other->path_segments;
    if( 2 < @seg ) {
        $other = $other->clone if $other == $self;
        $other->path_segments( @seg );   # enforce 2 segments
    }

    return $other;
}

##############################################
sub fragment
{
    return if 1==@_;
    croak "->fragment() currently not supported";
}

##############################################
sub as_array
{
    my $self = shift;
    my $kid;
    $kid = $POE::Kernel::poe_kernel->ID
        if $POE::Kernel::poe_kernel and $POE::Kernel::poe_kernel->can('ID');
    my $kernel = $self->kernel;
    my $alias = $self->session;
    if( $kernel and ( not $kid or $kernel ne $kid ) ) {
        $alias = join '/', $self->scheme.':/', $kernel, $alias;
    }

    my @ret = ( $alias, $self->event, $self->argument );

    return \@ret unless wantarray;
    return @ret;
}

##############################################
sub argument
{
    my $self = shift;
    my $old = $self->_argument;
    if( @_ ) {
        if( 1==@_ ) {
            my $new = shift;
            unless( ref $new ) {
                $self->query( $new );
            }
            elsif( 'ARRAY' eq ref $new ) {
                $self->query_keywords( $new );
            }
            else {
                $self->query_form( $new );
            }
        }
        else {
            $self->query_form( @_ );
        }
    }
    return unless defined $old;
    return $old;
}

sub _argument
{
    my $self = shift;
    my $args;

    my $q = $self->query;
    return unless defined $q;

    if( $q =~ /=/ ) {
        return { map { s/\+/ /g; uri_unescape($_) }
                 map { /=/ ? split(/=/, $_, 2) : ($_ => '')}
                 split(/&/, $q)
               };
    }
    return [ map { uri_unescape($_) } split(/\+/, $q, -1) ];
}

##############################################
sub abs
{
    my $self = shift;
    my $base = shift || croak "Missing base argument";

    $base = URI->new($base) unless ref $base;
    $base = $base->canonical;
    my $abs = $self->clone;

    $abs->scheme( $base->scheme ) unless $abs->scheme;
    foreach my $part ( qw( event session authority ) ) {
        my $f = $abs->$part;
        next if defined $f and length $f;
        $f = $base->$part;
        next unless length $f;
        $abs->$part( $base->$part );
    }
    return $abs;
}

##############################################
sub rel
{
    my $self = shift;
    my $base = shift || croak "Missing base argument";

    my $rel = $self->clone;
    $base = URI->new($base) unless ref $base;

    my $scheme = $rel->scheme;
    my $auth   = $rel->canonical->authority;
    my $session = $rel->session;
    my $event  = $rel->event;

    if (!defined($scheme) && !defined($auth)) {
        # it is already relative
        return $rel;
    }

    my $bscheme = $base->scheme;
    my $bauth   = $base->canonical->authority;
    my $bsession = $base->session;
    my $bevent  = $base->event;

    for ($bscheme, $bauth, $auth) {
        $_ = '' unless defined
    }

    unless ($scheme eq $bscheme && $auth eq $bauth) {
        # different location, can't make it relative
        return $rel;
    }

    # Make it relative by eliminating scheme and authority
    $rel->scheme(undef);
    $rel->authority(undef);

    for ($session, $event, $bsession, $bevent) {
        $_ = '' unless defined
    }

    if( $bsession eq $session ) {
        $rel->session(undef);
    }
    if( $bevent eq $event ) {
        $rel->event(undef);
    }

    return $rel;
}

1;

__END__