File Coverage

blib/lib/POE/Sugar/Attributes.pm

Criterion	Covered	Total	%
statement	219	230	95.2
branch	52	64	81.2
condition	14	28	50.0
subroutine	47	49	95.9
pod	10	11	90.9
total	342	382	89.5

package POE::Sugar::Attributes::SymInfo;
use strict;
use warnings;
use Class::Struct;
use Attribute::Handlers;

struct (__PACKAGE__,
    [
        'flags'     => '$',
        'coderef'   => '$',
        '_name'      => '$',
        'package'   => '$',
        'events'    => '@',
        'data'      => '*@'
    ]);

sub name {
    my ($self,$pkg) = @_;
    if($self->_name) {
        return $self->_name;
    }

    $pkg ||= $self->package;
    my $glob = Attribute::Handlers::findsym($pkg, $self->coderef);
    if(!$glob) {
        warn("Can't find symbol for " . $self->coderef);
        return;
    }
    my $symname = *$glob{NAME};
    $self->_name($symname);
    return $symname;
}

package POE::Sugar::Attributes::PkgInfo;
use strict;
use warnings;
use Class::Struct;

struct (__PACKAGE__,
    [
        'ctor' => '$',
        'dtor' => '$',
        'events' => '%',
        'catcher' => '$',
        'reaper' => '$',
        'sigs' => '%',
        'syms' => '%'
    ]);


package POE::Sugar::Attributes;
use strict;
use warnings;

use POE;
use POE::Session;

our $VERSION = 0.02;

use base qw(Exporter);
use Log::Fu { level => "info" };
use Data::Dumper;
our @EXPORT_OK;
BEGIN {
@EXPORT_OK = qw(
    wire_new_session
    wire_current_session
);
}

use Attribute::Handlers;

use Constant::Generate [qw(
    PA_EVENT
    PA_CTOR
    PA_DTOR
    PA_TIMER
    PA_CATCHER
    PA_REAPER
    PA_SIGHANDLER

    PA_NAME_RESOLVE
)], -type => 'bitfield',
    -start_at => 1;

use Constant::Generate [qw(
    FLD_FLAGS
    FLD_DATA
    FLD_CODE
)];

my %map_names;
my %pkgcache;
my %const2hkey;

my ($HKEY_CATCHER,
    $HKEY_REAPER,
    $HKEY_SIGHANDLERS
);

%map_names = (
    Start    => PA_CTOR,
    Stop     => PA_DTOR,
    Event    => PA_EVENT,
    State    => PA_EVENT,
    Recurring=> PA_TIMER,
    Catcher => PA_CATCHER,
    Reaper  => PA_REAPER,
    SigHandler=> PA_SIGHANDLER,
);

#Ensure we don't actually collide with a real symbol
$HKEY_CATCHER = __PACKAGE__ . "__HKEY_CATCHER__";
$HKEY_REAPER = __PACKAGE__ . "__HKEY_REAPER__";
$HKEY_SIGHANDLERS = __PACKAGE__ . "__HKEY_SIGHANDLERS__";

%const2hkey = (
    PA_CATCHER, $HKEY_CATCHER,
    PA_REAPER, $HKEY_REAPER
);



sub _get_infos {
    my ($pkg,$cv) = @_;
    my $pkginfo = ($pkgcache{$pkg} ||=
        POE::Sugar::Attributes::PkgInfo->new());
    my $syminfo = ($pkginfo->syms->{$cv+0} ||=
        POE::Sugar::Attributes::SymInfo->new(
            package => $pkg,
            coderef => $cv)
        );

    return ($pkginfo,$syminfo);
}

sub _poe_attr_handler :ATTR(CODE) {
    my ($pkg,undef,$cv,$attr,$data) = @_;

    my @opt_array;
    my %opt_hash;

    if(ref $data) {
        if(@$data % 2 == 0) {
            %opt_hash = @$data;
        }
        @opt_array = @$data;
    }

    my $flag = $map_names{$attr};
    die "No such attribute: $attr" unless defined $flag;

    my ($pkg_info,$sym_info) = _get_infos($pkg, $cv);

    $sym_info->flags( ($sym_info->flags || 0) | $flag );

    if($flag == PA_EVENT)
    {
        if(@opt_array) {
            push @{$sym_info->events}, @opt_array;
        } else {
            push @{$sym_info->events}, \undef;
        }
    }

    elsif ($flag == PA_TIMER)
    {
        my $interval = delete $opt_hash{Interval};
        die("Timer must have interval ()") unless $interval;
        my $evname = $opt_hash{Name};
        $evname ||= \undef;
        $sym_info->data->[PA_TIMER] = [ $evname, $interval ];
    }

    elsif ($flag == PA_CTOR || $flag == PA_DTOR)
    {
        if($flag == PA_CTOR) {
            $pkg_info->ctor($sym_info);
        }
        elsif($flag == PA_DTOR) {
           $pkg_info->dtor($sym_info);
        }
        #Do we have anything to do here?
    }


    elsif ($flag == PA_CATCHER) {
        $pkg_info->catcher($sym_info);
    }

    elsif ($flag == PA_REAPER) {
        $pkg_info->reaper($sym_info);
    }

    elsif ($flag == PA_SIGHANDLER) {
        if(!ref $data) {
            push @opt_array, $data;
        }
        foreach my $signame (@opt_array) {
            log_debug("Found signal $signame");
            $pkg_info->sigs->{$signame} = $sym_info;
        }
    }
}

