view release on metacpan or  search on metacpan

lib/Beam/Emitter.pm  view on Meta::CPAN

#pod         return if $event->is_default_stopped;
#pod         $self->open_the_door;
#pod     }
#pod
#pod Finally, let's build a listener that knows who is allowed in the door.
#pod
#pod     my $private_door = Door->new;
#pod     $private_door->on( before_open => sub {
#pod         my ( $event ) = @_;
#pod
#pod         if ( $event->who ne 'preaction' ) {
#pod             $event->stop_default;
#pod         }
#pod
#pod     } );
#pod
#pod     $private_door->open;
#pod
#pod =head2 Without Beam::Event
#pod
#pod Although checking C<is_default_stopped> is completely optional, if you do not
#pod wish to use the C<Beam::Event> object, you can instead call L<emit_args>
#pod instead of L<emit> to give arbitrary arguments to your listeners.
#pod
#pod     package Door;
#pod     use Moo;
#pod     with 'Beam::Emitter';
#pod
#pod     sub open {
#pod         my ( $self, $who ) = @_;
#pod         $self->emit_args( 'open', $who );
#pod         $self->open_the_door;
#pod     }
#pod
#pod There's no way to stop the door being opened, but you can at least notify
#pod someone before it does.
#pod
#pod =head1 SEE ALSO
#pod
#pod =over 4
#pod
#pod =item L<Beam::Event>
#pod
#pod =item L<Beam::Emitter::Cookbook>
#pod
#pod This document contains some useful patterns for your event emitters and
#pod listeners.
#pod
#pod =item L<http://perladvent.org/2013/2013-12-16.html>
#pod
#pod Coordinating Christmas Dinner with Beam::Emitter by Yanick Champoux.
#pod
#pod =back
#pod
#pod =cut

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<event_name> is the name of the event.
#pod C<subref> is a subroutine reference that will get either a L<Beam::Event> object
#pod (if using the L<emit> method) or something else (if using the L<emit_args> 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<undef $cb> 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<Beam::Listener>.  If more information should be
#pod stored, create a custom subclass of L<Beam::Listener> 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</listeners> 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</subscribe>. B<NOTE>: Do not use this alias for method
#pod modifiers! If you want to override behavior, override C<subscribe>.
#pod
#pod =cut

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

#pod =method unsubscribe ( event_name [, subref ] )
#pod
#pod Unsubscribe from an event. C<event_name> is the name of the event. C<subref> 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</unsubscribe>. B<NOTE>: Do not use this alias for method
#pod modifiers! If you want to override behavior, override C<unsubscribe>.
#pod
#pod =cut

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

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

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