File Coverage

blib/lib/Mixin/Event/Dispatch.pm
Criterion Covered Total %
statement 61 66 92.4
branch 14 26 53.8
condition 10 13 76.9
subroutine 14 15 93.3
pod 6 6 100.0
total 105 126 83.3


line stmt bran cond sub pod time code
1             package Mixin::Event::Dispatch;
2             # ABSTRACT: Mixin methods for simple event/message dispatch framework
3 8     8   7451 use strict;
  8         13  
  8         168  
4 8     8   35 use warnings;
  8         11  
  8         300  
5              
6             our $VERSION = '2.000';
7              
8             # Key name to use for event handlers. Nothing should be
9             # accessing this directly so we don't mind something
10             # unreadable, it's only used in two methods which subclasses
11             # can override at will
12 8     8   34 use constant EVENT_HANDLER_KEY => '__MED_event_handlers';
  8         13  
  8         608  
13              
14             # Legacy support, newer classes probably would turn this off
15 8     8   35 use constant EVENT_DISPATCH_ON_FALLBACK => 1;
  8         18  
  8         447  
16              
17             =encoding utf8
18              
19             =head1 NAME
20              
21             Mixin::Event::Dispatch - mixin methods for simple event/message dispatch framework
22              
23             =head1 VERSION
24              
25             version 2.000
26              
27             =head1 SYNOPSIS
28              
29             # Add a handler then invoke it
30             package Some::Class;
31             use parent qw(Mixin::Event::Dispatch);
32             sub new { bless {}, shift }
33              
34             my $obj = Some::Class->new;
35              
36             # Subscribe to events - subscribers will be called with an event object,
37             # and any event parameters, each time the event is raised.
38             $obj->subscribe_to_event(another_event => (my $code = sub {
39             my $ev = shift;
40             warn "[] @_";
41             }));
42             $obj->invoke_event(another_event => 'like this');
43             # should get output 'Event data: like this'
44             $obj->unsubscribe_from_event(another_event => $code);
45              
46             # Note that handlers will be called for each instance of an event until they return false,
47             # at which point the handler will be removed, so for a permanent handler, make sure to return 1.
48             $obj->add_handler_for_event(some_event => sub { my $self = shift; warn "had some_event: @_"; 1; });
49             $obj->invoke_event(some_event => 'message here');
50              
51             # Attach event handler for all on_XXX named parameters
52             package Event::User;
53             sub configure {
54             my $self = shift;
55             my %args = @_;
56             $self->add_handler_for_event(
57             map { (/^on_(.*)$/) ? ($1 => $args{$_}) : () } keys %args
58             );
59             return $self;
60             }
61              
62             =head1 DESCRIPTION
63              
64             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).
65              
66             Note that handlers should return 0 for a one-off handler, and 1 if it should be called again on the next event.
67              
68             =head1 SPECIAL EVENTS
69              
70             A single event has been reserved for cases where a callback dies:
71              
72             =over 4
73              
74             =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,
75             then this error will be re-thrown. As with the other handlers, you can have more than one C< event_error > handler.
76              
77             =back
78              
79             =cut
80              
81 8     8   5634 use List::UtilsBy ();
  8         12599  
  8         181  
82 8     8   48 use Scalar::Util ();
  8         15  
  8         151  
83 8     8   4308 use Mixin::Event::Dispatch::Event;
  8         17  
  8         4778  
