File Coverage

blib/lib/POE/Component/SubWrapper.pm

Criterion	Covered	Total	%
statement	77	78	98.7
branch	5	6	83.3
condition	4	6	66.6
subroutine	15	16	93.7
pod	5	5	100.0
total	106	111	95.5

package POE::Component::SubWrapper;

=head1 NAME

POE::Component::SubWrapper - event based wrapper for subs

=head1 SYNOPSIS

  use POE::Component::SubWrapper;
  POE::Component::SubWrapper->spawn('main');
  $kernel->post('main', 'my_sub', [ $arg1, $arg2, $arg3 ], 'callback_state');

=head1 DESCRIPTION

This is a module which provides an event based wrapper for subroutines.


=head1 METHODS

=cut

use warnings;
use strict;

use Carp qw(croak);
use POE;
use Devel::Symdump;

use Exporter::Lite;
our @EXPORT = qw(poeize);


our $VERSION = '2.01';

use constant DEBUG => 0;

=head2 spawn

  POE::Component::SubWrapper->spawn('main');

SubWrapper components are not normal objects, but are instead 'spawned' as
separate sessions.  This is done with with PoCo::SubWrapper's 'spawn'
method, which takes one required and one optional argument.  The first
argument is the package name to wrap. This is required. The second argument
is optional and contains an alias to give to the session created. If no
alias is supplied, the package name is used as an alias.

=cut

sub spawn { #{{{
    DEBUG && print "PoCo::SubWrapper->spawn: Entering\n";

    my $type = shift;
    my $package = shift;
    my $alias = shift;

    croak "Too many args" if scalar @_;
    $alias = $package unless defined($alias) and length($alias);

    DEBUG && print "PoCo::SubWrapper->spawn: type = [$type], package = [$package], alias = [$alias]\n";

    # get subroutines defined by package.
    my @subs;

    my $sym = Devel::Symdump->new($package);
    {
        no strict 'refs';
        foreach my $function ($sym->functions) {
            *p = *$function;
            my $coderef = *p{CODE};
            my ($key) = ($function =~ /([^:]*)$/);

            use Data::Dumper;
            DEBUG && print "Symbol is $function\n";
            DEBUG && print "key is $key\n";
            DEBUG && print "Coderef is [", Dumper($coderef), "]\n";

            push @subs, { name => $key, code => $coderef };
        }
    }

    my %states;
    foreach my $sub (@subs) {
        DEBUG && print "Building state for ", $sub->{name}, "\n";
        $states{$sub->{name}} = build_handler($package, $sub->{code});
    }

    $states{'_start'} = \&wrapper_start;
    $states{'_stop'} = sub {};

    my $s = POE::Session->create(
        inline_states => \%states,
        heap => {
            alias => $alias,
        }
    );
    return $s;
} #}}}


=head2 poeize

  poeize My::Package;

Another way to create SubWrapper components is to use the C method,
which is included in the default export list of the package. You can simply
do:

  poeize Data::Dumper;

and Data::Dumper will be wrapped into a session with the alias
'Data::Dumper'.

=cut

sub poeize (*) { #{{{
  my $package = shift;
  spawn($package, $package);
} #}}}

=begin devel

=head2 wrapper_start

Sets our alias

=cut

sub wrapper_start { #{{{
    $_[KERNEL]->alias_set($_[HEAP]->{alias});
} #}}}


=head2 shutdown

Provides a way to forcibly shutdown our session.
This is done by removing our alias. Assuming there are no events on the
queue for us, we should shut down immediately.

=cut

sub shutdown { #{{{
    $_[KERNEL]->alias_remove($_[HEAP]->{alias});
} #}}}

=head2 build_handler

return a closure that knows how to call the specified sub and post
the results back.

=cut

sub build_handler { #{{{
    my ($package, $sub) = @_;

    my $ref = sub {
        my ($kernel, $heap, $args_ref, $callback, $context, $sender) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2, SENDER];
        warn Dumper($kernel->alias_list($_[SESSION]));
        DEBUG && print "Handler called for package=[$package], sub = [$sub]\n";

        my @sub_args = @$args_ref;
        my $result;
        #my $name = "${package}::${sub}";
        DEBUG && print "handler: calling [$sub]\n";

        if (defined($context) and $context eq 'SCALAR') {
            # scalar context. default if not supplied.
            DEBUG && print "handler: calling in scalar context\n";

            $result = scalar &{$sub}(@sub_args);
        } else {
            # array context.
            my @result;
            DEBUG && print "handler: calling in array context\n";
            @result = &{$sub}(@sub_args);
            $result = \@result;
        }

        $kernel->post($sender, $callback, $result);
        return;
    };

    return $ref;
} #}}}

1;

__END__