sub Start    :ATTR(CODE) { goto &_poe_attr_handler }
sub Stop     :ATTR(CODE) { goto &_poe_attr_handler }
sub Event    :ATTR(CODE) { goto &_poe_attr_handler }
sub State    :ATTR(CODE) { goto &_poe_attr_handler }
sub Recurring:ATTR(CODE) { goto &_poe_attr_handler }
sub Catcher  :ATTR(CODE) { goto &_poe_attr_handler }
sub Reaper   :ATTR(CODE) { goto &_poe_attr_handler }
sub SigHandler:ATTR(CODE){ goto &_poe_attr_handler }

sub _get_params {
    my $pkg = shift;
    my $pkg_info = $pkgcache{$pkg};
    die("Don't have anything registered for $pkg")
        unless defined $pkg_info;

    my ($ctor,$dtor,$catcher,$reaper);
    my @events;
    my @timers;

    foreach my $sym_info (values %{$pkg_info->syms}) {

        my $symname = $sym_info->name();
        $symname = $pkg ."::$symname";

        if($sym_info->flags & PA_EVENT) {
            foreach my $evname (@{$sym_info->events}) {
                if(ref $evname) {
                    log_debug("Event is the symbol name itself.. converting");
                    $evname = $sym_info->name();
                }
                push @events, [$evname, $symname ];
            }
        }

        if($sym_info->flags & PA_TIMER) {
            my ($evname,$interval) = @{$sym_info->data->[PA_TIMER] };
            if(ref $evname) {
                log_debug("Timer event name is the symbol itsef.. converting");
                $evname = $sym_info->name();
            }
            push @timers, [ $evname, $symname, $interval ];
        }

        if($sym_info->flags & PA_CTOR) {
            $ctor = $symname;
        }
        if($sym_info->flags & PA_DTOR) {
            $dtor = $symname;
        }
    }

    my $params = {
        Events => \@events,
        Timers => \@timers,
        Ctor    => $ctor,
        Dtor    => $dtor
    };


    foreach (
        ['reaper', 'Reaper'],
        ['catcher', 'Catcher']
    ) {
        my ($meth,$key) = @$_;
        if(my $handler = $pkg_info->can($meth)->($pkg_info)) {
            my $symname = $handler->name;
            push @events, [ $symname, $pkg . "::$symname" ];
            $params->{$key} = $symname;
        }
    }

    while (my ($signame,$sighandler) = each %{$pkg_info->sigs} ) {
        my $symname = $sighandler->name();
        push @events, [ $symname, $pkg ."::$symname" ] ;
        $params->{Signals}->{$signame} = $symname;
    }

    return $params;
}

sub _setup_events {
    my ($events,$poe_kernel) = @_;
    foreach (@$events) {
        my ($evname,$subname) = @$_;
        log_debug("$evname:$subname");
        $poe_kernel->state($evname, sub { goto &{$subname} } );
    }
}

sub _setup_timers {
    my ($timers,$poe_kernel) = @_;
    foreach (@$timers) {
        my ($evname, $symname, $interval) = @$_;
        my $wrap = sub {
            $poe_kernel->delay($evname, $interval);
            goto &{$symname};
        };
        $poe_kernel->state($evname, $wrap);
        $poe_kernel->delay($evname, $interval);
    }
}

sub _setup_signals {
    my ($signals, $poe_kernel) = @_;
    return unless $signals;
    while (my ($signame,$evname) = each %$signals) {
        log_debugf("$signame => $evname");
        $poe_kernel->sig($signame, $evname);
    }
}

sub inline_states {
    my ($cls,$pkg,$alias) = @_;
    $pkg ||= caller();
    my $params = _get_params($pkg);
    my $sess_hash =  {
        _start => sub {
            if($alias) {
                $_[KERNEL]->alias_set($alias);
            }
            _setup_timers($params->{Timers}, $_[KERNEL]);
            _setup_events($params->{Events}, $_[KERNEL]);

            if($params->{Catcher}) {
                log_debug("Setting DIE handler: ", $params->{Catcher});
                $_[KERNEL]->sig(DIE => $params->{Catcher});
            }

            if(my $reaper = $params->{Reaper}) {
                log_debugf("Setting CHLD handler: %s", $reaper);
                $_[KERNEL]->sig(CHLD => $reaper);
            }

            if($params->{Signals}) {
                _setup_signals($params->{Signals}, $_[KERNEL]);
            }

            if($params->{Ctor}) {
                goto &{ $params->{Ctor} };
            }
        },
        _stop => sub {
            if($params->{Dtor}) {
                goto &{ $params->{Dtor} };
            }
        }
    };

    return $sess_hash;
}

#This is for other modules which inject themselves, in-situ, into a session
sub wire_current_session {
    my ($cls,$poe_kernel,$pkg) = @_;
    $pkg ||= caller();
    my $params = _get_params($pkg);
    _setup_timers($params->{Timers}, $poe_kernel);
    _setup_events($params->{Events}, $poe_kernel);
    _setup_signals($params->{Signals}, $poe_kernel);
}


sub wire_new_session {
    my $alias = shift;
    if( $alias && $alias eq __PACKAGE__) {
        $alias = shift;
    }

    my $pkg = shift;
    $pkg ||= caller();

    POE::Session->create(
        inline_states => __PACKAGE__->inline_states($pkg, $alias)
    );
}

1;

__END__