84              
85             =head1 METHODS
86              
87             =cut
88              
89             =head2 invoke_event
90              
91             Takes an C parameter, and optional additional parameters that are passed to any callbacks.
92              
93             $self->invoke_event('new_message', from => 'fred', subject => 'test message');
94              
95             Returns $self if a handler was found, undef if not.
96              
97             =cut
98              
99             sub invoke_event {
100 16     16 1 3385 my ($self, $event_name, @param) = @_;
101 16   100     42 my $handlers = $self->event_handlers->{$event_name} || [];
102            
103 16 100       63 unless(@$handlers) {
104             # Legacy flag - when set, pass control to on_$event_name
105             # if we don't have a handler defined.
106 7 100 66     89 if($self->can('EVENT_DISPATCH_ON_FALLBACK') && $self->EVENT_DISPATCH_ON_FALLBACK && (my $code = $self->can("on_$event_name"))) {
      100        
107 2         2 local $@;
108             eval {
109 2         7 $code->($self, @_);
110 2         11 1;
111 2 50       4 } or do {
112 0 0       0 die $@ if $event_name eq 'event_error';
113 0 0       0 $self->invoke_event(event_error => $@) or die "$@ and no event_error handler found";
114             };
115             }
116 7         26 return $self;
117             }
118              
119             # We should really do this...
120             # my $ev = Mixin::Event::Dispatch::Event->new(
121             # name => $event_name,
122             # instance => $self,
123             # handlers => [ @$handlers ],
124             # );
125             # $ev->dispatch;
126             # ... but this gives better performance (examples/benchmark.pl)
127 9         103 (bless {
128             name => $event_name,
129             instance => $self,
130             # Passing a copy since we might change these later and
131             # we do not want those changes to affect any events
132             # currently in flight
133             handlers => [ @$handlers ],
134             }, 'Mixin::Event::Dispatch::Event')->dispatch(@param);
135 9         69 return $self;
136             }
137              
138             =head2 subscribe_to_event
139              
140             Subscribe the given coderef to the named event.
141              
142             Called with a list of event name and handler pairs. An
143             event name can be any string value. The handler is one
144             of the following:
145              
146             =over 4
147              
148             =item * a coderef will be used directly as a handler,
149             and will be passed the L
150             object representing this event.
151              
152             =item * a plain string will be used as a method name
153              
154             =item * a subclass of L will
155             be used to delegate the event - use this if you have
156             an object hierarchy and want the parent object to handle
157             events on the current object
158              
159             =back
160              
161             If you have an overloaded object which is both a
162             L subclass and provides a
163             coderef overload, it will default to event delegation
164             behaviour. To ensure the overloaded coderef is used
165             instead, pass \&$obj instead.
166              
167             All handlers will be given an event (a
168             L object) as the first
169             parameter, and any passed event parameters as the
170             remainder of @_.
171              
172             Example usage:
173              
174             my $parent = $obj->parent;
175             $obj->subscribe_to_event(
176             connect => sub { warn shift->name }, # warns 'connect'
177             connect => $parent, # $parent->invoke_event(connect => @_)
178             connect => \&$parent, # $parent's overloaded &{}
179             joined => 'on_joined', # the on_joined method in $obj
180             );
181              
182             Note that multiple handlers can be assigned to the same
183             event name.
184              
185             =cut
186              
187             sub subscribe_to_event {
188 6     6 1 29798 my $self = shift;
189              
190             # Init if we haven't got a valid event_handlers yet
191 6 50       30 $self->clear_event_handlers unless $self->event_handlers;
192              
193             # Add the defined handlers
194 6         33 while(@_) {
195 6         25 my ($ev, $code) = splice @_, 0, 2;
196 6 50       22 die 'Undefined event?' unless defined $ev;
197 6         12 push @{$self->event_handlers->{$ev}}, $code;
  6         21  
198 6 50 33     99 Scalar::Util::weaken($self->event_handlers->{$ev}[-1]) if ref($code) && Scalar::Util::reftype($code) ne 'CODE'
199             }
200 6         16 return $self;
201             }
202              
203             =head2 unsubscribe_from_event
204              
205             Removes the given coderef from the list of handlers for this event.
206              
207             Expects pairs of (event name, coderef) entries for the events to
208             unsubscribe from.
209              
210             Example usage:
211              
212             $obj->subscribe_to_event(
213             some_event => (my $code = sub { }),
214             );
215             $obj->unsubscribe_from_event(
216             some_event => $code,
217             );
218              
219             If you need to unsubscribe from the event currently being
220             handled, try the L
221             method.
222              
223             Returns $self.
224              
225             =cut
226              
227             sub unsubscribe_from_event {
228 6     6 1 1955 my $self = shift;
229              
230             # Init if we haven't got a valid event_handlers yet
231 6 50       20 $self->clear_event_handlers unless $self->event_handlers;
232              
233             # Add the defined handlers
234 6         19 while(@_) {
235 6         21 my ($ev, $code) = splice @_, 0, 2;
236 6 50       20 die 'Undefined event?' unless defined $ev;
237             List::UtilsBy::extract_by {
238 6     6   81 Scalar::Util::refaddr($code) == Scalar::Util::refaddr($_)
239 6 50       30 } @{$self->event_handlers->{$ev}} or die "Was not subscribed to $ev for $code";
  6         19  
240             }
241 6         86 return $self;
242             }
243              
244             =head2 add_handler_for_event
245              
246             Adds handlers to the stack for the given events.
247              
248             $self->add_handler_for_event(
249             new_message => sub { warn @_; 1 },
250             login => sub { warn @_; 1 },
251             logout => sub { warn @_; 1 },
252             );
253              
254             =cut
255              
256             sub add_handler_for_event {
257 2     2 1 3 my $self = shift;
258              
259             # Init if we haven't got a valid event_handlers yet
260 2 50       7 $self->clear_event_handlers unless $self->event_handlers;
261              
262             # Add the defined handlers
263 2         6 while(@_) {
264 2         19 my ($ev, $code) = splice @_, 0, 2;
265             # Support legacy interface via wrapper
266             # * handler is passed $self
267             # * returning false means we want to unsubscribe
268 2         5 push @{$self->event_handlers->{$ev}}, sub {
269 2     2   3 my $ev = shift;
270 2 100       7 return if $code->($ev->instance, @_);
271 1         8 $ev->unsubscribe;
272 2         3 };
273             }
274 2         7 return $self;
275             }
276              
277             =head2 event_handlers
278              
279             Accessor for the event stack itself - should return a hashref which maps event names to arrayrefs for
280             the currently defined handlers.
281              
282             =cut
283              
284 44   100 44 1 304 sub event_handlers { shift->{+EVENT_HANDLER_KEY} ||= {} }
285              
286             =head2 clear_event_handlers
287              
288             Removes all queued event handlers.
289              
290             Will also be called when defining the first handler to create the initial L entry, should
291             be overridden by subclass if something other than $self->{event_handlers} should be used.
292              
293             =cut
294              
295             sub clear_event_handlers {
296 0     0 1   my $self = shift;
297 0           $self->{+EVENT_HANDLER_KEY} = { };
298 0           return $self;
299             }
300              
301             1;
302              
303             __END__