line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package MooX::Role::POE::Emitter; |
2
|
|
|
|
|
|
|
$MooX::Role::POE::Emitter::VERSION = '1.001001'; |
3
|
1
|
|
|
1
|
|
9863
|
use strictures 1; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
32
|
|
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
77
|
use feature 'state'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
81
|
|
6
|
1
|
|
|
1
|
|
4
|
use Carp; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
64
|
|
7
|
1
|
|
|
1
|
|
5
|
use Scalar::Util 'reftype'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
70
|
|
8
|
|
|
|
|
|
|
|
9
|
1
|
|
|
1
|
|
893
|
use List::Objects::WithUtils; |
|
1
|
|
|
|
|
677
|
|
|
1
|
|
|
|
|
6
|
|
10
|
1
|
|
|
1
|
|
189805
|
use List::Objects::Types -all; |
|
1
|
|
|
|
|
99413
|
|
|
1
|
|
|
|
|
15
|
|
11
|
1
|
|
|
1
|
|
5103
|
use Types::Standard -types; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
12
|
|
|
|
|
|
|
|
13
|
1
|
|
|
1
|
|
4655
|
use MooX::Role::Pluggable::Constants; |
|
1
|
|
|
|
|
378
|
|
|
1
|
|
|
|
|
85
|
|
14
|
1
|
|
|
1
|
|
741
|
use MooX::Role::POE::Emitter::RegisteredSession; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
49
|
|
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
1
|
|
463
|
use POE; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub E_TAG () { 'Emitter Running' } |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=pod |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=for Pod::Coverage E_TAG |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=cut |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
use Moo::Role; use MooX::late; |
28
|
|
|
|
|
|
|
with 'MooX::Role::Pluggable'; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
has alias => ( |
32
|
|
|
|
|
|
|
lazy => 1, |
33
|
|
|
|
|
|
|
is => 'ro', |
34
|
|
|
|
|
|
|
isa => Str, |
35
|
|
|
|
|
|
|
predicate => 'has_alias', |
36
|
|
|
|
|
|
|
writer => 'set_alias', |
37
|
|
|
|
|
|
|
default => sub { my $self = shift; "$self" }, |
38
|
|
|
|
|
|
|
); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
around set_alias => sub { |
41
|
|
|
|
|
|
|
my ($orig, $self, $value) = @_; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
if ( $poe_kernel->alias_resolve( $self->session_id ) ) { |
44
|
|
|
|
|
|
|
$self->call( __emitter_reset_alias => $value ); |
45
|
|
|
|
|
|
|
$self->emit( $self->event_prefix . 'alias_set' => $value ); |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
$self->$orig($value) |
49
|
|
|
|
|
|
|
}; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
has event_prefix => ( |
52
|
|
|
|
|
|
|
lazy => 1, |
53
|
|
|
|
|
|
|
is => 'ro', |
54
|
|
|
|
|
|
|
isa => Str, |
55
|
|
|
|
|
|
|
predicate => 'has_event_prefix', |
56
|
|
|
|
|
|
|
writer => 'set_event_prefix', |
57
|
|
|
|
|
|
|
default => sub { 'emitted_' }, |
58
|
|
|
|
|
|
|
); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has pluggable_type_prefixes => ( |
61
|
|
|
|
|
|
|
## Optionally remap PROCESS / NOTIFY types |
62
|
|
|
|
|
|
|
lazy => 1, |
63
|
|
|
|
|
|
|
is => 'ro', |
64
|
|
|
|
|
|
|
isa => HashObj, |
65
|
|
|
|
|
|
|
coerce => 1, |
66
|
|
|
|
|
|
|
predicate => 'has_pluggable_type_prefixes', |
67
|
|
|
|
|
|
|
writer => 'set_pluggable_type_prefixes', |
68
|
|
|
|
|
|
|
default => sub { |
69
|
|
|
|
|
|
|
hash( PROCESS => 'P', NOTIFY => 'N' ) |
70
|
|
|
|
|
|
|
}, |
71
|
|
|
|
|
|
|
); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
has object_states => ( |
75
|
|
|
|
|
|
|
lazy => 1, |
76
|
|
|
|
|
|
|
is => 'ro', |
77
|
|
|
|
|
|
|
isa => ArrayObj, |
78
|
|
|
|
|
|
|
coerce => 1, |
79
|
|
|
|
|
|
|
predicate => 'has_object_states', |
80
|
|
|
|
|
|
|
writer => 'set_object_states', |
81
|
|
|
|
|
|
|
trigger => 1, |
82
|
|
|
|
|
|
|
default => sub { array }, |
83
|
|
|
|
|
|
|
); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub _trigger_object_states { |
86
|
|
|
|
|
|
|
my ($self, $states) = @_; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
$states = array(%$states) if reftype $states eq 'HASH'; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
confess "object_states() should be an ARRAY or HASH" |
91
|
|
|
|
|
|
|
unless ref $states and reftype $states eq 'ARRAY'; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$states = array(@$states) unless is_ArrayObj $states; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
state $disallowed = array( qw/ |
96
|
|
|
|
|
|
|
_start |
97
|
|
|
|
|
|
|
_stop |
98
|
|
|
|
|
|
|
_default |
99
|
|
|
|
|
|
|
emit |
100
|
|
|
|
|
|
|
register |
101
|
|
|
|
|
|
|
unregister |
102
|
|
|
|
|
|
|
subscribe |
103
|
|
|
|
|
|
|
unsubscribe |
104
|
|
|
|
|
|
|
/ )->map(sub { $_ => 1 })->inflate; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
my $itr = $states->natatime(2); |
107
|
|
|
|
|
|
|
while (my (undef, $events) = $itr->()) { |
108
|
|
|
|
|
|
|
my $evarr = reftype $events eq 'ARRAY' ? array(@$events) |
109
|
|
|
|
|
|
|
: reftype $events eq 'HASH' ? array(keys %$events) |
110
|
|
|
|
|
|
|
: confess "Expected ARRAY or HASH but got $events"; |
111
|
|
|
|
|
|
|
$evarr->map( |
112
|
|
|
|
|
|
|
sub { confess "Disallowed handler: $_" if $disallowed->exists($_) } |
113
|
|
|
|
|
|
|
); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
has register_prefix => ( |
119
|
|
|
|
|
|
|
lazy => 1, |
120
|
|
|
|
|
|
|
is => 'ro', |
121
|
|
|
|
|
|
|
isa => Str, |
122
|
|
|
|
|
|
|
predicate => 'has_register_prefix', |
123
|
|
|
|
|
|
|
writer => 'set_register_prefix', |
124
|
|
|
|
|
|
|
## Emitter_register / Emitter_unregister |
125
|
|
|
|
|
|
|
default => sub { 'Emitter_' }, |
126
|
|
|
|
|
|
|
); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
has session_id => ( |
129
|
|
|
|
|
|
|
init_arg => undef, |
130
|
|
|
|
|
|
|
lazy => 1, |
131
|
|
|
|
|
|
|
is => 'ro', |
132
|
|
|
|
|
|
|
isa => Defined, |
133
|
|
|
|
|
|
|
predicate => 'has_session_id', |
134
|
|
|
|
|
|
|
writer => 'set_session_id', |
135
|
|
|
|
|
|
|
default => sub { -1 }, |
136
|
|
|
|
|
|
|
); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
has shutdown_signal => ( |
139
|
|
|
|
|
|
|
lazy => 1, |
140
|
|
|
|
|
|
|
is => 'ro', |
141
|
|
|
|
|
|
|
isa => Str, |
142
|
|
|
|
|
|
|
predicate => 'has_shutdown_signal', |
143
|
|
|
|
|
|
|
writer => 'set_shutdown_signal', |
144
|
|
|
|
|
|
|
default => sub { 'SHUTDOWN_EMITTER' }, |
145
|
|
|
|
|
|
|
); |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
has __emitter_reg_sessions => ( |
148
|
|
|
|
|
|
|
lazy => 1, |
149
|
|
|
|
|
|
|
is => 'ro', |
150
|
|
|
|
|
|
|
isa => TypedHash[Object], |
151
|
|
|
|
|
|
|
default => sub { hash_of Object }, |
152
|
|
|
|
|
|
|
); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
has __emitter_reg_events => ( |
156
|
|
|
|
|
|
|
## ->{ $event }->{ $session_id } = 1 |
157
|
|
|
|
|
|
|
lazy => 1, |
158
|
|
|
|
|
|
|
is => 'ro', |
159
|
|
|
|
|
|
|
isa => TypedHash[ TypedHash[Int] ], |
160
|
|
|
|
|
|
|
coerce => 1, |
161
|
|
|
|
|
|
|
default => sub { hash_of TypedHash[Int] }, |
162
|
|
|
|
|
|
|
); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub _start_emitter { |
166
|
|
|
|
|
|
|
## Call to spawn Session. |
167
|
|
|
|
|
|
|
## my $emitter = MyClass->new( |
168
|
|
|
|
|
|
|
## alias => Emitter session alias |
169
|
|
|
|
|
|
|
## event_prefix => Session event prefix (emitted_) |
170
|
|
|
|
|
|
|
## register_prefix => _register/_unregister prefix (Emitter_) |
171
|
|
|
|
|
|
|
## object_states => Extra object_states for Session |
172
|
|
|
|
|
|
|
## )->_start_emitter(); |
173
|
|
|
|
|
|
|
my ($self) = @_; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
my %types; |
176
|
|
|
|
|
|
|
if ( $self->has_pluggable_type_prefixes ) { |
177
|
|
|
|
|
|
|
$types{PROCESS} = $self->pluggable_type_prefixes->{PROCESS} ||= 'P'; |
178
|
|
|
|
|
|
|
$types{NOTIFY} = $self->pluggable_type_prefixes->{NOTIFY} ||= 'N'; |
179
|
|
|
|
|
|
|
} else { |
180
|
|
|
|
|
|
|
%types = ( PROCESS => 'P', NOTIFY => 'N' ); |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
$self->_pluggable_init( |
184
|
|
|
|
|
|
|
event_prefix => $self->event_prefix, |
185
|
|
|
|
|
|
|
reg_prefix => $self->register_prefix, |
186
|
|
|
|
|
|
|
types => \%types, |
187
|
|
|
|
|
|
|
); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
POE::Session->create( |
190
|
|
|
|
|
|
|
object_states => [ |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
$self => { |
193
|
|
|
|
|
|
|
'_start' => '__emitter_start', |
194
|
|
|
|
|
|
|
'_stop' => '__emitter_stop', |
195
|
|
|
|
|
|
|
'shutdown_emitter' => '__shutdown_emitter', |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
'register' => '__emitter_register', |
198
|
|
|
|
|
|
|
'subscribe' => '__emitter_register', |
199
|
|
|
|
|
|
|
'unregister' => '__emitter_unregister', |
200
|
|
|
|
|
|
|
'unsubscribe' => '__emitter_unregister', |
201
|
|
|
|
|
|
|
'emit' => '__emitter_notify', |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
'_default' => '__emitter_disp_default', |
204
|
|
|
|
|
|
|
'__emitter_real_default' => '_emitter_default', |
205
|
|
|
|
|
|
|
}, |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
$self => [ qw/ |
208
|
|
|
|
|
|
|
__emitter_notify |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
__emitter_timer_set |
211
|
|
|
|
|
|
|
__emitter_timer_del |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
__emitter_sigdie |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
__emitter_reset_alias |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
__emitter_sig_shutdown |
218
|
|
|
|
|
|
|
/ ], |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
( |
221
|
|
|
|
|
|
|
$self->has_object_states ? $self->object_states->all : () |
222
|
|
|
|
|
|
|
), |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
], |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
$self |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
around '_pluggable_event' => sub { |
231
|
|
|
|
|
|
|
my ($orig, $self) = splice @_, 0, 2; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
## Overriden from Role::Pluggable |
234
|
|
|
|
|
|
|
## Receives plugin_error, plugin_add etc |
235
|
|
|
|
|
|
|
## Redispatch via emit() |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
$self->emit( @_ ); |
238
|
|
|
|
|
|
|
}; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
### Public: |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub timer { |
244
|
|
|
|
|
|
|
my ($self, $time, $event, @args) = @_; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
confess "timer() expected at least a time and event name" |
247
|
|
|
|
|
|
|
unless defined $time and defined $event; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
$self->call( __emitter_timer_set => $time, $event, @args ) |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub __emitter_timer_set { |
253
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
254
|
|
|
|
|
|
|
my ($time, $event, @args) = @_[ARG0 .. $#_]; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
my $alarm_id = $poe_kernel->delay_set( $event, $time, @args ); |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
$self->emit( $self->event_prefix . 'timer_set', |
259
|
|
|
|
|
|
|
$alarm_id, |
260
|
|
|
|
|
|
|
$event, |
261
|
|
|
|
|
|
|
$time, |
262
|
|
|
|
|
|
|
@args |
263
|
|
|
|
|
|
|
) if $alarm_id; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
$alarm_id |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
sub timer_del { |
269
|
|
|
|
|
|
|
my ($self, $alarm_id) = @_; |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
confess "timer_del() expects an alarm ID" |
272
|
|
|
|
|
|
|
unless defined $alarm_id; |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
$self->call( __emitter_timer_del => $alarm_id ); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub __emitter_timer_del { |
278
|
|
|
|
|
|
|
my ($kernel, $self, $alarm_id) = @_[KERNEL, OBJECT, ARG0]; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
my @deleted = $poe_kernel->alarm_remove($alarm_id); |
281
|
|
|
|
|
|
|
return unless @deleted; |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
my ($event, undef, $params) = @deleted; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
$self->emit( $self->event_prefix . 'timer_deleted', |
286
|
|
|
|
|
|
|
$alarm_id, |
287
|
|
|
|
|
|
|
$event, |
288
|
|
|
|
|
|
|
@{ $params || [] } |
289
|
|
|
|
|
|
|
); |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
$params |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
## yield/call provide post()/call() frontends. |
295
|
|
|
|
|
|
|
sub yield { |
296
|
|
|
|
|
|
|
my ($self, @args) = @_; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
$poe_kernel->post( $self->session_id, @args ); |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
$self |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub call { |
304
|
|
|
|
|
|
|
my ($self, @args) = @_; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
$poe_kernel->call( $self->session_id, @args ); |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
$self |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub emit { |
312
|
|
|
|
|
|
|
## Async NOTIFY event dispatch. |
313
|
|
|
|
|
|
|
my ($self, $event, @args) = @_; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
$self->yield( __emitter_notify => $event, @args ); |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
$self |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
sub emit_now { |
321
|
|
|
|
|
|
|
## Synchronous NOTIFY event dispatch. |
322
|
|
|
|
|
|
|
my ($self, $event, @args) = @_; |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
$self->call( __emitter_notify => $event, @args ); |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
$self |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
sub process { |
330
|
|
|
|
|
|
|
my ($self, $event, @args) = @_; |
331
|
|
|
|
|
|
|
## Dispatch PROCESS events. |
332
|
|
|
|
|
|
|
## process() events should _pluggable_process immediately |
333
|
|
|
|
|
|
|
## and return the EAT value. |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
## Dispatched to P_$event : |
336
|
|
|
|
|
|
|
$self->_pluggable_process( PROCESS => $event, \@args ) |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
## Session ref-counting bits. |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
sub __get_ses_refc { |
344
|
|
|
|
|
|
|
my ($self, $sess_id) = @_; |
345
|
|
|
|
|
|
|
return unless $self->__emitter_reg_sessions->exists($sess_id); |
346
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->get($sess_id)->refcount |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub __reg_ses_id { |
350
|
|
|
|
|
|
|
my ($self, $sess_id) = @_; |
351
|
|
|
|
|
|
|
return if $self->__emitter_reg_sessions->exists($sess_id); |
352
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->set($sess_id => |
353
|
|
|
|
|
|
|
MooX::Role::POE::Emitter::RegisteredSession->new( |
354
|
|
|
|
|
|
|
id => $sess_id, |
355
|
|
|
|
|
|
|
refcount => 0 |
356
|
|
|
|
|
|
|
) |
357
|
|
|
|
|
|
|
); |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
sub __incr_ses_refc { |
361
|
|
|
|
|
|
|
my ($self, $sess_id) = @_; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
my $regsess_obj = $self->__emitter_reg_sessions->get($sess_id); |
364
|
|
|
|
|
|
|
unless (defined $regsess_obj) { |
365
|
|
|
|
|
|
|
confess "BUG; attempted to increase nonexistant refcount for '$sess_id'"; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->set($sess_id => |
369
|
|
|
|
|
|
|
MooX::Role::POE::Emitter::RegisteredSession->new( |
370
|
|
|
|
|
|
|
id => $sess_id, |
371
|
|
|
|
|
|
|
refcount => $regsess_obj->refcount + 1, |
372
|
|
|
|
|
|
|
) |
373
|
|
|
|
|
|
|
); |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->get($sess_id)->refcount |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
sub __decr_ses_refc { |
379
|
|
|
|
|
|
|
my ($self, $sess_id) = @_; |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
my $regsess_obj = $self->__emitter_reg_sessions->get($sess_id); |
382
|
|
|
|
|
|
|
unless (defined $regsess_obj) { |
383
|
|
|
|
|
|
|
confess "BUG; attempted to decrease nonexistant refcount for '$sess_id'" |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->set($sess_id => |
387
|
|
|
|
|
|
|
do { |
388
|
|
|
|
|
|
|
my $refc = $regsess_obj->refcount - 1; |
389
|
|
|
|
|
|
|
$refc = 0 if $refc < 0; # FIXME delete (and return above) instead? |
390
|
|
|
|
|
|
|
MooX::Role::POE::Emitter::RegisteredSession->new( |
391
|
|
|
|
|
|
|
id => $sess_id, |
392
|
|
|
|
|
|
|
refcount => $refc, |
393
|
|
|
|
|
|
|
) |
394
|
|
|
|
|
|
|
}, |
395
|
|
|
|
|
|
|
); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub __emitter_drop_sessions { |
399
|
|
|
|
|
|
|
my ($self) = @_; |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
for my $id ($self->__emitter_reg_sessions->keys->all) { |
402
|
|
|
|
|
|
|
my $count = $self->__get_ses_refc($id); |
403
|
|
|
|
|
|
|
while ( $count-- > 0 ) { |
404
|
|
|
|
|
|
|
$poe_kernel->refcount_decrement( $id, E_TAG ) |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->delete($id) |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
1 |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
## Our Session's handlers: |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
sub __emitter_notify { |
417
|
|
|
|
|
|
|
## Dispatch a NOTIFY event |
418
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
419
|
|
|
|
|
|
|
my ($event, @args) = @_[ARG0 .. $#_]; |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
my $prefix = $self->event_prefix; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
## May have event_prefix (such as $prefix.'plugin_error') |
424
|
|
|
|
|
|
|
substr($event, 0, length($prefix), '') if index($event, $prefix) == 0; |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my %sessions; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
for my $registered_ev ('all', $event) { |
429
|
|
|
|
|
|
|
if (my $sess_hash = $self->__emitter_reg_events->get($registered_ev)) { |
430
|
|
|
|
|
|
|
$sess_hash->keys->visit(sub { $sessions{$_} = 1 }) |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
my $meth = $prefix . $event; |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
## Our own session will get ->event_prefix . $event first |
437
|
|
|
|
|
|
|
$kernel->call( $_[SESSION], $meth, @args ) |
438
|
|
|
|
|
|
|
if delete $sessions{ $_[SESSION]->ID }; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
## Dispatched to N_$event after our Session has been notified: |
441
|
|
|
|
|
|
|
unless ( $self->_pluggable_process('NOTIFY', $event, \@args) == EAT_ALL ) { |
442
|
|
|
|
|
|
|
## Notify subscribed sessions. |
443
|
|
|
|
|
|
|
$kernel->call( $_ => $meth, @args ) for keys %sessions; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
## Received emitted 'shutdown', drop sessions. |
447
|
|
|
|
|
|
|
$self->__emitter_drop_sessions if $event eq 'shutdown'; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
sub __emitter_start { |
451
|
|
|
|
|
|
|
## _start handler |
452
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
453
|
|
|
|
|
|
|
my ($session, $sender) = @_[SESSION, SENDER]; |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
$self->set_session_id( $session->ID ); |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
$kernel->alias_set( $self->alias ); |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
$kernel->sig( DIE => '__emitter_sigdie' ); |
460
|
|
|
|
|
|
|
$kernel->sig( $self->shutdown_signal => '__emitter_sig_shutdown' ); |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
unless ($sender == $kernel) { |
463
|
|
|
|
|
|
|
## Have a parent session. |
464
|
|
|
|
|
|
|
my $s_id = $sender->ID; |
465
|
|
|
|
|
|
|
$kernel->refcount_increment( $s_id, E_TAG ); |
466
|
|
|
|
|
|
|
$self->__reg_ses_id( $s_id ); |
467
|
|
|
|
|
|
|
$self->__incr_ses_refc( $s_id ); |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
## subscribe parent session to all notification events |
470
|
|
|
|
|
|
|
$self->__emitter_reg_events->{all}->{ $s_id } = 1; |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
## Detach child session. |
473
|
|
|
|
|
|
|
$kernel->detach_myself; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
$self->call('emitter_started'); |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
$self |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
sub __emitter_reset_alias { |
482
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
483
|
|
|
|
|
|
|
$kernel->alias_set( $_[ARG0] ); |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
sub __emitter_disp_default { |
487
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
488
|
|
|
|
|
|
|
my ($event, $args) = @_[ARG0, ARG1]; |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
if (ref $event eq 'CODE') { |
491
|
|
|
|
|
|
|
## Anonymous coderef callback. |
492
|
|
|
|
|
|
|
## Cute trick from dngor: |
493
|
|
|
|
|
|
|
## - Shove arguments back into @_ |
494
|
|
|
|
|
|
|
## (starting at ARG0 and replacing ARG0/ARG1) |
495
|
|
|
|
|
|
|
## - Set $_[STATE] to our coderef |
496
|
|
|
|
|
|
|
## (callback sub can retrieve itself via $_[STATE]) |
497
|
|
|
|
|
|
|
## - Replace current subroutine |
498
|
|
|
|
|
|
|
splice @_, ARG0, 2, @$args; |
499
|
|
|
|
|
|
|
$_[STATE] = $event; |
500
|
|
|
|
|
|
|
goto $event |
501
|
|
|
|
|
|
|
} else { |
502
|
|
|
|
|
|
|
$self->call( __emitter_real_default => $event, $args ); |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
sub _emitter_default { |
507
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
508
|
|
|
|
|
|
|
my ($event, $args) = @_[ARG0, ARG1]; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
## Session received an unknown event. |
511
|
|
|
|
|
|
|
## Dispatch it to any appropriate P_$event handlers. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
$self->process( $event, @$args ) |
514
|
|
|
|
|
|
|
unless index($event, '_') == 0 |
515
|
|
|
|
|
|
|
or index($event, 'emitter_') == 0 |
516
|
|
|
|
|
|
|
and $event =~ /(?:started|stopped)$/; |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
sub __emitter_sig_shutdown { |
520
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
521
|
|
|
|
|
|
|
$self->yield( shutdown_emitter => @_[ARG2 .. $#_] ) |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
sub __emitter_sigdie { |
525
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
526
|
|
|
|
|
|
|
my $exh = $_[ARG1]; |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
my $event = $exh->{event}; |
529
|
|
|
|
|
|
|
my $dest_id = $exh->{dest_session}->ID; |
530
|
|
|
|
|
|
|
my $errstr = $exh->{error_str}; |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
warn |
533
|
|
|
|
|
|
|
"SIG_DIE: Event '$event' session '$dest_id'\n", |
534
|
|
|
|
|
|
|
" exception: $errstr\n"; |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
$kernel->sig_handled; |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
sub __emitter_stop { |
540
|
|
|
|
|
|
|
## _stop handler |
541
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
$self->call('emitter_stopped'); |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
sub _shutdown_emitter { |
547
|
|
|
|
|
|
|
## Opposite of _start_emitter |
548
|
|
|
|
|
|
|
my $self = shift; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
$self->call( shutdown_emitter => @_ ); |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
1 |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub __shutdown_emitter { |
556
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
$kernel->alarm_remove_all; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
## Destroy plugin pipeline. |
561
|
|
|
|
|
|
|
$self->_pluggable_destroy; |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
## Notify sessions. |
564
|
|
|
|
|
|
|
$self->emit( shutdown => @_[ARG0 .. $#_] ); |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
## Drop sessions and we're spent. |
567
|
|
|
|
|
|
|
$self->call( unsubscribe => () ); |
568
|
|
|
|
|
|
|
$self->__emitter_drop_sessions; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
## Handlers for listener sessions. |
573
|
|
|
|
|
|
|
sub __emitter_register { |
574
|
|
|
|
|
|
|
my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; |
575
|
|
|
|
|
|
|
my @events = @_[ARG0 .. $#_]; |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
@events = 'all' unless @events; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
my $s_id = $sender->ID; |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
## Add to our known sessions. |
582
|
|
|
|
|
|
|
$self->__reg_ses_id( $s_id ); |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
for my $event (@events) { |
585
|
|
|
|
|
|
|
## Add session to registered event lists. |
586
|
|
|
|
|
|
|
$self->__emitter_reg_events->{$event}->{$s_id} = 1; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
## Make sure registered session hangs around |
589
|
|
|
|
|
|
|
## (until _unregister or shutdown) |
590
|
|
|
|
|
|
|
$kernel->refcount_increment( $s_id, E_TAG ) |
591
|
|
|
|
|
|
|
unless $s_id == $self->session_id |
592
|
|
|
|
|
|
|
or $self->__get_ses_refc($s_id); |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
$self->__incr_ses_refc( $s_id ); |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
$kernel->post( $s_id => $self->event_prefix . 'registered', $self ) |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
sub __emitter_unregister { |
601
|
|
|
|
|
|
|
my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; |
602
|
|
|
|
|
|
|
my @events = @_[ARG0 .. $#_]; |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
## - An unsub without any arguments means "stop sending all events I |
605
|
|
|
|
|
|
|
## have subscribed to" |
606
|
|
|
|
|
|
|
## - An unsub for 'all' means "stop sending events I haven't asked for |
607
|
|
|
|
|
|
|
## by name" |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
@events = $self->__emitter_reg_events->keys->all unless @events; |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
my $s_id = $sender->ID; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
EV: for my $event (@events) { |
614
|
|
|
|
|
|
|
# intentional no Lowu, leave me for autoviv: |
615
|
|
|
|
|
|
|
unless (delete $self->__emitter_reg_events->{$event}->{$s_id}) { |
616
|
|
|
|
|
|
|
next EV |
617
|
|
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# Sessions left for this event? |
620
|
|
|
|
|
|
|
$self->__emitter_reg_events->delete($event) |
621
|
|
|
|
|
|
|
if $self->__emitter_reg_events->get($event)->is_empty; |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
$self->__decr_ses_refc($s_id); |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
unless ($self->__get_ses_refc($s_id)) { |
626
|
|
|
|
|
|
|
## No events left for this session. |
627
|
|
|
|
|
|
|
$self->__emitter_reg_sessions->delete($s_id); |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
$kernel->refcount_decrement( $s_id, E_TAG ) |
630
|
|
|
|
|
|
|
unless $_[SESSION] == $sender; |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
} ## EV |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
1; |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
=pod |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
=for Pod::Coverage has_\S+ |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
=head1 NAME |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
MooX::Role::POE::Emitter - Pluggable POE event emitter role for cows |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
=head1 SYNOPSIS |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
## A POE::Session that can broadcast events to listeners: |
650
|
|
|
|
|
|
|
package My::EventEmitter; |
651
|
|
|
|
|
|
|
use POE; |
652
|
|
|
|
|
|
|
use Moo; |
653
|
|
|
|
|
|
|
with 'MooX::Role::POE::Emitter'; |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
sub spawn { |
656
|
|
|
|
|
|
|
my ($self, %args) = @_; |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
$self->set_object_states( |
659
|
|
|
|
|
|
|
[ |
660
|
|
|
|
|
|
|
$self => { |
661
|
|
|
|
|
|
|
## Add some extra handlers to our Emitter: |
662
|
|
|
|
|
|
|
'emitter_started' => '_emitter_started', |
663
|
|
|
|
|
|
|
'emitter_stopped' => '_emitter_stopped', |
664
|
|
|
|
|
|
|
}, |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
## Include any object_states we had previously |
667
|
|
|
|
|
|
|
## (e.g. states added at construction time): |
668
|
|
|
|
|
|
|
( |
669
|
|
|
|
|
|
|
$self->has_object_states ? |
670
|
|
|
|
|
|
|
@{ $self->object_states } : () |
671
|
|
|
|
|
|
|
), |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
## Maybe include from named arguments, for example: |
674
|
|
|
|
|
|
|
( |
675
|
|
|
|
|
|
|
ref $args{object_states} eq 'ARRAY' ? |
676
|
|
|
|
|
|
|
@{ $args{object_states} } : () |
677
|
|
|
|
|
|
|
), |
678
|
|
|
|
|
|
|
], |
679
|
|
|
|
|
|
|
); |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
## Start our Emitter's POE::Session: |
682
|
|
|
|
|
|
|
$self->_start_emitter; |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
sub shutdown { |
686
|
|
|
|
|
|
|
my ($self) = @_; |
687
|
|
|
|
|
|
|
## .. do some cleanup, whatever .. |
688
|
|
|
|
|
|
|
$self->_shutdown_emitter; |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
sub _emitter_started { |
692
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
693
|
|
|
|
|
|
|
## A POE state called when the emitter's session starts. |
694
|
|
|
|
|
|
|
## (Analogous to a normal '_start' handler) |
695
|
|
|
|
|
|
|
## Could load plugins, do initialization, etc. |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub _emitter_stopped { |
699
|
|
|
|
|
|
|
## Opposite of 'emitter_started' |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
sub do_something { |
703
|
|
|
|
|
|
|
my ($self, @things) = @_; |
704
|
|
|
|
|
|
|
# ... do some work ... |
705
|
|
|
|
|
|
|
# ... emit an event: |
706
|
|
|
|
|
|
|
$self->emit( did_stuff => @things ) |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
## A listening POE::Session: |
710
|
|
|
|
|
|
|
package My::Listener; |
711
|
|
|
|
|
|
|
use POE; |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
sub spawn { |
714
|
|
|
|
|
|
|
# This spawn() takes an alias/session to subscribe to: |
715
|
|
|
|
|
|
|
my ($self, $alias_or_sessionID) = @_; |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
POE::Session->create( |
718
|
|
|
|
|
|
|
## Set up a Session, etc |
719
|
|
|
|
|
|
|
object_states => [ |
720
|
|
|
|
|
|
|
$self => [ |
721
|
|
|
|
|
|
|
'emitted_did_stuff', |
722
|
|
|
|
|
|
|
# ... |
723
|
|
|
|
|
|
|
], |
724
|
|
|
|
|
|
|
], |
725
|
|
|
|
|
|
|
); |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
## Subscribe to all events from $alias_or_sessionID: |
728
|
|
|
|
|
|
|
$poe_kernel->call( |
729
|
|
|
|
|
|
|
$alias_or_sessionID => subscribe => 'all' |
730
|
|
|
|
|
|
|
); |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
sub emitted_did_stuff { |
734
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
735
|
|
|
|
|
|
|
## Received 'did_stuff' from Emitter |
736
|
|
|
|
|
|
|
my @things = @_[ARG0 .. $#_]; |
737
|
|
|
|
|
|
|
# ... |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=head1 DESCRIPTION |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
Consuming this L gives your class a L capable of |
743
|
|
|
|
|
|
|
processing events via loaded plugins and/or emitting them to registered |
744
|
|
|
|
|
|
|
"listener" sessions. |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
It is derived from L by BINGOS, HINRIK, APOCAL |
747
|
|
|
|
|
|
|
et al, but with more cows ;-) and a few extra features (such as anonymous |
748
|
|
|
|
|
|
|
coderef callbacks; see L), as well as the |
749
|
|
|
|
|
|
|
faster plugin dispatch system that comes with L. |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
The Emitter role consumes L, |
752
|
|
|
|
|
|
|
making your emitter pluggable (see the |
753
|
|
|
|
|
|
|
L documentation for plugin-related details). |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
You do not need to create your own L; calling |
756
|
|
|
|
|
|
|
L will spawn one for you. |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
You also get some useful sugar over POE event dispatch; see L. |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
=head2 Creating an Emitter |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
L contains an emitter that uses B methods to |
763
|
|
|
|
|
|
|
configure itself when C is called; attributes can, of course, |
764
|
|
|
|
|
|
|
be set when your Emitter is constructed: |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
my $emitter = MyEmitter->new( |
767
|
|
|
|
|
|
|
alias => 'my_emitter', |
768
|
|
|
|
|
|
|
pluggable_type_prefixes => { |
769
|
|
|
|
|
|
|
NOTIFY => 'Notify', |
770
|
|
|
|
|
|
|
PROCESS => 'Proc', |
771
|
|
|
|
|
|
|
}, |
772
|
|
|
|
|
|
|
# . . . |
773
|
|
|
|
|
|
|
); |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
=head3 Attributes |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
Most of these can be altered via B methods at any time before |
778
|
|
|
|
|
|
|
L is called. Changing an emitter's configuration after it has |
779
|
|
|
|
|
|
|
been started may result in undesirable behavior ;-) |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=head4 alias |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
B specifies the POE::Kernel alias used for our L; |
784
|
|
|
|
|
|
|
defaults to the stringified object. |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
Set via B. If the emitter is running, a prefixed B |
787
|
|
|
|
|
|
|
event is emitted to notify listeners that need to know where to reach the emitter. |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=head4 event_prefix |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
B is prepended to notification events before they are |
792
|
|
|
|
|
|
|
dispatched to listening sessions. It is also used for the plugin |
793
|
|
|
|
|
|
|
pipeline's internal events; see L |
794
|
|
|
|
|
|
|
for details. |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
Defaults to I |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
Set via B |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=head4 pluggable_type_prefixes |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
B is a hash reference that can optionally be set |
803
|
|
|
|
|
|
|
to change the default L plugin handler prefixes for |
804
|
|
|
|
|
|
|
C and C (which default to C and C, respectively): |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
my $emitter = $class->new( |
807
|
|
|
|
|
|
|
pluggable_type_prefixes => { |
808
|
|
|
|
|
|
|
PROCESS => 'P', |
809
|
|
|
|
|
|
|
NOTIFY => 'N', |
810
|
|
|
|
|
|
|
}, |
811
|
|
|
|
|
|
|
); |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
Set via B |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=head4 object_states |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
B is an array reference suitable for passing to |
818
|
|
|
|
|
|
|
L; the subclasses own handlers should be added to |
819
|
|
|
|
|
|
|
B prior to calling L. |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
Set via B |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
=head4 register_prefix |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
B is prepended to 'register' and 'unregister' methods |
826
|
|
|
|
|
|
|
called on plugins at load time (see L). |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
Defaults to I |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
Set via B |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
=head4 session_id |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
B is our emitter's L ID, set when our Session is |
835
|
|
|
|
|
|
|
started via L"_start_emitter">. |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
=head4 shutdown_signal |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
B is the name of the L signal that will trigger a |
840
|
|
|
|
|
|
|
shutdown (used to shut down multiple Emitters). See L"Signals"> |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=head3 _start_emitter |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
B<_start_emitter()> should be called on our object to spawn the actual |
845
|
|
|
|
|
|
|
L. It takes no arguments and should be called after the |
846
|
|
|
|
|
|
|
object has been configured. |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=head3 _shutdown_emitter |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
B<_shutdown_emitter()> must be called to terminate the Emitter's |
851
|
|
|
|
|
|
|
L |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
A 'shutdown' event will be emitted before sessions are dropped. |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
=head2 Listening sessions |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
=head3 Session event subscription |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
An external L can subscribe to receive events via |
860
|
|
|
|
|
|
|
normal POE event dispatch by sending a C: |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
$poe_kernel->post( $emitter->session_id, |
863
|
|
|
|
|
|
|
'subscribe', |
864
|
|
|
|
|
|
|
@events |
865
|
|
|
|
|
|
|
); |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
Listening sessions are consumers; they cannot modify event arguments in |
868
|
|
|
|
|
|
|
any meaningful way, and will receive arguments as-normal (in @_[ARG0 .. |
869
|
|
|
|
|
|
|
$#_] like any other POE state). Plugins operate differently and receive |
870
|
|
|
|
|
|
|
references to arguments that can be modified -- see |
871
|
|
|
|
|
|
|
L for details. |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
=head3 Session event unregistration |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
An external Session can unregister subscribed events using the same syntax |
876
|
|
|
|
|
|
|
as above: |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
$poe_kernel->post( $emitter->session_id, |
879
|
|
|
|
|
|
|
'unsubscribe', |
880
|
|
|
|
|
|
|
@events |
881
|
|
|
|
|
|
|
); |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
If no events are specified, then any previously subscribed events are |
884
|
|
|
|
|
|
|
unregistered. |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
Note that unsubscribing from 'all' does not carry the same behavior; that |
887
|
|
|
|
|
|
|
is to say, a subscriber can subscribe/unsubscribe for 'all' separately from |
888
|
|
|
|
|
|
|
some set of specifically named events. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
=head2 Receiving events |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
=head3 Events delivered to listeners |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
Events are delivered to subscribed listener sessions as normal POE events, |
895
|
|
|
|
|
|
|
with the configured L prepended and arguments available via |
896
|
|
|
|
|
|
|
C< @_[ARG0 .. $#_] > as normal. |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
sub emitted_my_event { |
899
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
900
|
|
|
|
|
|
|
my @args = @_[ARG0 .. $#_]; |
901
|
|
|
|
|
|
|
# . . . |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
See L"Session event subscription"> and L"emit"> |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
=head3 Events delivered to this session |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
The emitter's L provides a '_default' handler that |
909
|
|
|
|
|
|
|
redispatches unknown POE-delivered events to L |
910
|
|
|
|
|
|
|
(except for events prefixed with '_', which are reserved). |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
You can change this behavior by overriding '_emitter_default' -- here's a |
913
|
|
|
|
|
|
|
direct adaption of the example from L: |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
use Moo; |
916
|
|
|
|
|
|
|
use POE; |
917
|
|
|
|
|
|
|
with 'MooX::Role::POE::Emitter'; |
918
|
|
|
|
|
|
|
around '_emitter_default' => sub { |
919
|
|
|
|
|
|
|
my $orig = shift; |
920
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
921
|
|
|
|
|
|
|
my ($event, $args) = @_[ARG0, ARG1]; |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
## process(), then do something else, for example |
924
|
|
|
|
|
|
|
return if $self->process( $event, @$args ) == EAT_ALL; |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
. . . |
927
|
|
|
|
|
|
|
}; |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
(Note that due to internal redispatch $_[SENDER] will be the Emitter's |
930
|
|
|
|
|
|
|
Session.) |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
=head2 EAT values |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
L uses C constants to indicate event |
935
|
|
|
|
|
|
|
lifetime. |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
If a plugin in the pipeline returns EAT_CLIENT or EAT_ALL, events |
938
|
|
|
|
|
|
|
are not dispatched to subscribed listening sessions; a dispatched NOTIFY |
939
|
|
|
|
|
|
|
event goes to your emitter's Session if it is subscribed to receive it, |
940
|
|
|
|
|
|
|
then to the plugin pipeline, and finally to other subscribed listener |
941
|
|
|
|
|
|
|
Sessions B a plugin returned EAT_CLIENT or EAT_ALL. |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
See L"emit"> for more on dispatch behavior and event lifetime. See |
944
|
|
|
|
|
|
|
L for details regarding plugins. |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
=head3 NOTIFY events |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
B events are intended to be dispatched asynchronously to our own |
949
|
|
|
|
|
|
|
session, any loaded plugins in the pipeline, and subscribed listening |
950
|
|
|
|
|
|
|
sessions, respectively. |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
See L. |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
=head3 PROCESS events |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
B events are intended to be processed by the plugin pipeline |
957
|
|
|
|
|
|
|
immediately; these are intended for message processing and similar |
958
|
|
|
|
|
|
|
synchronous action handled by plugins. |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
Handlers for B events are prefixed with C |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
See L. |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
=head2 Sending events |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
=head3 emit |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
$self->emit( $event, @args ); |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
B dispatches L"NOTIFY events"> -- these events are dispatched |
971
|
|
|
|
|
|
|
first to our own session (with L prepended), then any |
972
|
|
|
|
|
|
|
loaded plugins in the pipeline (with C prepended), then registered |
973
|
|
|
|
|
|
|
sessions (with L prepended): |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
## With default event_prefix: |
976
|
|
|
|
|
|
|
$self->emit( 'my_event', @args ) |
977
|
|
|
|
|
|
|
# -> Dispatched to own session as 'emitted_my_event' |
978
|
|
|
|
|
|
|
# -> Dispatched to plugin pipeline as 'N_my_event' |
979
|
|
|
|
|
|
|
# -> Dispatched to registered sessions as 'emitted_my_event' |
980
|
|
|
|
|
|
|
# *unless* a plugin returned EAT_CLIENT or EAT_ALL |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
See L"Receiving events">, L"EAT values"> |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
=head3 emit_now |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
$self->emit_now( $event, @args ); |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
B synchronously dispatches L"NOTIFY events"> -- see |
989
|
|
|
|
|
|
|
L. |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
=head3 process |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
$self->process( $event, @args ); |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
B calls registered plugin handlers for L"PROCESS events"> |
996
|
|
|
|
|
|
|
immediately; these are B dispatched to listening sessions. |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
Returns the same value as L. |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
See L for details on pluggable |
1001
|
|
|
|
|
|
|
event dispatch. |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
=head2 Methods |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
These methods provide easy proxy mechanisms for issuing POE events and |
1006
|
|
|
|
|
|
|
managing timers within the context of the emitter's L. |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
=head3 yield |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
$self->yield( $poe_event, @args ); |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
Provides an interface to L's yield/post() method, dispatching |
1013
|
|
|
|
|
|
|
POE events within the context of the emitter's session. |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
The event can be either a named event/state dispatched to your Emitter's |
1016
|
|
|
|
|
|
|
L: |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
$emitter->yield( 'some_event', @args ); |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
... or an anonymous coderef, which is executed as if it were a named |
1021
|
|
|
|
|
|
|
POE state belonging to your Emitter: |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
$emitter->yield( sub { |
1024
|
|
|
|
|
|
|
## $_[OBJECT] is the Emitter's object: |
1025
|
|
|
|
|
|
|
my ($kernel, $self) = @_[KERNEL, OBJECT]; |
1026
|
|
|
|
|
|
|
my @params = @_[ARG0 .. $#_]; |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
## $_[STATE] is the current coderef |
1029
|
|
|
|
|
|
|
## Yield ourselves again, for example: |
1030
|
|
|
|
|
|
|
$self->yield( $_[STATE], @new_args ) |
1031
|
|
|
|
|
|
|
if $some_condition; |
1032
|
|
|
|
|
|
|
}, $some, $args ); |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
Inside an anonymous coderef callback such as shown above, C<$_[OBJECT]> is |
1035
|
|
|
|
|
|
|
the Emitter's C<$self> object and C<$_[STATE]> contains the callback |
1036
|
|
|
|
|
|
|
coderef itself. |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=head3 call |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
$self->call( $poe_event, @args ); |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
The synchronous counterpart to L. |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
=head3 timer |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
my $alarm_id = $self->timer( |
1047
|
|
|
|
|
|
|
$delayed_seconds, |
1048
|
|
|
|
|
|
|
$event, |
1049
|
|
|
|
|
|
|
@args |
1050
|
|
|
|
|
|
|
); |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
Set a timer in the context of the emitter's L. Returns the |
1053
|
|
|
|
|
|
|
POE alarm ID. |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
The event can be either a named event/state or an anonymous coderef (see |
1056
|
|
|
|
|
|
|
L). |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
A prefixed (L) 'timer_set' event is emitted when a timer is |
1059
|
|
|
|
|
|
|
set. Arguments are the alarm ID, the event name or coderef, the delay time, |
1060
|
|
|
|
|
|
|
and any event parameters, respectively. |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
=head3 timer_del |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
$self->timer_del( $alarm_id ); |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
Clears a pending L. |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
A prefixed (L) 'timer_deleted' event is emitted when a timer |
1069
|
|
|
|
|
|
|
is deleted. Arguments are the removed alarm ID, the event name or coderef, |
1070
|
|
|
|
|
|
|
and any event parameters, respectively. |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
=head2 Signals |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
=head3 Shutdown Signal |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
The attribute L defines a POE signal that will trigger a |
1077
|
|
|
|
|
|
|
shutdown; it defaults to C: |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
## Shutdown *all* emitters (with a default shutdown_signal()): |
1080
|
|
|
|
|
|
|
$poe_kernel->signal( $poe_kernel, 'SHUTDOWN_EMITTER' ); |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
See L for details on L signals. |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
=head1 SEE ALSO |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
For details regarding POE, see L, L, L |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
For details regarding Moo classes and Roles, see L, L, |
1089
|
|
|
|
|
|
|
L |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
=head1 AUTHOR |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
Jon Portnoy |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
Written from the ground up, but conceptually derived from |
1096
|
|
|
|
|
|
|
L-0.06 by BINGOS, HINRIK, |
1097
|
|
|
|
|
|
|
APOCAL et al. That will probably do you for non-Moo(se) use cases; I |
1098
|
|
|
|
|
|
|
needed something cow-like that worked with L. |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
Licensed under the same terms as perl5 |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
=cut |
1103
|
|
|
|
|
|
|
|