POEx::URI - URI extension for POE event specfiers

POEx-URI documentation Contained in the POEx-URI distribution.

Index

Code Index:

NAME

Top

POEx::URI - URI extension for POE event specfiers

SYNOPSIS

Top

    use URI;

    my $uri = URI->new( "$session/$event" );

    $poe_kernel->post( $uri->session, $uri->event, @args );
    $poe_kernel->post( @$uri, @args );

    $uri->host( $host );
    $uri->port( 33100 );
    $poe_kernel->post( IKC => $uri, @args );

DESCRIPTION

Top

This module implements the URIs that reference POE session/event tuples. Objects of this class represent non-standard "Uniform Resource Identifier references" of the poe: scheme.

The canonical forms of POE URIs are:

    poe:event
    poe:session/
    poe:session/event
    poe://kernel/session/
    poe://kernel/session/event

Events may also have parameters :

    poe:event?foo=bar
    poe:event?b+20+BINGO

See argument below.

URI fragements (the bits after #) make no sense.

Use

This module attempts to have no pre-conception on how the URIs would be used. Core POE has way of turning URIs into event invocations. However, you may use as_array to invoke the event referenced by a URI.

    $poe_kernel->post( @$uri );

The presence of a kernel name in the URI presuposes some form of inter-kernel communication. POE::Component::IKC doesn't currently support URIs, beyond the fact that a subscribed remote session will have a local thunk session with the alias of the form poe://kernel/session. So using as_array will be able to access it.

METHODS

Top

event

    my $name = $uri->event
    $old = $uri->event( $name );

Sets and returns the event part of the $uri. If the $name contains a forward-slash (/), it is escaped (%2F).

To clear the event name, use '' or undef, which are equivalent.

session

    my $name = $uri->session
    $old = $uri->session( $name );

Sets and returns the session part of the $uri. If the $name contains a forward-slash (/), it is escaped (%2F).

To clear the event name, use '' or undef, which are equivalent

kernel

    my $kernel = $uri->kernel;
    $old = $uri->kernel( $name );

Sets and returns the kernel part of the $uri. A kernel may be a dotted quad IPv4 address (127.0.0.1), an IPv6 address ([::1]) or a hostname (localhost.localdomain) followed by a port number. A kernel may also be kernel ID or alias.

The kernel only make sense when using IKC.

To clear the kernel name, use '' or undef, which are equivalent.

host

    $host = $uri->host;
    $old = $uri->host( $host );

Sets and returns the host part of the $uri's kernel. If the kernel wasn't host:port, then it is converted to that.

port

    $port = $uri->port;
    $old = $uri->port( $port );

Sets and retuns the port part of the $uri's kernel. If the kernel wasn't a host name, then it becomes one.

default_port

The default POE port is 603 which is POE upside-down and backwards. Almost.

argument

    $arg = $uri->argument
    $old = $uri->argument( $new_arg );
    $old = $uri->argument( %new_arg );
    $old = $uri->argument( \@new_arg );

Sets and returns the argument for this $uri. And argument may be a string, a hash (query_form in URI) or an arrayref (query_keywords in URI).

See as_array to see how the argument is passed to the event handler.

user

    $user = $uri->user;
    $old = $uri->user( $user );

Sets and returns the username part of the $uri's userinfo in URI. If the user name contains :, it is escaped.

A user only makes sense in IKC.

password

    $pw = $uri->password;
    $old = $uri->password( $passwd );

Sets and returns the password part of the $uri's userinfo in URI. If the password contains :, it is escaped.

The user name and password are seperated by :. This is might be a security issue. Beware.

While this method is called password, it works just as well with pass phrases.

A password only makes sense in IKC.

as_array

    $poe_kernel->post( @$uri, @args );
    $poe_kernel->post( $uri->as_array, @args );

Returns a URI object to a session/event tuple, suitable for posting or calling. POEx::URI objects are also converted to arrays automatically by overloading.

If a kernel name is present, and it is not the local kernel ID, then it is prepended to the session name. This is compatible with IKC after subscribing to the remote session.

If an argument is present, it is returned as the last item.

canonical

    my $full = $uri->canonical;

Returns a normalized version of the URI. For POE URIs, the hostname is folded to lower case.

path

    $path = $uri->path;
    $old = $uri->path( $new_path );

Sets and returns the session/event tupple of a $uri. If the new path contains more then one slash, the last segment of the path is the event, and the others are the session and those slash are escaped.

path_segments

    ( $session, $event ) = $uri->path_segments;
    @old = $uri->path_segments( @new );

Sets and returns the path. In a scalar context, it returns the same value as $uri->path. In a list context, it returns the unescaped path segments that make up the path. See path_segments in URI for more details.

SEE ALSO

Top

POE, URI, http://www.faqs.org/rfcs/rfc3986.html.

AUTHOR

Top

Philip Gwyn, <gwyn -at- cpan.org>

COPYRIGHT AND LICENSE

Top

Some of this code is based on URI and related subclasses was developed by Gisle Aas et al.

Copyright (C) 2009 by Philip Gwyn

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available.

POEx-URI documentation Contained in the POEx-URI distribution. 
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__