File Coverage

blib/lib/POE/Session/Multiplex.pm

Criterion	Covered	Total	%
statement	167	182	91.7
branch	67	90	74.4
condition	11	18	61.1
subroutine	26	27	96.3
pod	13	15	86.6
total	284	332	85.5

package POE::Session::Multiplex;

use strict;
use warnings;

use Carp;
use POE;
use POE::Session;

use Scalar::Util qw( blessed );

require Exporter;

our @ISA = qw(Exporter POE::Session);
our %EXPORT_TAGS = ( 'all' => [ qw( ev evs rsvp evo evos ) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( ev evo evs rsvp );

our $VERSION = '0.0600';
our $CURRENTOBJ;

our $START;

#######################################
our $LAST_OFF;
BEGIN {
    *SE_NAMESPACE = \&POE::Session::SE_NAMESPACE;
    *SE_OPTIONS   = \&POE::Session::SE_OPTIONS;
    *SE_STATES    = \&POE::Session::SE_STATES;

    ## +1 and +2 used by PlainCall
    if( POE::Session->can( 'SE_ID' ) ) {
        # POE 1.300 +
        *SE_ID       = \&POE::Session::SE_ID;
        eval '
        *SE_OBJECTS  = sub () { POE::Session::SE_ID+3 };
        *SE_STATERE  = sub () { POE::Session::SE_ID+4 };
        *SE_ISAPLAIN = sub () { POE::Session::SE_ID+5 };
        ';
    }
    else {
        # POE 1.299-
        *SE_OBJECTS  = sub () { POE::Session::SE_STATES+3 };
        *SE_STATERE  = sub () { POE::Session::SE_STATES+4 };
        *SE_ISAPLAIN = sub () { POE::Session::SE_STATES+5 };
    }

    *EN_SIGNAL    = \&POE::Session::EN_SIGNAL;
    *EN_DEFAULT   = \&POE::Session::EN_DEFAULT;

    *OPT_TRACE    = \&POE::Session::OPT_TRACE;
    *OPT_DEBUG    = \&POE::Session::OPT_DEBUG;
    *OPT_DEFAULT  = \&POE::Session::OPT_DEFAULT;
}

sub OH_OBJECT () { 0 }
sub OH_NAME   () { 1 }
sub OH_OURS   () { 2 }

############################################################################
sub _loggable
{
    my( $self ) = @_;
    $POE::Kernel::poe_kernel->_data_alias_loggable( $_[0] );
}

sub create
{
    my $package = shift;

    if( $package->isa( 'POE::Session::PlainCall' ) ) {
        return $package->POE::Session::PlainCall::create( @_ );
    }
    else {
        return $package->SUPER::create( @_ );
    }
}

sub instantiate
{
    my $package = shift;
    my $self = $package->SUPER::instantiate( @_ );
    $self->__init;
    return $self;
}

sub __init
{
    my( $self ) = @_;
    if( $self->[SE_OBJECTS] ) {
        die "Definition of POE::Session changed!  $self needs to be modified.\n";
    }
    $self->[SE_OBJECTS] = {};
    $self->[SE_ISAPLAIN] = $self->isa( 'POE::Session::PlainCall' );
    if( $self->[SE_ISAPLAIN] ) {
        $self->POE::Session::PlainCall::__init;
    }
}

#######################################
sub _invoke_state
{
    my( $self, $source_session, $state, $etc, $file, $line, $fromstate ) = @_;

    $self->set_objectre unless $self->[SE_STATERE];

    if ($self->[SE_OPTIONS]->{+OPT_TRACE}) {
        POE::Kernel::_warn( $self->_loggable,
                            " -> $state (from $file at $line)\n"
                          );
    }

    if( $state =~ /^$self->[SE_STATERE]$/ ) {
        my $obj_name = $1;
        my $obj_state = $2;

        my( $object, $method ) = $self->handler_for( $obj_name, $obj_state, $state );
        if( $method ) {
            if ($self->[SE_OPTIONS]->{+OPT_TRACE}) {
                POE::Kernel::_warn( $self->_loggable,
                                    " OBJECT=$obj_name METHOD=$method\n"
                                  );
            }

            local $CURRENTOBJ = $obj_name;
            if( $self->[SE_ISAPLAIN] ) {
                local $POE::Session::PlainCall::POE_HOLDER  = bless [
                  ( $object,                        # object
                    $self,                          # session
                    $POE::Kernel::poe_kernel,       # kernel
                    $self->[SE_NAMESPACE],          # heap
                    $obj_state,                     # state
                    $source_session,                # sender
                    undef,                          # unused #6
                    $file,                          # caller file name
                    $line,                          # caller file line
                    $fromstate,                     # caller state
                    $method,                        # method
                    $etc,                           # args
                  ) ], 'POE::Session::PlainCall::Holder';
                return $object->$method( @$etc );
            }
            return $object->$method(
                    $self,                          # SESSION
                    $POE::Kernel::poe_kernel,       # KERNEL
                    $self->[SE_NAMESPACE],          # HEAP
                    $obj_state,                     # STATE
                    $source_session,                # SENDER
                    undef,                          # unused #6
                    $file,                          # CALLER_FILE
                    $line,                          # CALLER_LINE
                    $fromstate,                     # CALLER_STATE
                    @$etc,                          # ARG0, ARG1, ARG2
              );
        }
    }

    if ($self->[SE_OPTIONS]->{+OPT_TRACE}) {
                POE::Kernel::_warn( $self->_loggable,
                                " -> $state (not an multiplex state)\n"
                          );
    }

    ## Skip out if it's not our state
    if( $self->[SE_ISAPLAIN] ) {
        return shift->POE::Session::PlainCall::_invoke_state( @_ );
    }
    else {
        return shift->SUPER::_invoke_state( @_ );
    }
}


#######################################
sub evo ($$)
{
    my( $obj_name, $event ) = @_;
    return "$obj_name->$event";
}

#######################################
sub ev ($)
{
    my( $event ) = @_;
    croak "Can't call ev outside of a multiplexed object" unless $CURRENTOBJ;
    return evo $CURRENTOBJ, $event;
}

#######################################
sub evs ($)
{
    my( $event ) = @_;
    croak "Can't call evs outside of a multiplexed object" unless $CURRENTOBJ;
    my $self = $poe_kernel->get_active_session;
    croak "Can't call evs outside of a multiplexed session" unless $self;
    return $self->ID, ev$event;
}

#######################################
sub rsvp ($)
{
    return [ evs $_[0] ];
}

#######################################
sub evos ($$$)
{
    my( $session, $obj_name, $event ) = @_;
    $session = $session->ID if blessed $session;
    return $session, evo $obj_name, $event;
}


#######################################
sub set_objectre
{
    my( $self ) = @_;
    my $re = '(' . join( '|', map quotemeta, keys %{$self->[SE_OBJECTS]} ).
              ')->(.+)';
    $self->[SE_STATERE] = $re;
}

#######################################
# $obj_name  => name of object
# $obj_state => clean state name
# $state     => raw state name ($obj_name->$obj_state)
sub handler_for
{
    my( $self, $obj_name, $obj_state, $state ) = @_;

    my @ret = $self->_handler_for( $obj_name, $state );
    return @ret if @ret;

    return $self->_handler_for( $obj_name, $obj_state );
}

sub _handler_for
{
    my( $self, $obj_name, $state ) = @_;
    my $handler = $self->[SE_STATES]->{$state};
    return unless $handler;
    return if 'CODE' eq ref $handler;

    my $def = $self->[SE_OBJECTS]->{$obj_name};
    return unless $def;

    # Same object?
    if( blessed $handler->[0] and $handler->[0] eq $def->[OH_OBJECT] ) {
        return $def->[OH_OBJECT], $handler->[1];
    }
    # Object of the right package?
    elsif( $def->[OH_OBJECT]->isa( $handler->[0] ) ) {
        return $def->[OH_OBJECT], $handler->[1];
    }
    return;
}

#######################################
sub object
{
    my( $self, $obj_name, @def ) = @_;
    if( @def ) {
        if( blessed $obj_name ) {
            @def = ( $obj_name, @def );
            $obj_name = $self->_obj_name( $def[0] );
        }
        $self->object_register( name => $obj_name,
                                object => $def[0],
                                states => $def[1]
                              );
    }
    else {
        $self->object_unregister( $obj_name );
    }
}

sub _obj_name
{
    my( $package, $obj ) = @_;
    return "$obj" unless $obj->can( '__name' );
    my $name = $obj->__name;
    die ref( $obj ), "->__name must return the object's name" unless $name;
    return $name;
}


#######################################
sub object_get
{
    my( $self, $obj_name ) = @_;
    return unless exists $self->[SE_OBJECTS]->{ $obj_name };
    return $self->[SE_OBJECTS]->{ $obj_name }[OH_OBJECT];
}

#######################################
sub object_register
{
    my( $self, @def ) = @_;

    if( 1==@def ) {
        @def = ( object => $def[0] );
    }
    my %def = ( @def );

    my $object   = $def{object};
    croak "You must supply an object" unless $object;

    my $obj_name = $def{name} || $self->_obj_name( $object );
    croak "You may not include -> in an object name" if $obj_name =~ /->/;
    my $states   = $def{states} || $def{events};

    if( $self->[SE_OBJECTS]->{ $obj_name } ) {
        $self->object_unregister( $obj_name );
    }
    $self->[SE_STATERE] = '';

    my $hold = $self->[SE_OBJECTS]->{ $obj_name } = [];
    if( $states ) {
        # Tediously define states for this object
        my $ours = $hold->[OH_OURS] = [];
        local $CURRENTOBJ = $obj_name;
        $states = [ $states ] unless ref $states;
        if( 'HASH' eq ref $states ) {
            while( my( $event, $method ) = each %$states ) {
                push @$ours, ev$event;
                $self->_register_state( $ours->[-1], $object, $method );
            }
        }
        else {
            foreach my $event ( @$states ) {
                push @$ours, ev$event;
                $self->_register_state( $ours->[-1], $object, $event );
            }
        }
    }
    else {
        # Make sure there are some states defined for this object's class
        my $ok = 0;
        my $package = ref $object;
        foreach my $handler ( values %{ $self->[SE_STATES] } ) {
            next unless 'ARRAY' eq ref $handler;
            next if blessed $handler->[0] and $handler->[0] ne $object;
            next unless $package eq $handler->[0] or
                        $object->isa( $handler->[0] );
            $ok = 1;
            last;
        }
        croak "No package_states defined for package $package" unless $ok;
    }
    $hold->[OH_NAME]   = $obj_name;
    $hold->[OH_OBJECT] = $object;

    # greet the object
    if( $self->_handler_for( $obj_name, "_psm_begin" ) ) {
        $poe_kernel->call( $self, evo( $obj_name, "_psm_begin" ) );
    }

    return 1;
}

#######################################
sub object_unregister
{
    my( $self, $obj_name ) = @_;

    if( blessed $obj_name ) {
        $obj_name = $self->_obj_name( $obj_name );
    }
    # say good bye the object
    if( $self->_handler_for( $obj_name, "_psm_end" ) ) {
        $poe_kernel->call( $self, evo( $obj_name, "_psm_end" ) );
    }
    my $def = delete $self->[SE_OBJECTS]->{ $obj_name };
    unless( $def ) {
        carp "Attempt to unregister unknown object $obj_name";
        return;
    }

    $self->[SE_STATERE] = '';
    return unless $def and $def->[OH_OURS];

    foreach my $event ( @{ $def->[OH_OURS] } ) {
        $self->_register_state( $event );
    }
    return 1;
}

#######################################
sub object_list
{
    my( $self ) = @_;
    return keys %{ $self->[SE_OBJECTS] };
}


#######################################
sub package_register
{
    my( $self, $package, $states ) = @_;

    $states = [ $states ] unless ref $states;
    if( 'HASH' eq ref $states ) {
        while( my( $event, $method ) = each %$states ) {
            $self->_register_state( $event, $package, $method );
        }
    }
    else {
        foreach my $event ( @$states ) {
            $self->_register_state( $event, $package, $event );
        }
    }
    return 1;
}

1;


__END__