package Mixin::Event::Dispatch; # ABSTRACT: Mixin methods for simple event/message dispatch framework use strict; use warnings; use List::UtilsBy (); use Scalar::Util (); use Try::Tiny; use Mixin::Event::Dispatch::Event; our $VERSION = '1.004'; # Key name to use for event handlers. Nothing should be # accessing this directly so we don't mind something # unreadable, it's only used in two methods which subclasses # can override at will use constant EVENT_HANDLER_KEY => '__MED_event_handlers'; # Legacy support, newer classes probably would turn this off use constant EVENT_DISPATCH_ON_FALLBACK => 1; =encoding utf8 =head1 NAME Mixin::Event::Dispatch - mixin methods for simple event/message dispatch framework =head1 VERSION version 1.004 =head1 SYNOPSIS # Add a handler then invoke it package Some::Class; use parent qw(Mixin::Event::Dispatch); sub new { bless {}, shift } my $obj = Some::Class->new; # Subscribe to events - subscribers will be called with an event object, # and any event parameters, each time the event is raised. $obj->subscribe_to_event(another_event => (my $code = sub { my $ev = shift; warn "[] @_"; })); $obj->invoke_event(another_event => 'like this'); # should get output 'Event data: like this' $obj->unsubscribe_from_event(another_event => $code); $obj->trace_events_for(sub { $obj->invoke_event(another_event => 'like this'); }); # Note that handlers will be called for each instance of an event until they return false, # at which point the handler will be removed, so for a permanent handler, make sure to return 1. $obj->add_handler_for_event(some_event => sub { my $self = shift; warn "had some_event: @_"; 1; }); $obj->invoke_event(some_event => 'message here'); # Attach event handler for all on_XXX named parameters package Event::User; sub configure { my $self = shift; my %args = @_; $self->add_handler_for_event( map { (/^on_(.*)$/) ? ($1 => $args{$_}) : () } keys %args ); return $self; } =head1 DESCRIPTION Add this in as a parent to your class, and it'll provide some methods for defining event handlers (L or L) and calling them (L). Note that handlers should return 0 for a one-off handler, and 1 if it should be called again on the next event. =head1 SPECIAL EVENTS A single event has been reserved for cases where a callback dies: =over 4 =item * C< event_error > - if a handler is available, this will be called instead of dying whenever any other handler dies. If an C< event_error > handler also fails, then this error will be re-thrown. As with the other handlers, you can have more than one C< event_error > handler. =back =head1 METHODS =cut =head2 invoke_event Takes an C parameter, and optional additional parameters that are passed to any callbacks. $self->invoke_event('new_message', from => 'fred', subject => 'test message'); Returns $self if a handler was found, undef if not. =cut sub invoke_event { my ($self, $event_name, @param) = @_; my $handlers = $self->event_handlers->{$event_name} || []; unless(@$handlers) { local $@; # Legacy flag - when set, pass control to on_$event_name # if we don't have a handler defined. return $self unless $self->EVENT_DISPATCH_ON_FALLBACK; return $self unless my $code = $self->can("on_$event_name"); eval { $code->($self, @_); 1; } or do { die $@ if $event_name eq 'event_error'; $self->invoke_event(event_error => $@) or die "$@ and no event_error handler found"; }; return $self; } # We should really do this... # my $ev = Mixin::Event::Dispatch::Event->new( # name => $event_name, # instance => $self, # handlers => [ @$handlers ], # ); # $ev->dispatch; # ... but this gives better performance (examples/ (bless { name => $event_name, instance => $self, # Passing a copy since we might change these later and # we do not want those changes to affect any events # currently in flight handlers => [ @$handlers ], }, 'Mixin::Event::Dispatch::Event')->dispatch(@param); return $self; } =head2 subscribe_to_event Subscribe the given coderef to the named event. Called with a list of event name and handler pairs. An event name can be any string value. The handler is one of the following: =over 4 =item * a coderef will be used directly as a handler, and will be passed the L object representing this event. =item * a plain string will be used as a method name =item * a subclass of L will be used to delegate the event - use this if you have an object hierarchy and want the parent object to handle events on the current object =back If you have an overloaded object which is both a L subclass and provides a coderef overload, it will default to event delegation behaviour. To ensure the overloaded coderef is used instead, pass \&$obj instead. All handlers will be given an event (a L object) as the first parameter, and any passed event parameters as the remainder of @_. Example usage: my $parent = $obj->parent; $obj->subscribe_to_event( connect => sub { warn shift->name }, # warns 'connect' connect => $parent, # $parent->invoke_event(connect => @_) connect => \&$parent, # $parent's overloaded &{} joined => 'on_joined', # the on_joined method in $obj ); Note that multiple handlers can be assigned to the same event name. =cut sub subscribe_to_event { my $self = shift; # Init if we haven't got a valid event_handlers yet $self->clear_event_handlers unless $self->event_handlers; # Add the defined handlers while(@_) { my ($ev, $code) = splice @_, 0, 2; die 'Undefined event?' unless defined $ev; push @{$self->event_handlers->{$ev}}, $code; Scalar::Util::weaken($self->event_handlers->{$ev}[-1]) if ref($code) && Scalar::Util::reftype($code) ne 'CODE' } return $self; } =head2 unsubscribe_from_event Removes the given coderef from the list of handlers for this event. Expects pairs of (event name, coderef) entries for the events to unsubscribe from. Example usage: $obj->subscribe_to_event( some_event => (my $code = sub { }), ); $obj->unsubscribe_from_event( some_event => $code, ); If you need to unsubscribe from the event currently being handled, try the L method. Returns $self. =cut sub unsubscribe_from_event { my $self = shift; # Init if we haven't got a valid event_handlers yet $self->clear_event_handlers unless $self->event_handlers; # Add the defined handlers while(@_) { my ($ev, $code) = splice @_, 0, 2; die 'Undefined event?' unless defined $ev; List::UtilsBy::extract_by { Scalar::Util::refaddr($code) == Scalar::Util::refaddr($_) } @{$self->event_handlers->{$ev}} or die "Was not subscribed to $ev for $code"; } return $self; } =head2 add_handler_for_event Adds handlers to the stack for the given events. $self->add_handler_for_event( new_message => sub { warn @_; 1 }, login => sub { warn @_; 1 }, logout => sub { warn @_; 1 }, ); =cut sub add_handler_for_event { my $self = shift; # Init if we haven't got a valid event_handlers yet $self->clear_event_handlers unless $self->event_handlers; # Add the defined handlers while(@_) { my ($ev, $code) = splice @_, 0, 2; # Support legacy interface via wrapper # * handler is passed $self # * returning false means we want to unsubscribe push @{$self->event_handlers->{$ev}}, sub { my $ev = shift; return if $code->($ev->instance, @_); $ev->unsubscribe; }; } return $self; } =head2 event_handlers Accessor for the event stack itself - should return a hashref which maps event names to arrayrefs for the currently defined handlers. =cut sub event_handlers { shift->{+EVENT_HANDLER_KEY} ||= {} } =head2 clear_event_handlers Removes all queued event handlers. Will also be called when defining the first handler to create the initial L entry, should be overridden by subclass if something other than $self->{event_handlers} should be used. =cut sub clear_event_handlers { my $self = shift; $self->{+EVENT_HANDLER_KEY} = { }; return $self; } 1; __END__ =head1 API HISTORY Version 1.000 implemented L and L. Version 0.002 changed to use L instead of C< event_stack > for storing the available handlers (normally only L and L are expected to be called directly). =head1 ROLE vs. MIXIN Most role systems should be able to use this class - either directly, or through a thin wrapper which adds any required boilerplate. Try L or L / L for that. Alternatively, you could use this as a component via L. (I haven't tried any of the above options myself, please let me know if I'm spreading disinformation here) =head1 SEE ALSO There are at least a dozen similar modules already on CPAN, here's a small sample: =over 4 =item * L - event callback interface used in several L modules. =item * L - part of the L web application framework =item * L - event subscription via TCP-based message bus =item * L - wrapping for event listeners =item * L - node.js-inspired events, for Moose users =back Note that some frameworks such as L and L already have comprehensive message-passing and callback interfaces. If you're looking for usage examples, try the following: =over 4 =item * L - uses this as the underlying event-passing mechanism, with some support in L for indicating event usage metadata =item * L - mostly an adapter converting PostgreSQL database messages to/from events using this class =item * L - the same, but for the IMAPv4bis protocol =item * L - and again for Jabber/XMPP =back =head1 AUTHOR Tom Molesworth with thanks to various helpful people on freenode #perl who suggested making L into an accessor (to support non-hashref objects) and who patiently tried to explain about roles. =head1 LICENSE Copyright Tom Molesworth 2011-2013, based on code originally part of L. Licensed under the same terms as Perl itself.