File Coverage

blib/lib/Beam/Emitter.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	14	16	87.5
condition	11	13	84.6
subroutine	16	16	100.0
pod	7	7	100.0
total	119	123	96.7

package Beam::Emitter;
our $VERSION = '1.005';
# ABSTRACT: Role for event emitting classes

use strict;
use warnings;

use Types::Standard qw(:all);
use Scalar::Util qw( weaken refaddr );
use Carp qw( croak );
use Beam::Event;
use Module::Runtime qw( use_module );
use Moo::Role; # Put this last to ensure proper, automatic cleanup


# The event listeners on this object, a hashref of arrayrefs of
# EVENT_NAME => [ Beam::Listener object, ... ]

has _listeners => (
    is      => 'ro',
    isa     => HashRef,
    default => sub { {} },
);

#pod =method subscribe ( event_name, subref, [ %args ] )
#pod
#pod Subscribe to an event from this object. C is the name of the event.
#pod C is a subroutine reference that will get either a L object
#pod (if using the L method) or something else (if using the L method).
#pod
#pod Returns a coderef that, when called, unsubscribes the new subscriber.
#pod
#pod     my $unsubscribe = $emitter->subscribe( open_door => sub {
#pod         warn "ding!";
#pod     } );
#pod     $emitter->emit( 'open_door' );  # ding!
#pod     $unsubscribe->();
#pod     $emitter->emit( 'open_door' );  # no ding
#pod
#pod This unsubscribe subref makes it easier to stop our subscription in a safe,
#pod non-leaking way:
#pod
#pod     my $unsub;
#pod     $unsub = $emitter->subscribe( open_door => sub {
#pod         $unsub->(); # Only handle one event
#pod     } );
#pod     $emitter->emit( 'open_door' );
#pod
#pod The above code does not leak memory, but the following code does:
#pod
#pod     # Create a memory cycle which must be broken manually
#pod     my $cb;
#pod     $cb = sub {
#pod         my ( $event ) = @_;
#pod         $event->emitter->unsubscribe( open_door => $cb ); # Only handle one event
#pod         # Because the callback sub ($cb) closes over a reference to itself
#pod         # ($cb), it can never be cleaned up unless something breaks the
#pod         # cycle explicitly.
#pod     };
#pod     $emitter->subscribe( open_door => $cb );
#pod     $emitter->emit( 'open_door' );
#pod
#pod The way to fix this second example is to explicitly C inside the callback
#pod sub. Forgetting to do that will result in a leak. The returned unsubscribe coderef
#pod does not have this issue.
#pod
#pod By default, the emitter only stores the subroutine reference in an
#pod object of class L.  If more information should be
#pod stored, create a custom subclass of L and use C<%args>
#pod to specify the class name and any attributes to be passed to its
#pod constructor:
#pod
#pod   {
#pod     package MyListener;
#pod     extends 'Beam::Listener';
#pod
#pod     # add metadata with subscription time
#pod     has sub_time => is ( 'ro',
#pod 			  init_arg => undef,
#pod 			  default => sub { time() },
#pod     );
#pod   }
#pod
#pod   # My::Emitter consumes the Beam::Emitter role
#pod   my $emitter = My::Emitter->new;
#pod   $emitter->on( "foo",
#pod     sub { print "Foo happened!\n"; },
#pod    class => MyListener
#pod   );
#pod
#pod The L method can be used to examine the subscribed listeners.
#pod
#pod
#pod =cut

sub subscribe {
    my ( $self, $name, $sub, %args ) = @_;

    my $class = delete $args{ class } || "Beam::Listener";
    croak( "listener object must descend from Beam::Listener" )
      unless use_module($class)->isa( 'Beam::Listener' );

    my $listener = $class->new( %args, callback => $sub );

    push @{ $self->_listeners->{$name} }, $listener;
    weaken $self;
    weaken $sub;
    return sub {
        $self->unsubscribe($name => $sub)
	  if defined $self;
    };
}

#pod =method on ( event_name, subref )
#pod
#pod An alias for L. B: Do not use this alias for method
#pod modifiers! If you want to override behavior, override C.
#pod
#pod =cut

sub on { shift->subscribe( @_ ) }

#pod =method unsubscribe ( event_name [, subref ] )
#pod
#pod Unsubscribe from an event. C is the name of the event. C is
#pod the single listener subref to be removed. If no subref is given, will remove
#pod all listeners for this event.
#pod
#pod =cut

sub unsubscribe {
    my ( $self, $name, $sub ) = @_;
    if ( !$sub ) {
        delete $self->_listeners->{$name};
    }
    else {
        my $listeners = $self->_listeners->{$name};
        my $idx = 0;
        $idx++ until $idx > $#{$listeners} or refaddr $listeners->[$idx]->callback eq refaddr $sub;
        if ( $idx > $#{$listeners} ) {
            croak "Could not find sub in listeners";
        }
        splice @{$self->_listeners->{$name}}, $idx, 1;
    }
    return;
}

#pod =method un ( event_name [, subref ] )
#pod
#pod An alias for L. B: Do not use this alias for method
#pod modifiers! If you want to override behavior, override C.
#pod
#pod =cut

sub un { shift->unsubscribe( @_ ) }

#pod =method emit ( name, event_args )
#pod
#pod Emit a L with the given C. C is a list of name => value
#pod pairs to give to the C constructor.
#pod
#pod Use the C key in C to specify a different Event class.
#pod
#pod =cut

sub emit {
    my ( $self, $name, %args ) = @_;

    return unless exists $self->_listeners->{$name};

    my $class = delete $args{ class } || "Beam::Event";
    $args{ emitter  } ||= $self;
    $args{ name     } ||= $name;
    my $event = $class->new( %args );

    # don't use $self->_listeners->{$name} directly, as callbacks may unsubscribe
    # from $name, changing the array, and confusing the for loop
    my @listeners = @{ $self->_listeners->{$name} };

    for my $listener ( @listeners  ) {
        $listener->callback->( $event );
        last if $event->is_stopped;
    }
    return $event;
}

#pod =method emit_args ( name, callback_args )
#pod
#pod Emit an event with the given C. C is a list that will be given
#pod directly to each subscribed callback.
#pod
#pod Use this if you want to avoid using L, though you miss out on the control
#pod features like L and L.
#pod
#pod =cut

sub emit_args {
    my ( $self, $name, @args ) = @_;

    return unless exists $self->_listeners->{$name};

    # don't use $self->_listeners->{$name} directly, as callbacks may unsubscribe
    # from $name, changing the array, and confusing the for loop
    my @listeners = @{ $self->_listeners->{$name} };

    for my $listener ( @listeners ) {
        $listener->callback->( @args );
    }
    return;
}

#pod =method listeners ( event_name )
#pod
#pod Returns a list containing the listeners which have subscribed to the
#pod specified event from this emitter.  The list elements are either
#pod instances of L or of custom classes specified in calls
#pod to L.
#pod
#pod =cut

sub listeners {

    my ( $self, $name ) = @_;

    return @{ $self->_listeners->{$name} || [] };
}

1;

__END__