view release on metacpan or  search on metacpan

lib/Event/Wrappable.pm  view on Meta::CPAN

# ABSTRACT: Sugar to let you instrument event listeners at a distance
package Event::Wrappable;
{
  $Event::Wrappable::VERSION = '0.1.1';
}
use strict;
use warnings;
use Scalar::Util qw( refaddr weaken );
use Sub::Exporter -setup => {
    exports => [qw( event event_method )],
    groups => { default => [qw( event event_method )] },
    };
use Sub::Clone qw( clone_sub );

our %INSTANCES;

our @EVENT_WRAPPERS;

sub wrap_events {
    my $class = shift;
    my( $todo, @wrappers ) = @_;
    local @EVENT_WRAPPERS = ( @EVENT_WRAPPERS, @wrappers );
    $todo->();
}

my $LAST_ID;


sub _new {
    my $class = shift;
    my( $event, $raw_event ) = @_;
    bless $event, $class;
    my $storage = $INSTANCES{refaddr $event} = {};
    weaken( $storage->{'wrapped'} = $event );
    weaken( $storage->{'base'}    = $raw_event );
    $storage->{'wrappers'} = [ @EVENT_WRAPPERS ];
    $storage->{'id'} = ++ $LAST_ID;
    return $event;
}


sub event(&) {
    my( $raw_event ) = @_;
    my $event = clone_sub $raw_event;
    if ( @EVENT_WRAPPERS ) {
        for (reverse @EVENT_WRAPPERS) {
            $event = $_->($event);
        }
    }
    return __PACKAGE__->_new( $event, $raw_event );
}


sub event_method($$) {
    my( $object, $method ) = @_;
    my $method_sub = ref($method) eq 'CODE' ? $method : $object->can($method);
    return event { unshift @_, $object; goto $method_sub };
}

sub get_unwrapped {
    my $self = shift;
    return $INSTANCES{refaddr $self}->{'base'};
}

sub get_wrappers {
    my $self = shift;
    my $wrappers = ref $self
                 ? $INSTANCES{refaddr $self}->{'wrappers'}
                 : \@EVENT_WRAPPERS;
    return wantarray ? @$wrappers : $wrappers;
}

sub object_id {
    my $self = shift;
    return $INSTANCES{refaddr $self}->{'id'};
}

sub DESTROY {
    my $self = shift;
    delete $INSTANCES{refaddr $self};
}

sub CLONE {
    my $self = shift;
    foreach (keys %INSTANCES) {
        my $object = $INSTANCES{$_}{'wrapped'};
        $INSTANCES{refaddr $object} = $INSTANCES{$_};
        delete $INSTANCES{$_};
    }
}

1;

__END__
=pod