File Coverage

blib/lib/Mixin/Event/Dispatch/Event.pm
Criterion Covered Total %
statement 39 61 63.9
branch 4 14 28.5
condition 2 3 66.6
subroutine 11 18 61.1
pod 13 13 100.0
total 69 109 63.3


line stmt bran cond sub pod time code
1             package Mixin::Event::Dispatch::Event;
2             $Mixin::Event::Dispatch::Event::VERSION = '1.999_002'; # TRIAL
3 8     8   35 use strict;
  8         11  
  8         185  
4 8     8   34 use warnings;
  8         13  
  8         170  
5              
6 8     8   32 use List::UtilsBy ();
  8         13  
  8         203  
7 8     8   32 use Scalar::Util qw(reftype);
  8         12  
  8         1005  
8              
9 8     8   40 use constant DEBUG => $ENV{MIXIN_EVENT_DISPATCH_DEBUG};
  8         12  
  8         5608  
10              
11             =encoding utf8
12              
13             =head1 NAME
14              
15             Mixin::Event::Dispatch::Event - an event object
16              
17             =head1 VERSION
18              
19             version 1.999_002
20              
21             =head1 SYNOPSIS
22              
23             my $self = shift;
24             my $ev = Mixin::Event::Dispatch::Event->new(
25             name => 'some_event',
26             instance => $self,
27             );
28             $ev->dispatch;
29              
30             =head1 DESCRIPTION
31              
32             Provides an object with which to interact with the current
33             event.
34              
35             =head1 METHODS
36              
37             =cut
38              
39             =head2 new
40              
41             Takes the following (named) parameters:
42              
43             =over 4
44              
45             =item * name - the name of this event
46              
47             =item * instance - the originating instance
48              
49             =item * parent - another L
50             object if we were invoked within an existing handler
51              
52             =item * handlers - the list of handlers for this event
53              
54             =back
55              
56             We're assuming that time is of the essence,
57             hence the peculiar implementation. Also note that this
58             constructor is rarely called in practice -
59             L uses bless directly.
60              
61             Returns $self.
62              
63             =cut
64              
65 0     0 1 0 sub new { bless { @_[1..$#_] }, $_[0] }
66              
67             =head1 READ-ONLY ACCESSORS
68              
69             =cut
70              
71             =head2 name
72              
73             Returns the name of this event.
74              
75             =cut
76              
77 2     2 1 1333 sub name { $_[0]->{name} }
78              
79             =head2 is_deferred
80              
81             Returns true if this event has been deferred. This means
82             another handler is active, and has allowed remaining handlers
83             to take over the event - once those other handlers have
84             finished the original handler will be resumed.
85              
86             =cut
87              
88 0 0   0 1 0 sub is_deferred { $_[0]->{is_deferred} ? 1 : 0 }
89              
90             =head2 is_stopped
91              
92             Returns true if this event has been stopped. This means
93             no further handlers will be called.
94              
95             =cut
96              
97 0 0   0 1 0 sub is_stopped { $_[0]->{is_deferred} ? 1 : 0 }
98              
99             =head2 instance
100              
101             Returns the original object instance upon which the
102             L method was called.
103              
104             This may be different from the instance we're currently
105             handling, for cases of event delegation for example.
106              
107             =cut
108              
109 3     3 1 11 sub instance { $_[0]->{instance} }
110              
111             =head2 parent
112              
113             Returns the parent L, if there
114             was one. Usually there wasn't.
115              
116             =cut
117              
118 0     0 1 0 sub parent { $_[0]->{parent} }
119              
120             =head2 handlers
121              
122             Returns a list of the remaining handlers for this event.
123             Any that have already been called will be removed from this
124             list.
125              
126             =cut
127              
128             sub handlers {
129 0     0 1 0 my $self = shift;
130 0 0       0 @{$self->{remaining}||[]}
  0         0  
131             }
132              
133             =head2 stop
134              
135             Stop processing for this event. Prevents any further event
136             handlers from being called.
137              
138             =cut
139              
140             sub stop {
141 1     1 1 2 my $self = shift;
142 1         2 $self->debug_print('Stopping') if DEBUG;
143 1         2 $self->{is_stopped} = 1;
144 1         7 $self
145             }
146              
147             =head2 dispatch
148              
149             Dispatches this event. Takes the parameters originally passed to
150             L (with the exception of
151             the event name), and passes it on to the defined handlers.
152              
153             Returns $self.
154              
155             =cut
156              
157             sub dispatch {
158 9     9 1 16 my $self = shift;
159 9         14 $self->debug_print("Dispatch with [@_]") if DEBUG;
160             # Support pre-5.14 Perl versions. The main reason for not using
161             # Try::Tiny here is performance; 10k events/sec with Try::Tiny on
162             # an underpowered system, vs. 30k+ with plain eval.
163             eval {
164 9   66     96 while(!$self->{is_deferred} && @{$self->{handlers}}) {
  18         4239  
165 9         14 local $self->{current_handler} = my $h = shift @{$self->{handlers}};
  9         25  
166 9 50       41 if(ref $h) {
167 9 50       45 if(reftype($h) eq 'CODE') {
168 9         30 $h->($self, @_)
169             } else {
170 0         0 $h->invoke_event($self->name, @_)
171             }
172             } else {
173 0         0 $self->instance->$h($self, @_)
174             }
175             }
176 9         38 1;
177 9 50       14 } or do {
178 0         0 my $err = $@;
179 0         0 $self->debug_print("Exception $err from [@_]") if DEBUG;
180 0         0 die $err;
181             };
182 9         18 $self
183             }
184              
185             =head2 play
186              
187             Continue the current event. Do not use.
188              
189             Semantics are subject to change so avoid this and consider
190             L instead. Currently does nothing anyway.
191              
192             Returns $self.
193              
194             =cut
195              
196 1     1 1 4 sub play { shift }
197              
198             =head2 defer
199              
200             Defers this event.
201              
202             Causes remaining handlers to be called, and marks as
203             L.
204              
205             sub {
206             my $ev = shift;
207             print "Deferring\n";
208             $ev->defer(@_);
209             print "Finished deferring\n";
210             }
211              
212             Returns $self.
213              
214             =cut
215              
216             sub defer {
217 0     0 1 0 my $self = shift;
218 0         0 $self->debug_print("Deferring with [@_]") if DEBUG;
219 0         0 $self->{is_deferred} = 1;
220 0         0 my $handler = $self->{current_handler};
221 0         0 $self->dispatch(@_);
222 0         0 $self->{current_handler} = $handler;
223 0         0 $self;
224             }
225              
226             =head2 unsubscribe
227              
228             Unsubscribes the current handler from the event that we're
229             processing at the moment.
230              
231             Can be used to implement one-shot or limited-lifetime event
232             handlers:
233              
234             my $count = 0;
235             $obj->subscribeto_event(
236             som_event => sub {
237             my $ev = shift;
238             return $ev->unsubscribe if ++$count > 3;
239             print "Current count: $count\n";
240             }
241             );
242             $obj->invoke_event('some_event') for 1..5;
243              
244             Returns $self.
245              
246             =cut
247              
248             sub unsubscribe {
249 1     1 1 2 my $self = shift;
250 1         2 $self->debug_print("Unsubscribing") if DEBUG;
251 1 50       3 die "Cannot unsubscribe if we have no handler" unless $self->{current_handler};
252             $self->instance->unsubscribe_from_event(
253             $self->name => $self->{current_handler}
254 1         3 );
255 1         7 $self
256             }
257              
258             =head2 debug_print
259              
260             Show a debug message, should only be called if the appropriate
261             (compile-time) flag is set:
262              
263             $self->debug_print(...) if DEBUG;
264              
265             rather than expecting
266              
267             $self->debug_print(...);
268              
269             to check for you.
270              
271             Returns $self.
272              
273             =cut
274              
275             sub debug_print {
276 0     0 1   my $self = shift;
277 0           printf "[%s] %s\n", $self->name, join ' ', @_;
278 0           $self
279             }
280              
281             *DESTROY = sub {
282             my $self = shift;
283             $self->debug_print("Destroying");
284             } if DEBUG;
285              
286             1;
287              
288             __END__