line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Kernel; |
2
|
|
|
|
|
|
|
|
3
|
178
|
|
|
178
|
|
82433
|
use strict; |
|
178
|
|
|
|
|
231
|
|
|
178
|
|
|
|
|
6274
|
|
4
|
|
|
|
|
|
|
|
5
|
178
|
|
|
178
|
|
648
|
use vars qw($VERSION); |
|
178
|
|
|
|
|
204
|
|
|
178
|
|
|
|
|
8571
|
|
6
|
|
|
|
|
|
|
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places) |
7
|
|
|
|
|
|
|
|
8
|
178
|
|
|
178
|
|
3728
|
use POE::Resource::Clock qw( monotime sleep mono2wall wall2mono walltime time ); |
|
178
|
|
|
|
|
309
|
|
|
178
|
|
|
|
|
10359
|
|
9
|
|
|
|
|
|
|
|
10
|
178
|
|
|
178
|
|
736
|
use POSIX qw(uname); |
|
178
|
|
|
|
|
207
|
|
|
178
|
|
|
|
|
1204
|
|
11
|
178
|
|
|
178
|
|
39258
|
use Errno qw(ESRCH EINTR ECHILD EPERM EINVAL EEXIST EAGAIN EWOULDBLOCK); |
|
178
|
|
|
|
|
267
|
|
|
178
|
|
|
|
|
10248
|
|
12
|
178
|
|
|
178
|
|
759
|
use Carp qw(carp croak confess cluck); |
|
178
|
|
|
|
|
253
|
|
|
178
|
|
|
|
|
9739
|
|
13
|
178
|
|
|
178
|
|
82667
|
use Sys::Hostname qw(hostname); |
|
178
|
|
|
|
|
152672
|
|
|
178
|
|
|
|
|
9017
|
|
14
|
178
|
|
|
178
|
|
931
|
use IO::Handle (); |
|
178
|
|
|
|
|
205
|
|
|
178
|
|
|
|
|
2065
|
|
15
|
178
|
|
|
178
|
|
12693
|
use File::Spec (); |
|
178
|
|
|
|
|
202
|
|
|
178
|
|
|
|
|
3070
|
|
16
|
|
|
|
|
|
|
#use Time::HiRes qw(time sleep); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# People expect these to be lexical. |
19
|
|
|
|
|
|
|
|
20
|
178
|
|
|
178
|
|
629
|
use vars qw($poe_kernel $poe_main_window); |
|
178
|
|
|
|
|
193
|
|
|
178
|
|
|
|
|
16187
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
23
|
|
|
|
|
|
|
# A cheezy exporter to avoid using Exporter. |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my $queue_class; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
BEGIN { |
28
|
178
|
|
|
178
|
|
323
|
eval { |
29
|
178
|
|
|
|
|
30136
|
require POE::XS::Queue::Array; |
30
|
0
|
|
|
|
|
0
|
POE::XS::Queue::Array->import(); |
31
|
0
|
|
|
|
|
0
|
$queue_class = "POE::XS::Queue::Array"; |
32
|
|
|
|
|
|
|
}; |
33
|
178
|
50
|
|
|
|
917
|
unless ($queue_class) { |
34
|
178
|
|
|
|
|
69303
|
require POE::Queue::Array; |
35
|
178
|
|
|
|
|
917
|
POE::Queue::Array->import(); |
36
|
178
|
|
|
|
|
10609
|
$queue_class = "POE::Queue::Array"; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub import { |
41
|
510
|
|
|
510
|
|
2868
|
my ($class, $args) = ($poe_kernel, @_[1..$#_]); |
42
|
510
|
|
|
|
|
1104
|
my $package = caller(); |
43
|
|
|
|
|
|
|
|
44
|
510
|
100
|
100
|
|
|
2279
|
croak "POE::Kernel expects its arguments in a hash ref" |
45
|
|
|
|
|
|
|
if ($args && ref($args) ne 'HASH'); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
{ |
48
|
178
|
|
|
178
|
|
899
|
no strict 'refs'; |
|
178
|
|
|
|
|
238
|
|
|
178
|
|
|
|
|
39810
|
|
|
509
|
|
|
|
|
678
|
|
49
|
509
|
|
|
|
|
814
|
*{ $package . '::poe_kernel' } = \$poe_kernel; |
|
509
|
|
|
|
|
2497
|
|
50
|
509
|
|
|
|
|
858
|
*{ $package . '::poe_main_window' } = \$poe_main_window; |
|
509
|
|
|
|
|
1776
|
|
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# Extract the import arguments we're interested in here. |
54
|
|
|
|
|
|
|
|
55
|
509
|
|
100
|
|
|
3704
|
my $loop = delete $args->{loop} || $ENV{POE_EVENT_LOOP}; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# Don't accept unknown/mistyped arguments. |
58
|
|
|
|
|
|
|
|
59
|
509
|
|
|
|
|
2124
|
my @unknown = sort keys %$args; |
60
|
509
|
100
|
|
|
|
1544
|
croak "Unknown POE::Kernel import arguments: @unknown" if @unknown; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# Now do things with them. |
63
|
|
|
|
|
|
|
|
64
|
508
|
100
|
|
|
|
102459
|
unless (UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop')) { |
65
|
178
|
100
|
|
|
|
584
|
if (defined $loop) { |
66
|
6
|
|
|
|
|
33
|
$loop =~ s/^(POE::)?(XS::)?(Loop::)?//; |
67
|
6
|
50
|
|
|
|
28
|
if (defined $2) { |
68
|
0
|
|
|
|
|
0
|
$loop = "POE::XS::Loop::$loop"; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
else { |
71
|
6
|
|
|
|
|
12
|
$loop = "POE::Loop::$loop"; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
} |
74
|
178
|
|
|
|
|
609
|
_test_loop($loop); |
75
|
|
|
|
|
|
|
# Bootstrap the kernel. This is inherited from a time when multiple |
76
|
|
|
|
|
|
|
# kernels could be present in the same Perl process. |
77
|
176
|
50
|
|
|
|
2148
|
POE::Kernel->new() if UNIVERSAL::can('POE::Kernel', 'poe_kernel_loop'); |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
82
|
|
|
|
|
|
|
# Perform some optional setup. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
BEGIN { |
85
|
178
|
|
|
178
|
|
837
|
local $SIG{'__DIE__'} = 'DEFAULT'; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
{ |
88
|
178
|
|
|
178
|
|
850
|
no strict 'refs'; |
|
178
|
|
|
|
|
249
|
|
|
178
|
|
|
|
|
12476
|
|
|
178
|
|
|
|
|
323
|
|
89
|
178
|
50
|
|
|
|
836
|
if ($^O eq 'MSWin32') { |
90
|
0
|
|
|
|
|
0
|
*{ __PACKAGE__ . '::RUNNING_IN_HELL' } = sub { 1 }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
91
|
|
|
|
|
|
|
} else { |
92
|
178
|
|
|
3184
|
|
3722
|
*{ __PACKAGE__ . '::RUNNING_IN_HELL' } = sub { 0 }; |
|
178
|
|
|
|
|
5356
|
|
|
3184
|
|
|
|
|
15735
|
|
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
BEGIN { |
98
|
|
|
|
|
|
|
# The entire BEGIN block is a no-strict-refs zone. |
99
|
|
|
|
|
|
|
|
100
|
178
|
|
|
178
|
|
847
|
no strict 'refs'; |
|
178
|
|
|
|
|
283
|
|
|
178
|
|
|
|
|
47112
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# Set up a constant that lets the user deactivate automatic |
103
|
|
|
|
|
|
|
# exception handling. |
104
|
|
|
|
|
|
|
|
105
|
178
|
100
|
|
178
|
|
708
|
unless (defined &CATCH_EXCEPTIONS) { |
106
|
170
|
100
|
|
|
|
639
|
my $catch_exceptions = ( |
107
|
|
|
|
|
|
|
(exists $ENV{POE_CATCH_EXCEPTIONS}) |
108
|
|
|
|
|
|
|
? $ENV{POE_CATCH_EXCEPTIONS} |
109
|
|
|
|
|
|
|
: 1 |
110
|
|
|
|
|
|
|
); |
111
|
|
|
|
|
|
|
|
112
|
170
|
100
|
|
|
|
362
|
if ($catch_exceptions) { |
113
|
169
|
|
|
|
|
396
|
*CATCH_EXCEPTIONS = sub () { 1 }; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
else { |
116
|
1
|
|
|
|
|
2
|
*CATCH_EXCEPTIONS = sub () { 0 }; |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
178
|
50
|
|
|
|
618
|
unless (defined &CHILD_POLLING_INTERVAL) { |
121
|
|
|
|
|
|
|
# That's one second, not a true value. |
122
|
178
|
|
|
|
|
283
|
*CHILD_POLLING_INTERVAL = sub () { 1 }; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
178
|
100
|
|
|
|
464
|
unless (defined &USE_SIGCHLD) { |
126
|
|
|
|
|
|
|
# Perl >= 5.7.3 has safe signals support |
127
|
|
|
|
|
|
|
# perlipc.pod#Deferred_Signals_(Safe_Signals) |
128
|
|
|
|
|
|
|
# We decided to target 5.8.1 just to be safe :) |
129
|
162
|
50
|
33
|
|
|
960
|
if ( $] >= 5.008001 and not RUNNING_IN_HELL ) { |
130
|
162
|
|
|
|
|
262
|
*USE_SIGCHLD = sub () { 1 }; |
131
|
|
|
|
|
|
|
} else { |
132
|
0
|
|
|
|
|
0
|
*USE_SIGCHLD = sub () { 0 }; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
178
|
100
|
|
|
|
606
|
unless (defined &USE_SIGNAL_PIPE) { |
137
|
175
|
|
|
|
|
359
|
my $use_signal_pipe; |
138
|
175
|
50
|
|
|
|
561
|
if ( exists $ENV{POE_USE_SIGNAL_PIPE} ) { |
139
|
0
|
|
|
|
|
0
|
$use_signal_pipe = $ENV{POE_USE_SIGNAL_PIPE}; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
175
|
50
|
|
|
|
308
|
if (RUNNING_IN_HELL) { |
143
|
0
|
0
|
|
|
|
0
|
if ($use_signal_pipe) { |
144
|
0
|
|
|
|
|
0
|
_warn( |
145
|
|
|
|
|
|
|
"Sorry, disabling USE_SIGNAL_PIPE on $^O.\n", |
146
|
|
|
|
|
|
|
"Programs are reported to hang when it's enabled.\n", |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# Must be defined to supersede the default. |
151
|
0
|
|
|
|
|
0
|
$use_signal_pipe = 0; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
175
|
50
|
33
|
|
|
931
|
if ($use_signal_pipe or not defined $use_signal_pipe) { |
155
|
175
|
|
|
|
|
6039
|
*USE_SIGNAL_PIPE = sub () { 1 }; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
else { |
158
|
0
|
|
|
|
|
0
|
*USE_SIGNAL_PIPE = sub () { 0 }; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
#============================================================================== |
164
|
|
|
|
|
|
|
# Globals, or at least package-scoped things. Data structures were |
165
|
|
|
|
|
|
|
# moved into lexicals in 0.1201. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# A reference to the currently active session. Used throughout the |
168
|
|
|
|
|
|
|
# functions that act on the current session. |
169
|
|
|
|
|
|
|
my $kr_active_session; |
170
|
|
|
|
|
|
|
my $kr_active_event; |
171
|
|
|
|
|
|
|
my $kr_active_event_type; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
# Needs to be lexical so that POE::Resource::Events can see it |
174
|
|
|
|
|
|
|
# change. TODO - Something better? Maybe we call a method in |
175
|
|
|
|
|
|
|
# POE::Resource::Events to trigger the exception there? |
176
|
178
|
|
|
178
|
|
817
|
use vars qw($kr_exception); |
|
178
|
|
|
|
|
207
|
|
|
178
|
|
|
|
|
125695
|
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# The Kernel's master queue. |
179
|
|
|
|
|
|
|
my $kr_queue; |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# The current PID, to detect when it changes |
182
|
|
|
|
|
|
|
my $kr_pid; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Filehandle activity modes. They are often used as list indexes. |
185
|
|
|
|
|
|
|
sub MODE_RD () { 0 } # read |
186
|
|
|
|
|
|
|
sub MODE_WR () { 1 } # write |
187
|
|
|
|
|
|
|
sub MODE_EX () { 2 } # exception/expedite |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
190
|
|
|
|
|
|
|
# Kernel structure. This is the root of a large data tree. Dumping |
191
|
|
|
|
|
|
|
# $poe_kernel with Data::Dumper or something will show most of the |
192
|
|
|
|
|
|
|
# data that POE keeps track of. The exceptions to this are private |
193
|
|
|
|
|
|
|
# storage in some of the leaf objects, such as POE::Wheel. All its |
194
|
|
|
|
|
|
|
# members are described in detail further on. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
my $kr_id_seq = 0; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub KR_SESSIONS () { 0 } # [ \%kr_sessions, |
199
|
|
|
|
|
|
|
sub KR_FILENOS () { 1 } # \%kr_filenos, |
200
|
|
|
|
|
|
|
sub KR_SIGNALS () { 2 } # \%kr_signals, |
201
|
|
|
|
|
|
|
sub KR_ALIASES () { 3 } # \%kr_aliases, |
202
|
|
|
|
|
|
|
sub KR_ACTIVE_SESSION () { 4 } # \$kr_active_session, |
203
|
|
|
|
|
|
|
sub KR_QUEUE () { 5 } # \$kr_queue, |
204
|
|
|
|
|
|
|
sub KR_ID () { 6 } # $unique_kernel_id, |
205
|
|
|
|
|
|
|
sub KR_SESSION_IDS () { 7 } # \%kr_session_ids, |
206
|
|
|
|
|
|
|
sub KR_SID_SEQ () { 8 } # \$kr_sid_seq, |
207
|
|
|
|
|
|
|
sub KR_EXTRA_REFS () { 9 } # \$kr_extra_refs, |
208
|
|
|
|
|
|
|
sub KR_SIZE () { 10 } # XXX UNUSED ??? |
209
|
|
|
|
|
|
|
sub KR_RUN () { 11 } # \$kr_run_warning |
210
|
|
|
|
|
|
|
sub KR_ACTIVE_EVENT () { 12 } # \$kr_active_event |
211
|
|
|
|
|
|
|
sub KR_PIDS () { 13 } # \%kr_pids_to_events |
212
|
|
|
|
|
|
|
sub KR_ACTIVE_EVENT_TYPE () { 14 } # \$kr_active_event_type |
213
|
|
|
|
|
|
|
# ] |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# This flag indicates that POE::Kernel's run() method was called. |
216
|
|
|
|
|
|
|
# It's used to warn about forgetting $poe_kernel->run(). |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub KR_RUN_CALLED () { 0x01 } # $kernel->run() called |
219
|
|
|
|
|
|
|
sub KR_RUN_SESSION () { 0x02 } # sessions created |
220
|
|
|
|
|
|
|
sub KR_RUN_DONE () { 0x04 } # run returned |
221
|
|
|
|
|
|
|
my $kr_run_warning = 0; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
224
|
|
|
|
|
|
|
# Events themselves. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub EV_SESSION () { 0 } # [ $destination_session, |
227
|
|
|
|
|
|
|
sub EV_SOURCE () { 1 } # $sender_session, |
228
|
|
|
|
|
|
|
sub EV_NAME () { 2 } # $event_name, |
229
|
|
|
|
|
|
|
sub EV_TYPE () { 3 } # $event_type, |
230
|
|
|
|
|
|
|
sub EV_ARGS () { 4 } # \@event_parameters_arg0_etc, |
231
|
|
|
|
|
|
|
# |
232
|
|
|
|
|
|
|
# (These fields go towards the end |
233
|
|
|
|
|
|
|
# because they are optional in some |
234
|
|
|
|
|
|
|
# cases. TODO: Is this still true?) |
235
|
|
|
|
|
|
|
# |
236
|
|
|
|
|
|
|
sub EV_OWNER_FILE () { 5 } # $caller_filename_where_enqueued, |
237
|
|
|
|
|
|
|
sub EV_OWNER_LINE () { 6 } # $caller_line_where_enqueued, |
238
|
|
|
|
|
|
|
sub EV_FROMSTATE () { 7 } # $fromstate |
239
|
|
|
|
|
|
|
sub EV_SEQ () { 8 } # Maintained by POE::Queue (unique event ID) |
240
|
|
|
|
|
|
|
sub EV_WALLTIME () { 9 } # Walltime when event was created (for alarms) |
241
|
|
|
|
|
|
|
sub EV_DELTA () { 10 } # Seconds past walltime for event (for alarms) |
242
|
|
|
|
|
|
|
# ] |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# These are the names of POE's internal events. They're in constants |
245
|
|
|
|
|
|
|
# so we don't mistype them again. |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub EN_CHILD () { '_child' } |
248
|
|
|
|
|
|
|
sub EN_GC () { '_garbage_collect' } |
249
|
|
|
|
|
|
|
sub EN_PARENT () { '_parent' } |
250
|
|
|
|
|
|
|
sub EN_SCPOLL () { '_sigchld_poll' } |
251
|
|
|
|
|
|
|
sub EN_SIGNAL () { '_signal' } |
252
|
|
|
|
|
|
|
sub EN_START () { '_start' } |
253
|
|
|
|
|
|
|
sub EN_STOP () { '_stop' } |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# These are POE's event classes (types). They often shadow the event |
256
|
|
|
|
|
|
|
# names themselves, but they can encompass a large group of events. |
257
|
|
|
|
|
|
|
# For example, ET_ALARM describes anything enqueued as by an alarm |
258
|
|
|
|
|
|
|
# call. Types are preferred over names because bitmask tests are |
259
|
|
|
|
|
|
|
# faster than string equality tests. |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub ET_POST () { 0x0001 } # User events (posted, yielded). |
262
|
|
|
|
|
|
|
sub ET_CALL () { 0x0002 } # User events that weren't enqueued. |
263
|
|
|
|
|
|
|
sub ET_START () { 0x0004 } # _start |
264
|
|
|
|
|
|
|
sub ET_STOP () { 0x0008 } # _stop |
265
|
|
|
|
|
|
|
sub ET_SIGNAL () { 0x0010 } # _signal |
266
|
|
|
|
|
|
|
sub ET_GC () { 0x0020 } # _garbage_collect |
267
|
|
|
|
|
|
|
sub ET_PARENT () { 0x0040 } # _parent |
268
|
|
|
|
|
|
|
sub ET_CHILD () { 0x0080 } # _child |
269
|
|
|
|
|
|
|
sub ET_SCPOLL () { 0x0100 } # _sigchild_poll |
270
|
|
|
|
|
|
|
sub ET_ALARM () { 0x0200 } # Alarm events. |
271
|
|
|
|
|
|
|
sub ET_SELECT () { 0x0400 } # File activity events. |
272
|
|
|
|
|
|
|
sub ET_SIGCLD () { 0x0800 } # sig_child() events. |
273
|
|
|
|
|
|
|
sub ET_SIGDIE () { 0x1000 } # SIGDIE exception events. |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# A mask for all events generated by/for users. |
276
|
|
|
|
|
|
|
sub ET_MASK_USER () { ~(ET_GC | ET_SCPOLL) } |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# A mask for all events that are delayed by a dispatch time. |
279
|
|
|
|
|
|
|
sub ET_MASK_DELAYED () { ET_ALARM | ET_SCPOLL } |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
# Temporary signal subtypes, used during signal dispatch semantics |
282
|
|
|
|
|
|
|
# deprecation and reformation. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
sub ET_SIGNAL_RECURSIVE () { 0x2000 } # Explicitly requested signal. |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# A hash of reserved names. It's used to test whether someone is |
287
|
|
|
|
|
|
|
# trying to use an internal event directly. |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
my %poes_own_events = ( |
290
|
|
|
|
|
|
|
+EN_CHILD => 1, |
291
|
|
|
|
|
|
|
+EN_GC => 1, |
292
|
|
|
|
|
|
|
+EN_PARENT => 1, |
293
|
|
|
|
|
|
|
+EN_SCPOLL => 1, |
294
|
|
|
|
|
|
|
+EN_SIGNAL => 1, |
295
|
|
|
|
|
|
|
+EN_START => 1, |
296
|
|
|
|
|
|
|
+EN_STOP => 1, |
297
|
|
|
|
|
|
|
+EN_STAT => 1, |
298
|
|
|
|
|
|
|
); |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# These are ways a child may come or go. |
301
|
|
|
|
|
|
|
# TODO - It would be useful to split 'lose' into two types. One to |
302
|
|
|
|
|
|
|
# indicate that the child has stopped, and one to indicate that it was |
303
|
|
|
|
|
|
|
# given away. |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub CHILD_GAIN () { 'gain' } # The session was inherited from another. |
306
|
|
|
|
|
|
|
sub CHILD_LOSE () { 'lose' } # The session is no longer this one's child. |
307
|
|
|
|
|
|
|
sub CHILD_CREATE () { 'create' } # The session was created as a child of this. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# Argument offsets for different types of internally generated events. |
310
|
|
|
|
|
|
|
# TODO Exporting (EXPORT_OK) these would let people stop depending on |
311
|
|
|
|
|
|
|
# positions for them. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub EA_SEL_HANDLE () { 0 } |
314
|
|
|
|
|
|
|
sub EA_SEL_MODE () { 1 } |
315
|
|
|
|
|
|
|
sub EA_SEL_ARGS () { 2 } |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
318
|
|
|
|
|
|
|
# Debugging and configuration constants. |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
# Shorthand for defining a trace constant. |
321
|
|
|
|
|
|
|
sub _define_trace { |
322
|
178
|
|
|
178
|
|
873
|
no strict 'refs'; |
|
178
|
|
|
|
|
204
|
|
|
178
|
|
|
|
|
20896
|
|
323
|
178
|
|
|
178
|
|
415
|
foreach my $name (@_) { |
324
|
1424
|
50
|
|
|
|
1053
|
next if defined *{"TRACE_$name"}{CODE}; |
|
1424
|
|
|
|
|
4949
|
|
325
|
1424
|
|
|
|
|
2436
|
my $trace_value = &TRACE_DEFAULT; |
326
|
1424
|
|
|
|
|
1435
|
my $trace_name = "TRACE_$name"; |
327
|
1424
|
|
|
0
|
|
6980
|
*$trace_name = sub () { $trace_value }; |
|
0
|
|
|
|
|
0
|
|
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
# Debugging flags for subsystems. They're done as double evals here |
332
|
|
|
|
|
|
|
# so that someone may define them before using POE::Kernel (or POE), |
333
|
|
|
|
|
|
|
# and the pre-defined value will take precedence over the defaults |
334
|
|
|
|
|
|
|
# here. |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
my $trace_file_handle; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
BEGIN { |
339
|
|
|
|
|
|
|
# Shorthand for defining an assert constant. |
340
|
|
|
|
|
|
|
sub _define_assert { |
341
|
178
|
|
|
178
|
|
811
|
no strict 'refs'; |
|
178
|
|
|
|
|
260
|
|
|
178
|
|
|
|
|
30285
|
|
342
|
178
|
|
|
178
|
|
359
|
foreach my $name (@_) { |
343
|
890
|
100
|
|
|
|
711
|
next if defined *{"ASSERT_$name"}{CODE}; |
|
890
|
|
|
|
|
3924
|
|
344
|
887
|
|
|
|
|
1176
|
my $assert_value = &ASSERT_DEFAULT; |
345
|
887
|
|
|
|
|
926
|
my $assert_name = "ASSERT_$name"; |
346
|
887
|
|
|
0
|
|
184294
|
*$assert_name = sub () { $assert_value }; |
|
0
|
|
|
|
|
0
|
|
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# Assimilate POE_TRACE_* and POE_ASSERT_* environment variables. |
351
|
|
|
|
|
|
|
# Environment variables override everything else. |
352
|
178
|
|
|
178
|
|
1213
|
while (my ($var, $val) = each %ENV) { |
353
|
3927
|
100
|
|
|
|
11531
|
next unless $var =~ /^POE_([A-Z_]+)$/; |
354
|
|
|
|
|
|
|
|
355
|
11
|
|
|
|
|
32
|
my $const = $1; |
356
|
|
|
|
|
|
|
|
357
|
178
|
100
|
33
|
178
|
|
875
|
next unless $const =~ /^(?:TRACE|ASSERT)_/ or do { no strict 'refs'; defined &$const }; |
|
178
|
|
|
|
|
218
|
|
|
178
|
|
|
|
|
94814
|
|
|
11
|
|
|
|
|
41
|
|
|
11
|
|
|
|
|
91
|
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# Copy so we don't hurt our environment. |
360
|
1
|
|
|
|
|
1
|
my $value = $val; |
361
|
1
|
|
|
|
|
3
|
($value) = ($value =~ /^([-\@\w.]+)$/); # Untaint per rt.cpan.org 81550 |
362
|
1
|
|
|
|
|
3
|
$value =~ tr['"][]d; |
363
|
1
|
50
|
|
|
|
5
|
$value = 0 + $value if $value =~ /^\s*-?\d+(?:\.\d+)?\s*$/; |
364
|
|
|
|
|
|
|
|
365
|
178
|
|
|
178
|
|
2452
|
no strict 'refs'; |
|
178
|
|
|
|
|
261
|
|
|
178
|
|
|
|
|
11889
|
|
366
|
1
|
|
|
|
|
3
|
local $^W = 0; |
367
|
1
|
|
|
|
|
5
|
local $SIG{__WARN__} = sub { }; # redefine |
|
0
|
|
|
|
|
0
|
|
368
|
1
|
|
|
|
|
17
|
*$const = sub () { $value }; |
|
0
|
|
|
|
|
0
|
|
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# TRACE_FILENAME is special. |
372
|
|
|
|
|
|
|
{ |
373
|
178
|
|
|
178
|
|
863
|
no strict 'refs'; |
|
178
|
|
|
|
|
237
|
|
|
178
|
|
|
|
|
29997
|
|
|
178
|
|
|
|
|
303
|
|
374
|
178
|
50
|
|
|
|
547
|
my $trace_filename = TRACE_FILENAME() if defined &TRACE_FILENAME; |
375
|
178
|
50
|
|
|
|
525
|
if (defined $trace_filename) { |
376
|
0
|
0
|
|
|
|
0
|
open $trace_file_handle, ">$trace_filename" |
377
|
|
|
|
|
|
|
or die "can't open trace file `$trace_filename': $!"; |
378
|
0
|
|
|
|
|
0
|
CORE::select((CORE::select($trace_file_handle), $| = 1)[0]); |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
# TRACE_DEFAULT changes the default value for other TRACE_* |
382
|
|
|
|
|
|
|
# constants. Since define_trace() uses TRACE_DEFAULT internally, it |
383
|
|
|
|
|
|
|
# can't be used to define TRACE_DEFAULT itself. |
384
|
|
|
|
|
|
|
|
385
|
178
|
100
|
|
|
|
685
|
defined &TRACE_DEFAULT or *TRACE_DEFAULT = sub () { 0 }; |
386
|
|
|
|
|
|
|
|
387
|
178
|
|
|
|
|
456
|
_define_trace qw( |
388
|
|
|
|
|
|
|
EVENTS FILES PROFILE REFCNT RETVALS SESSIONS SIGNALS STATISTICS |
389
|
|
|
|
|
|
|
); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# See the notes for TRACE_DEFAULT, except read ASSERT and assert |
392
|
|
|
|
|
|
|
# where you see TRACE and trace. |
393
|
|
|
|
|
|
|
|
394
|
178
|
100
|
|
|
|
710
|
defined &ASSERT_DEFAULT or *ASSERT_DEFAULT = sub () { 0 }; |
395
|
|
|
|
|
|
|
|
396
|
178
|
|
|
|
|
490
|
_define_assert qw(DATA EVENTS FILES RETVALS USAGE); |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# An "idle" POE::Kernel may still have events enqueued. These events |
400
|
|
|
|
|
|
|
# regulate polling for signals, profiling, and perhaps other aspects of |
401
|
|
|
|
|
|
|
# POE::Kernel's internal workings. |
402
|
|
|
|
|
|
|
# |
403
|
|
|
|
|
|
|
# XXX - There must be a better mechanism. |
404
|
|
|
|
|
|
|
# |
405
|
|
|
|
|
|
|
my $idle_queue_size; |
406
|
|
|
|
|
|
|
|
407
|
3
|
|
|
3
|
|
13
|
sub _idle_queue_grow { $idle_queue_size++; } |
408
|
2
|
|
|
2
|
|
4
|
sub _idle_queue_shrink { $idle_queue_size--; } |
409
|
5
|
|
|
5
|
|
36
|
sub _idle_queue_size { $idle_queue_size; } |
410
|
174
|
|
|
174
|
|
427
|
sub _idle_queue_reset { $idle_queue_size = 0; } |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
413
|
|
|
|
|
|
|
# Helpers to carp, croak, confess, cluck, warn and die with whatever |
414
|
|
|
|
|
|
|
# trace file we're using today. _trap is reserved for internal |
415
|
|
|
|
|
|
|
# errors. |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub _trap { |
418
|
24
|
|
|
24
|
|
443
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
419
|
24
|
|
33
|
|
|
103
|
local *STDERR = $trace_file_handle || *STDERR; |
420
|
|
|
|
|
|
|
|
421
|
24
|
|
|
|
|
2932
|
confess( |
422
|
|
|
|
|
|
|
"=== $$ === Please address any warnings or errors above this message,\n", |
423
|
|
|
|
|
|
|
"=== $$ === and try again. If there are no previous messages, or they\n", |
424
|
|
|
|
|
|
|
"=== $$ === are from within POE, then please mail them along with the\n", |
425
|
|
|
|
|
|
|
"=== $$ === following information to bug-POE\@rt.cpan.org:\n", |
426
|
|
|
|
|
|
|
"---\n@_\n-----\n" |
427
|
|
|
|
|
|
|
); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
sub _croak { |
431
|
1
|
|
|
1
|
|
552
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
432
|
1
|
|
33
|
|
|
7
|
local *STDERR = $trace_file_handle || *STDERR; |
433
|
1
|
|
|
|
|
2
|
my $message = join("", @_); |
434
|
1
|
|
|
|
|
9
|
$message =~ s/^/=== $$ === /mg; |
435
|
1
|
|
|
|
|
4
|
croak $message; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub _confess { |
439
|
101
|
|
|
101
|
|
1005
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
440
|
101
|
|
33
|
|
|
358
|
local *STDERR = $trace_file_handle || *STDERR; |
441
|
101
|
|
|
|
|
180
|
my $message = join("", @_); |
442
|
101
|
|
|
|
|
616
|
$message =~ s/^/=== $$ === /mg; |
443
|
101
|
|
|
|
|
9210
|
confess $message; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub _cluck { |
447
|
5044
|
|
|
5044
|
|
9746
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
448
|
5044
|
|
33
|
|
|
20544
|
local *STDERR = $trace_file_handle || *STDERR; |
449
|
5044
|
|
|
|
|
9727
|
my $message = join("", @_); |
450
|
5044
|
|
|
|
|
32918
|
$message =~ s/^/=== $$ === /mg; |
451
|
5044
|
|
|
|
|
669570
|
cluck $message; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
sub _carp { |
455
|
4741
|
|
|
4741
|
|
8329
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
456
|
4741
|
|
33
|
|
|
18566
|
local *STDERR = $trace_file_handle || *STDERR; |
457
|
4741
|
|
|
|
|
8781
|
my $message = join("", @_); |
458
|
4741
|
|
|
|
|
25405
|
$message =~ s/^/=== $$ === /mg; |
459
|
4741
|
|
|
|
|
810366
|
carp $message; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub _warn { |
463
|
54607
|
|
|
54607
|
|
165224
|
my ($package, $file, $line) = caller(); |
464
|
54607
|
|
|
|
|
120253
|
my $message = join("", @_); |
465
|
54607
|
100
|
|
|
|
207171
|
$message .= " at $file line $line\n" unless $message =~ /\n$/; |
466
|
54607
|
|
|
|
|
378319
|
$message =~ s/^/=== $$ === /mg; |
467
|
54607
|
|
|
|
|
1551296
|
warn $message; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
sub _die { |
471
|
1
|
|
|
1
|
|
402
|
my ($package, $file, $line) = caller(); |
472
|
1
|
|
|
|
|
4
|
my $message = join("", @_); |
473
|
1
|
50
|
|
|
|
11
|
$message .= " at $file line $line\n" unless $message =~ /\n$/; |
474
|
1
|
|
|
|
|
12
|
$message =~ s/^/=== $$ === /mg; |
475
|
1
|
|
33
|
|
|
8
|
local *STDERR = $trace_file_handle || *STDERR; |
476
|
1
|
|
|
|
|
5
|
die $message; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
480
|
|
|
|
|
|
|
# Adapt POE::Kernel's personality to whichever event loop is present. |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub _find_loop { |
483
|
31095
|
|
|
31095
|
|
27536
|
my ($mod) = @_; |
484
|
|
|
|
|
|
|
|
485
|
31095
|
|
|
|
|
32900
|
foreach my $dir (@INC) { |
486
|
340787
|
100
|
|
|
|
2789912
|
return 1 if (-r "$dir/$mod"); |
487
|
|
|
|
|
|
|
} |
488
|
31044
|
|
|
|
|
77668
|
return 0; |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
sub _load_loop { |
492
|
178
|
|
|
178
|
|
397
|
my $loop = shift; |
493
|
|
|
|
|
|
|
|
494
|
178
|
|
|
8
|
|
1592
|
*poe_kernel_loop = sub { return "$loop" }; |
|
8
|
|
|
|
|
7115
|
|
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# Modules can die with "not really dying" if they've loaded |
497
|
|
|
|
|
|
|
# something else. This exception prevents the rest of the |
498
|
|
|
|
|
|
|
# originally used module from being parsed, so the module it's |
499
|
|
|
|
|
|
|
# handed off to takes over. |
500
|
178
|
|
|
|
|
15242
|
eval "require $loop"; |
501
|
178
|
100
|
66
|
|
|
1783
|
if ($@ and $@ !~ /not really dying/) { |
502
|
2
|
|
|
|
|
44
|
die( |
503
|
|
|
|
|
|
|
"*\n", |
504
|
|
|
|
|
|
|
"* POE can't use $loop:\n", |
505
|
|
|
|
|
|
|
"* $@\n", |
506
|
|
|
|
|
|
|
"*\n", |
507
|
|
|
|
|
|
|
); |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
sub _test_loop { |
512
|
178
|
|
|
178
|
|
324
|
my $used_first = shift; |
513
|
178
|
|
|
|
|
784
|
local $SIG{__DIE__}; |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# First see if someone wants to load a POE::Loop or XS version |
516
|
|
|
|
|
|
|
# explicitly. |
517
|
178
|
100
|
|
|
|
542
|
if (defined $used_first) { |
518
|
6
|
|
|
|
|
18
|
_load_loop($used_first); |
519
|
4
|
|
|
|
|
16
|
return; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
172
|
|
|
|
|
7000
|
foreach my $file (keys %INC) { |
523
|
15487
|
50
|
|
|
|
31811
|
next if (substr ($file, -3) ne '.pm'); |
524
|
15487
|
|
|
|
|
56712
|
my @split_dirs = File::Spec->splitdir($file); |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
# Create a module name by replacing the path separators with |
527
|
|
|
|
|
|
|
# underscores and removing ".pm" |
528
|
15487
|
|
|
|
|
23609
|
my $module = join("_", @split_dirs); |
529
|
15487
|
|
|
|
|
14502
|
substr($module, -3) = ""; |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
# Skip the module name if it isn't legal. |
532
|
15487
|
50
|
|
|
|
36831
|
next if $module =~ /[^\w\.]/; |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# Try for the XS version first. If it fails, try the plain |
535
|
|
|
|
|
|
|
# version. If that fails, we're up a creek. |
536
|
15487
|
|
|
|
|
18307
|
$module = "POE/XS/Loop/$module.pm"; |
537
|
15487
|
50
|
|
|
|
17566
|
unless (_find_loop($module)) { |
538
|
15487
|
|
|
|
|
36274
|
$module =~ s|XS/||; |
539
|
15487
|
100
|
|
|
|
22499
|
next unless (_find_loop($module)); |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
51
|
50
|
33
|
|
|
330
|
if (defined $used_first and $used_first ne $module) { |
543
|
0
|
|
|
|
|
0
|
die( |
544
|
|
|
|
|
|
|
"*\n", |
545
|
|
|
|
|
|
|
"* POE can't use multiple event loops at once.\n", |
546
|
|
|
|
|
|
|
"* You used $used_first and $module.\n", |
547
|
|
|
|
|
|
|
"* Specify the loop you want as an argument to POE\n", |
548
|
|
|
|
|
|
|
"* use POE qw(Loop::Select);\n", |
549
|
|
|
|
|
|
|
"* or;\n", |
550
|
|
|
|
|
|
|
"* use POE::Kernel { loop => 'Select' };\n", |
551
|
|
|
|
|
|
|
"*\n", |
552
|
|
|
|
|
|
|
); |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
51
|
|
|
|
|
167
|
$used_first = $module; |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
# No loop found. Default to our internal select() loop. |
559
|
172
|
100
|
|
|
|
2957
|
unless (defined $used_first) { |
560
|
121
|
|
|
|
|
299
|
$used_first = "POE/XS/Loop/Select.pm"; |
561
|
121
|
50
|
|
|
|
348
|
unless (_find_loop($used_first)) { |
562
|
121
|
|
|
|
|
527
|
$used_first =~ s/XS\///; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
172
|
|
|
|
|
480
|
substr($used_first, -3) = ""; |
567
|
172
|
|
|
|
|
641
|
$used_first =~ s|/|::|g; |
568
|
172
|
|
|
|
|
666
|
_load_loop($used_first); |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
572
|
|
|
|
|
|
|
# Include resource modules here. Later, when we have the option of XS |
573
|
|
|
|
|
|
|
# versions, we'll adapt this to include them if they're available. |
574
|
|
|
|
|
|
|
|
575
|
178
|
|
|
178
|
|
72071
|
use POE::Resources; |
|
178
|
|
|
|
|
319
|
|
|
178
|
|
|
|
|
1290006
|
|
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
############################################################################### |
578
|
|
|
|
|
|
|
# Helpers. |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
### Resolve $whatever into a session reference, trying every method we |
581
|
|
|
|
|
|
|
### can until something succeeds. |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
sub _resolve_session { |
584
|
3940
|
|
|
3940
|
|
4385
|
my ($self, $whatever) = @_; |
585
|
3940
|
|
|
|
|
3926
|
my $session; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# Resolve against sessions. |
588
|
3940
|
|
|
|
|
9133
|
$session = $self->_data_ses_resolve($whatever); |
589
|
3940
|
100
|
|
|
|
9239
|
return $session if defined $session; |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
# Resolve against IDs. |
592
|
206
|
|
|
|
|
809
|
$session = $self->_data_sid_resolve($whatever); |
593
|
206
|
100
|
|
|
|
462
|
return $session if defined $session; |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# Resolve against aliases. |
596
|
123
|
|
|
|
|
397
|
$session = $self->_data_alias_resolve($whatever); |
597
|
123
|
100
|
|
|
|
353
|
return $session if defined $session; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# Resolve against the Kernel itself. Use "eq" instead of "==" here |
600
|
|
|
|
|
|
|
# because $whatever is often a string. |
601
|
6
|
50
|
|
|
|
20
|
return $whatever if $whatever eq $self; |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
# We don't know what it is. |
604
|
6
|
|
|
|
|
13
|
return undef; |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
### Test whether POE has become idle. |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub _test_if_kernel_is_idle { |
610
|
2686
|
|
|
2686
|
|
3450
|
my $self = shift; |
611
|
|
|
|
|
|
|
|
612
|
2686
|
|
|
|
|
2794
|
if (TRACE_REFCNT) { |
613
|
|
|
|
|
|
|
_warn( |
614
|
|
|
|
|
|
|
" ,----- Kernel Activity -----\n", |
615
|
|
|
|
|
|
|
" | Events : ", $kr_queue->get_item_count(), |
616
|
|
|
|
|
|
|
" (vs. idle size = ", $idle_queue_size, ")\n", |
617
|
|
|
|
|
|
|
" | Files : ", $self->_data_handle_count(), "\n", |
618
|
|
|
|
|
|
|
" | Extra : ", $self->_data_extref_count(), "\n", |
619
|
|
|
|
|
|
|
" | Procs : ", $self->_data_sig_kernel_awaits_pids(), "\n", |
620
|
|
|
|
|
|
|
" | Sess : ", $self->_data_ses_count(), "\n", |
621
|
|
|
|
|
|
|
" `---------------------------\n", |
622
|
|
|
|
|
|
|
" ..." |
623
|
|
|
|
|
|
|
); |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
2686
|
|
|
|
|
6693
|
if( ASSERT_DATA ) { |
627
|
|
|
|
|
|
|
if( $kr_pid != $$ ) { |
628
|
|
|
|
|
|
|
_trap( |
629
|
|
|
|
|
|
|
"New process detected. " . |
630
|
|
|
|
|
|
|
"You must call ->has_forked() in the child process." |
631
|
|
|
|
|
|
|
); |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
# Not yet idle, or SO idle that there's nothing to receive the |
636
|
|
|
|
|
|
|
# event. Try to order these from most to least likely to be true so |
637
|
|
|
|
|
|
|
# that the tests short-circuit quickly. |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
return if ( |
640
|
2686
|
50
|
100
|
|
|
10510
|
$kr_queue->get_item_count() > $idle_queue_size or |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
641
|
|
|
|
|
|
|
$self->_data_handle_count() or |
642
|
|
|
|
|
|
|
$self->_data_extref_count() or |
643
|
|
|
|
|
|
|
$self->_data_sig_kernel_awaits_pids() or |
644
|
|
|
|
|
|
|
!$self->_data_ses_count() |
645
|
|
|
|
|
|
|
); |
646
|
|
|
|
|
|
|
|
647
|
1201
|
|
|
|
|
4418
|
$self->_data_ev_enqueue( |
648
|
|
|
|
|
|
|
$self, $self, EN_SIGNAL, ET_SIGNAL, [ 'IDLE' ], |
649
|
|
|
|
|
|
|
__FILE__, __LINE__, undef |
650
|
|
|
|
|
|
|
); |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
### Explain why a session could not be resolved. |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
sub _explain_resolve_failure { |
656
|
548
|
|
|
4
|
|
1664
|
my ($self, $whatever, $nonfatal) = @_; |
657
|
1266
|
|
|
|
|
4719
|
local $Carp::CarpLevel = 2; |
658
|
|
|
|
|
|
|
|
659
|
87
|
|
|
|
|
655
|
if (ASSERT_DATA and !$nonfatal) { |
660
|
|
|
|
|
|
|
_trap " Cannot resolve ``$whatever'' into a session reference"; |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
|
663
|
4
|
|
|
|
|
12
|
$! = ESRCH; |
664
|
0
|
|
|
|
|
0
|
TRACE_RETVALS and _carp " session not resolved: $!"; |
665
|
0
|
|
|
|
|
0
|
ASSERT_RETVALS and _carp " session not resolved: $!"; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
### Explain why a function is returning unsuccessfully. |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
sub _explain_return { |
671
|
15
|
|
|
15
|
|
19
|
my ($self, $message) = @_; |
672
|
15
|
|
|
|
|
18
|
local $Carp::CarpLevel = 2; |
673
|
|
|
|
|
|
|
|
674
|
15
|
|
|
|
|
28
|
ASSERT_RETVALS and _confess " $message"; |
675
|
6
|
|
|
|
|
7
|
TRACE_RETVALS and _carp " $message"; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
### Explain how the user made a mistake calling a function. |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
sub _explain_usage { |
681
|
25
|
|
|
25
|
|
33
|
my ($self, $message) = @_; |
682
|
25
|
|
|
|
|
35
|
local $Carp::CarpLevel = 2; |
683
|
|
|
|
|
|
|
|
684
|
25
|
|
|
|
|
36
|
ASSERT_USAGE and _confess " $message"; |
685
|
13
|
|
|
|
|
58
|
ASSERT_RETVALS and _confess " $message"; |
686
|
1
|
|
|
|
|
1
|
TRACE_RETVALS and _carp " $message"; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
#============================================================================== |
690
|
|
|
|
|
|
|
# SIGNALS |
691
|
|
|
|
|
|
|
#============================================================================== |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
694
|
|
|
|
|
|
|
# Register or remove signals. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
# Public interface for adding or removing signal handlers. |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub sig { |
699
|
281
|
|
|
281
|
1
|
20738
|
my ($self, $signal, $event_name, @args) = ($poe_kernel, @_[1..$#_]); |
700
|
|
|
|
|
|
|
|
701
|
281
|
|
|
|
|
384
|
if (ASSERT_USAGE) { |
702
|
|
|
|
|
|
|
_confess " must call sig() from a running session" |
703
|
|
|
|
|
|
|
if $kr_active_session == $self; |
704
|
|
|
|
|
|
|
_confess " undefined signal in sig()" unless defined $signal; |
705
|
|
|
|
|
|
|
_carp( |
706
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
707
|
|
|
|
|
|
|
"effect cannot be achieved assigning it to a signal" |
708
|
|
|
|
|
|
|
) if defined($event_name) and exists($poes_own_events{$event_name}); |
709
|
|
|
|
|
|
|
}; |
710
|
|
|
|
|
|
|
|
711
|
281
|
100
|
|
|
|
906
|
if (defined $event_name) { |
712
|
279
|
|
|
|
|
614
|
$self->_data_sig_add($kr_active_session, $signal, $event_name, \@args); |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
else { |
715
|
276
|
|
|
|
|
1541
|
$self->_data_sig_remove($kr_active_session->ID, $signal); |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
# Public interface for posting signal events. |
720
|
|
|
|
|
|
|
# TODO - Like post(), signal() should return |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
sub signal { |
723
|
296
|
|
|
21
|
1
|
1874
|
my ($self, $dest_session, $signal, @etc) = ($poe_kernel, @_[1..$#_]); |
724
|
|
|
|
|
|
|
|
725
|
176
|
|
|
|
|
713
|
if (ASSERT_USAGE) { |
726
|
|
|
|
|
|
|
_confess " undefined destination in signal()" |
727
|
|
|
|
|
|
|
unless defined $dest_session; |
728
|
|
|
|
|
|
|
_confess " undefined signal in signal()" unless defined $signal; |
729
|
|
|
|
|
|
|
}; |
730
|
|
|
|
|
|
|
|
731
|
141
|
|
|
|
|
467
|
my $session = $self->_resolve_session($dest_session); |
732
|
20
|
100
|
|
|
|
97
|
unless (defined $session) { |
733
|
17
|
|
|
|
|
63
|
$self->_explain_resolve_failure($dest_session); |
734
|
16
|
|
|
|
|
39
|
return; |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
$self->_data_ev_enqueue( |
738
|
2
|
|
|
|
|
11
|
$session, $kr_active_session, |
739
|
|
|
|
|
|
|
EN_SIGNAL, ET_SIGNAL, [ $signal, @etc ], |
740
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event |
741
|
|
|
|
|
|
|
); |
742
|
2
|
|
|
|
|
5
|
return 1; |
743
|
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
# Public interface for flagging signals as handled. This will replace |
746
|
|
|
|
|
|
|
# the handlers' return values as an implicit flag. Returns undef so |
747
|
|
|
|
|
|
|
# it may be used as the last function in an event handler. |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
sub sig_handled { |
750
|
140
|
|
|
124
|
1
|
2275
|
my $self = $poe_kernel; |
751
|
140
|
|
|
|
|
562
|
$self->_data_sig_handled(); |
752
|
|
|
|
|
|
|
|
753
|
124
|
100
|
|
|
|
621
|
if ($kr_active_event eq EN_SIGNAL) { |
754
|
0
|
|
|
|
|
0
|
_die( |
755
|
|
|
|
|
|
|
",----- DEPRECATION ERROR -----\n", |
756
|
|
|
|
|
|
|
"| ", $self->_data_alias_loggable($kr_active_session->ID), ":\n", |
757
|
|
|
|
|
|
|
"| handled a _signal event. You must register a handler with sig().\n", |
758
|
|
|
|
|
|
|
"`-----------------------------\n", |
759
|
|
|
|
|
|
|
); |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
# Attach a window or widget's destroy/closure to the UIDESTROY signal. |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
sub signal_ui_destroy { |
766
|
0
|
|
|
0
|
1
|
0
|
my ($self, $window) = @_; |
767
|
0
|
|
|
|
|
0
|
$self->loop_attach_uidestroy($window); |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
# Handle child PIDs being reaped. Added 2006-09-15. |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
sub sig_child { |
773
|
220
|
|
|
220
|
1
|
18808
|
my ($self, $pid, $event_name, @args) = ($poe_kernel, @_[1..$#_]); |
774
|
|
|
|
|
|
|
|
775
|
220
|
|
|
|
|
425
|
if (ASSERT_USAGE) { |
776
|
|
|
|
|
|
|
_confess " must call sig_chld() from a running session" |
777
|
|
|
|
|
|
|
if $kr_active_session == $self; |
778
|
|
|
|
|
|
|
_confess " undefined process ID in sig_chld()" unless defined $pid; |
779
|
|
|
|
|
|
|
_carp( |
780
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
781
|
|
|
|
|
|
|
"effect cannot be achieved assigning it to a signal" |
782
|
|
|
|
|
|
|
) if defined($event_name) and exists($poes_own_events{$event_name}); |
783
|
|
|
|
|
|
|
}; |
784
|
|
|
|
|
|
|
|
785
|
220
|
100
|
|
|
|
768
|
if (defined $event_name) { |
|
|
50
|
|
|
|
|
|
786
|
220
|
|
|
|
|
1877
|
$self->_data_sig_pid_watch($kr_active_session, $pid, $event_name, \@args); |
787
|
|
|
|
|
|
|
} |
788
|
|
|
|
|
|
|
elsif ($self->_data_sig_pids_is_ses_watching($kr_active_session->ID, $pid)) { |
789
|
122
|
|
|
|
|
1271
|
$self->_data_sig_pid_ignore($kr_active_session->ID, $pid); |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
#============================================================================== |
794
|
|
|
|
|
|
|
# KERNEL |
795
|
|
|
|
|
|
|
#============================================================================== |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub new { |
798
|
298
|
|
|
176
|
1
|
671
|
my $type = shift; |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
# Prevent multiple instances, no matter how many times it's called. |
801
|
|
|
|
|
|
|
# This is a backward-compatibility enhancement for programs that |
802
|
|
|
|
|
|
|
# have used versions prior to 0.06. It also provides a convenient |
803
|
|
|
|
|
|
|
# single entry point into the entirety of POE's state: point a |
804
|
|
|
|
|
|
|
# Dumper module at it, and you'll see a hideous tree of knowledge. |
805
|
|
|
|
|
|
|
# Be careful, though. Its apples bite back. |
806
|
297
|
100
|
|
|
|
2096
|
unless (defined $poe_kernel) { |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# Create our master queue. |
809
|
176
|
|
|
|
|
1352
|
$kr_queue = $queue_class->new(); |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
# Remember the PID |
812
|
176
|
|
|
|
|
793
|
$kr_pid = $$; |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# TODO - Should KR_ACTIVE_SESSIONS and KR_ACTIVE_EVENT be handled |
815
|
|
|
|
|
|
|
# by POE::Resource::Sessions? |
816
|
|
|
|
|
|
|
# TODO - Should the subsystems be split off into separate real |
817
|
|
|
|
|
|
|
# objects, such as KR_QUEUE is? |
818
|
|
|
|
|
|
|
|
819
|
176
|
|
|
|
|
891
|
my $self = $poe_kernel = bless [ |
820
|
|
|
|
|
|
|
undef, # KR_SESSIONS - from POE::Resource::Sessions |
821
|
|
|
|
|
|
|
undef, # KR_FILENOS - from POE::Resource::FileHandles |
822
|
|
|
|
|
|
|
undef, # KR_SIGNALS - from POE::Resource::Signals |
823
|
|
|
|
|
|
|
undef, # KR_ALIASES - from POE::Resource::Aliases |
824
|
|
|
|
|
|
|
\$kr_active_session, # KR_ACTIVE_SESSION |
825
|
|
|
|
|
|
|
$kr_queue, # KR_QUEUE - reference to an object |
826
|
|
|
|
|
|
|
undef, # KR_ID |
827
|
|
|
|
|
|
|
undef, # KR_SESSION_IDS - from POE::Resource::SIDS |
828
|
|
|
|
|
|
|
undef, # KR_SID_SEQ - from POE::Resource::SIDS |
829
|
|
|
|
|
|
|
undef, # KR_EXTRA_REFS |
830
|
|
|
|
|
|
|
undef, # KR_SIZE |
831
|
|
|
|
|
|
|
\$kr_run_warning, # KR_RUN |
832
|
|
|
|
|
|
|
\$kr_active_event, # KR_ACTIVE_EVENT |
833
|
|
|
|
|
|
|
undef, # KR_PIDS |
834
|
|
|
|
|
|
|
\$kr_active_event_type, # KR_ACTIVE_EVENT_TYPE |
835
|
|
|
|
|
|
|
], $type; |
836
|
|
|
|
|
|
|
|
837
|
176
|
|
|
|
|
1141
|
POE::Resources->load(); |
838
|
|
|
|
|
|
|
|
839
|
176
|
|
|
|
|
862
|
$self->_recalc_id(); |
840
|
176
|
|
|
|
|
948
|
$self->_data_sid_set($self->[KR_ID], $self); |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
# Initialize subsystems. The order is important. |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
# We need events before sessions, and the kernel's session before |
845
|
|
|
|
|
|
|
# it can start polling for signals. |
846
|
176
|
|
|
|
|
837
|
$self->_data_ev_initialize($kr_queue); |
847
|
176
|
|
|
|
|
1353
|
$self->_initialize_kernel_session(); |
848
|
175
|
|
|
|
|
602
|
$self->_data_sig_initialize(); |
849
|
174
|
|
|
|
|
771
|
$self->_data_alias_initialize(); |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# These other subsystems don't have strange interactions. |
852
|
174
|
|
|
|
|
708
|
$self->_data_handle_initialize($kr_queue); |
853
|
|
|
|
|
|
|
|
854
|
174
|
|
|
|
|
517
|
_idle_queue_reset(); |
855
|
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
# Return the global instance. |
858
|
174
|
|
|
|
|
3567
|
$poe_kernel; |
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub CLONE { |
862
|
0
|
|
|
0
|
|
0
|
_data_ses_clone(); |
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
866
|
|
|
|
|
|
|
# Send an event to a session right now. Used by _disp_select to |
867
|
|
|
|
|
|
|
# expedite select() events, and used by run() to deliver posted events |
868
|
|
|
|
|
|
|
# from the queue. |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
# Dispatch an event to its session. A lot of work goes on here. |
871
|
|
|
|
|
|
|
|
872
|
256
|
|
|
256
|
|
38076
|
sub _dummy_sigdie_handler { 1 } |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
sub _dispatch_signal_event { |
875
|
|
|
|
|
|
|
my ( |
876
|
482
|
|
|
482
|
|
1355
|
$self, |
877
|
|
|
|
|
|
|
$session, $source_session, $event, $type, $etc, |
878
|
|
|
|
|
|
|
$file, $line, $fromstate, $priority, $seq |
879
|
|
|
|
|
|
|
) = @_; |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
# TODO - Regrettably, duplicate checking code in: |
882
|
|
|
|
|
|
|
# _dispatch_signal_event(), _dispatch_event(). |
883
|
|
|
|
|
|
|
|
884
|
482
|
|
|
|
|
508
|
if (ASSERT_EVENTS) { |
885
|
|
|
|
|
|
|
_confess " undefined dest session" unless defined $session; |
886
|
|
|
|
|
|
|
_confess " undefined source session" unless defined $source_session; |
887
|
|
|
|
|
|
|
}; |
888
|
|
|
|
|
|
|
|
889
|
482
|
|
|
|
|
7299
|
if (TRACE_EVENTS) { |
890
|
|
|
|
|
|
|
my $log_session = $session; |
891
|
|
|
|
|
|
|
$log_session = $self->_data_alias_loggable($session->ID) unless ( |
892
|
|
|
|
|
|
|
$type & ET_START |
893
|
|
|
|
|
|
|
); |
894
|
|
|
|
|
|
|
my $string_etc = join(" ", map { defined() ? $_ : "(undef)" } @$etc); |
895
|
|
|
|
|
|
|
_warn( |
896
|
|
|
|
|
|
|
" Dispatching event $seq ``$event'' ($string_etc) from ", |
897
|
|
|
|
|
|
|
$self->_data_alias_loggable($source_session->ID), " to $log_session" |
898
|
|
|
|
|
|
|
); |
899
|
|
|
|
|
|
|
} |
900
|
|
|
|
|
|
|
|
901
|
482
|
|
|
|
|
1072
|
my $signal = $etc->[0]; |
902
|
|
|
|
|
|
|
|
903
|
482
|
|
|
|
|
609
|
if (TRACE_SIGNALS) { |
904
|
|
|
|
|
|
|
_warn( |
905
|
|
|
|
|
|
|
" dispatching ET_SIGNAL ($signal) to ", |
906
|
|
|
|
|
|
|
$self->_data_alias_loggable($session->ID) |
907
|
|
|
|
|
|
|
); |
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
# Step 1a: Reset the handled-signal flags. |
911
|
|
|
|
|
|
|
|
912
|
482
|
|
|
|
|
1088
|
local @POE::Kernel::kr_signaled_sessions; |
913
|
482
|
|
|
|
|
1174
|
local $POE::Kernel::kr_signal_total_handled; |
914
|
482
|
|
|
|
|
1294
|
local $POE::Kernel::kr_signal_type; |
915
|
|
|
|
|
|
|
|
916
|
625
|
|
|
|
|
1763
|
$self->_data_sig_reset_handled($signal); |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
# Step 1b: Collect a list of sessions to receive the signal. |
919
|
|
|
|
|
|
|
|
920
|
482
|
|
|
|
|
1279
|
my @touched_sessions = ($session); |
921
|
482
|
|
|
|
|
2623
|
my $touched_index = 0; |
922
|
482
|
|
|
|
|
963
|
while ($touched_index < @touched_sessions) { |
923
|
893
|
|
|
|
|
2023
|
my $next_target = $touched_sessions[$touched_index]->ID; |
924
|
893
|
|
|
|
|
2756
|
push @touched_sessions, $self->_data_ses_get_children($next_target); |
925
|
1047
|
|
|
|
|
1948
|
$touched_index++; |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
# Step 1c: The DIE signal propagates up through parents, too. |
929
|
|
|
|
|
|
|
|
930
|
636
|
100
|
|
|
|
1450
|
if ($signal eq "DIE") { |
931
|
524
|
|
|
|
|
1621
|
my $next_target = $self->_data_ses_get_parent($session->ID); |
932
|
370
|
|
100
|
|
|
788
|
while (defined($next_target) and $next_target != $self) { |
933
|
202
|
|
|
|
|
285
|
unshift @touched_sessions, $next_target; |
934
|
202
|
|
|
|
|
683
|
$next_target = $self->_data_ses_get_parent($next_target->ID); |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
} |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
# Step 2: Propagate the signal to the explicit watchers in the |
939
|
|
|
|
|
|
|
# child tree. Ensure the full tree is touched regardless |
940
|
|
|
|
|
|
|
# whether there are explicit watchers. |
941
|
|
|
|
|
|
|
|
942
|
812
|
100
|
|
|
|
2024
|
if ($self->_data_sig_explicitly_watched($signal)) { |
943
|
721
|
|
|
|
|
1817
|
my %signal_watchers = $self->_data_sig_watchers($signal); |
944
|
|
|
|
|
|
|
|
945
|
883
|
|
|
|
|
1941
|
$touched_index = @touched_sessions; |
946
|
388
|
|
|
|
|
1237
|
while ($touched_index--) { |
947
|
198
|
|
|
|
|
308
|
my $target_session = $touched_sessions[$touched_index]; |
948
|
198
|
|
|
|
|
513
|
$self->_data_sig_touched_session($target_session); |
949
|
|
|
|
|
|
|
|
950
|
355
|
|
|
|
|
488
|
my $target_sid = $target_session->ID; |
951
|
355
|
100
|
|
|
|
885
|
next unless exists $signal_watchers{$target_sid}; |
952
|
545
|
|
|
|
|
1302
|
my ($target_event, $target_etc) = @{$signal_watchers{$target_sid}}; |
|
505
|
|
|
|
|
1620
|
|
953
|
|
|
|
|
|
|
|
954
|
352
|
|
|
|
|
533
|
if (TRACE_SIGNALS) { |
955
|
|
|
|
|
|
|
_warn( |
956
|
|
|
|
|
|
|
" propagating explicit signal $target_event ($signal) ", |
957
|
|
|
|
|
|
|
"(@$target_etc) to ", $self->_data_alias_loggable($target_sid) |
958
|
|
|
|
|
|
|
); |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# ET_SIGNAL_RECURSIVE is used here to avoid repropagating |
962
|
|
|
|
|
|
|
# the signal ad nauseam. |
963
|
|
|
|
|
|
|
$self->_dispatch_event( |
964
|
352
|
|
|
|
|
1225
|
$target_session, $self, |
965
|
|
|
|
|
|
|
$target_event, ET_SIGNAL_RECURSIVE | $type, [ @$etc, @$target_etc ], |
966
|
|
|
|
|
|
|
$file, $line, $fromstate, monotime(), -__LINE__ |
967
|
|
|
|
|
|
|
); |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
} |
970
|
|
|
|
|
|
|
else { |
971
|
654
|
|
|
|
|
795
|
$touched_index = @touched_sessions; |
972
|
654
|
|
|
|
|
2384
|
while ($touched_index--) { |
973
|
891
|
|
|
|
|
2770
|
$self->_data_sig_touched_session($touched_sessions[$touched_index]); |
974
|
|
|
|
|
|
|
} |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# Step 3: Check to see if the signal was handled. |
978
|
|
|
|
|
|
|
|
979
|
512
|
|
|
|
|
1648
|
$self->_data_sig_free_terminated_sessions(); |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
# If the signal was SIGDIE, then propagate the exception. |
982
|
|
|
|
|
|
|
|
983
|
286
|
|
|
|
|
634
|
my $handled_session_count = (_data_sig_handled_status())[0]; |
984
|
451
|
100
|
100
|
|
|
1422
|
if ($signal eq "DIE" and !$handled_session_count) { |
985
|
338
|
100
|
|
|
|
744
|
$kr_exception = $etc->[1]{error_str} . ( |
986
|
|
|
|
|
|
|
(defined $kr_exception) |
987
|
|
|
|
|
|
|
? "Additional error thrown in handler for previous error:\n$kr_exception" |
988
|
|
|
|
|
|
|
: '' |
989
|
|
|
|
|
|
|
); |
990
|
|
|
|
|
|
|
} |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
# Signal completely dispatched. Thanks for flying! |
993
|
448
|
|
|
|
|
1951
|
return; |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
sub _dispatch_event { |
997
|
|
|
|
|
|
|
my ( |
998
|
8282
|
|
|
8114
|
|
20062
|
$self, |
999
|
|
|
|
|
|
|
$session, $source_session, $event, $type, $etc, |
1000
|
|
|
|
|
|
|
$file, $line, $fromstate, $priority, $seq |
1001
|
|
|
|
|
|
|
) = @_; |
1002
|
|
|
|
|
|
|
|
1003
|
8319
|
|
|
|
|
7994
|
if (ASSERT_EVENTS) { |
1004
|
|
|
|
|
|
|
_confess " undefined dest session" unless defined $session; |
1005
|
|
|
|
|
|
|
_confess " undefined source session" unless defined $source_session; |
1006
|
|
|
|
|
|
|
}; |
1007
|
|
|
|
|
|
|
|
1008
|
8157
|
|
|
|
|
13967
|
if (TRACE_EVENTS) { |
1009
|
|
|
|
|
|
|
my $log_session = $session; |
1010
|
|
|
|
|
|
|
$log_session = $self->_data_alias_loggable($session->ID) unless ( |
1011
|
|
|
|
|
|
|
$type & ET_START |
1012
|
|
|
|
|
|
|
); |
1013
|
|
|
|
|
|
|
my $string_etc = join(" ", map { defined() ? $_ : "(undef)" } @$etc); |
1014
|
|
|
|
|
|
|
_warn( |
1015
|
|
|
|
|
|
|
" Dispatching event $seq ``$event'' ($string_etc) from ", |
1016
|
|
|
|
|
|
|
$self->_data_alias_loggable($source_session->ID), " to $log_session" |
1017
|
|
|
|
|
|
|
); |
1018
|
|
|
|
|
|
|
} |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
### Pre-dispatch processing. |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
# Some sessions don't do anything in _start and expect their |
1023
|
|
|
|
|
|
|
# creators to provide a start-up event. This means we can't |
1024
|
|
|
|
|
|
|
# &_collect_garbage at _start time. Instead, an ET_GC event is |
1025
|
|
|
|
|
|
|
# posted as part of session allocation. Simply dispatching it |
1026
|
|
|
|
|
|
|
# will trigger a GC sweep. |
1027
|
|
|
|
|
|
|
|
1028
|
8418
|
100
|
|
|
|
16214
|
return 0 if $type & ET_GC; |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
# Preprocess signals. This is where _signal is translated into |
1031
|
|
|
|
|
|
|
# its registered handler's event name, if there is one. |
1032
|
|
|
|
|
|
|
|
1033
|
8193
|
|
|
|
|
8721
|
if (TRACE_EVENTS) { |
1034
|
|
|
|
|
|
|
_warn( |
1035
|
|
|
|
|
|
|
" dispatching event $seq ``$event'' to ", |
1036
|
|
|
|
|
|
|
$self->_data_alias_loggable($session->ID) |
1037
|
|
|
|
|
|
|
); |
1038
|
|
|
|
|
|
|
if ($event eq EN_SIGNAL) { |
1039
|
|
|
|
|
|
|
_warn(" signal($etc->[0])"); |
1040
|
|
|
|
|
|
|
} |
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
# Prepare to call the appropriate handler. Push the current active |
1044
|
|
|
|
|
|
|
# session on Perl's call stack. |
1045
|
|
|
|
|
|
|
|
1046
|
8190
|
|
|
|
|
11910
|
my ($hold_active_session, $hold_active_event, $hold_active_event_type) = ( |
1047
|
|
|
|
|
|
|
$kr_active_session, $kr_active_event, $kr_active_event_type |
1048
|
|
|
|
|
|
|
); |
1049
|
|
|
|
|
|
|
( |
1050
|
7969
|
|
|
|
|
19821
|
$kr_active_session, $kr_active_event, $kr_active_event_type |
1051
|
|
|
|
|
|
|
) = ($session, $event, $type); |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
# We only care about the return value and calling context if it's |
1054
|
|
|
|
|
|
|
# ET_CALL. |
1055
|
|
|
|
|
|
|
|
1056
|
7756
|
|
|
|
|
18340
|
my $return; |
1057
|
9299
|
|
|
|
|
18912
|
my $wantarray = wantarray(); |
1058
|
|
|
|
|
|
|
|
1059
|
7756
|
100
|
|
|
|
18611
|
confess 'please report this stacktrace to bug-poe@rt.cpan.org' unless ( |
1060
|
|
|
|
|
|
|
defined $session |
1061
|
|
|
|
|
|
|
); |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# Quiet SIGDIE if it's DEFAULT. If it's something special, then |
1064
|
|
|
|
|
|
|
# someone had better know what they're doing. |
1065
|
|
|
|
|
|
|
# 'DEFAULT', undef and '' are all the same. |
1066
|
|
|
|
|
|
|
|
1067
|
7756
|
|
|
|
|
26539
|
my $old_sig_die = $SIG{__DIE__}; |
1068
|
7470
|
100
|
66
|
|
|
21989
|
$SIG{__DIE__} = \&_dummy_sigdie_handler if ( |
|
|
|
100
|
|
|
|
|
1069
|
|
|
|
|
|
|
not defined $old_sig_die or $old_sig_die eq 'DEFAULT' or $old_sig_die eq '' |
1070
|
|
|
|
|
|
|
); |
1071
|
|
|
|
|
|
|
|
1072
|
7439
|
|
|
|
|
21029
|
eval { |
1073
|
7470
|
100
|
|
|
|
32680
|
if ($wantarray) { |
|
|
100
|
|
|
|
|
|
1074
|
2039
|
|
|
|
|
2683
|
$return = [ |
1075
|
|
|
|
|
|
|
$session->_invoke_state( |
1076
|
|
|
|
|
|
|
$source_session, $event, $etc, $file, $line, $fromstate |
1077
|
|
|
|
|
|
|
) |
1078
|
|
|
|
|
|
|
]; |
1079
|
|
|
|
|
|
|
} |
1080
|
|
|
|
|
|
|
elsif (defined $wantarray) { |
1081
|
6004
|
|
|
|
|
10843
|
$return = $session->_invoke_state( |
1082
|
|
|
|
|
|
|
$source_session, $event, $etc, $file, $line, $fromstate |
1083
|
|
|
|
|
|
|
); |
1084
|
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
|
else { |
1086
|
5327
|
|
|
|
|
11904
|
$session->_invoke_state( |
1087
|
|
|
|
|
|
|
$source_session, $event, $etc, $file, $line, $fromstate |
1088
|
|
|
|
|
|
|
); |
1089
|
|
|
|
|
|
|
} |
1090
|
|
|
|
|
|
|
}; |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
# An exception happened? |
1093
|
|
|
|
|
|
|
# It was intially thrown under the $SIG{__DIE__} conditions that the |
1094
|
|
|
|
|
|
|
# user wanted. Any formatting, logging, etc. is already done. |
1095
|
|
|
|
|
|
|
|
1096
|
6108
|
100
|
66
|
|
|
32174
|
if (ref($@) or $@ ne '') { |
1097
|
5205
|
|
|
|
|
8428
|
if (CATCH_EXCEPTIONS) { |
1098
|
5759
|
|
|
|
|
27862
|
if (TRACE_EVENTS) { |
1099
|
|
|
|
|
|
|
_warn( |
1100
|
|
|
|
|
|
|
" exception occurred in $event when invoked on ", |
1101
|
|
|
|
|
|
|
$self->_data_alias_loggable($session->ID) |
1102
|
|
|
|
|
|
|
); |
1103
|
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# Exceptions in _stop are rethrown unconditionally. |
1106
|
|
|
|
|
|
|
# We can't enqueue them--the session is about to go away. |
1107
|
|
|
|
|
|
|
# Also if the active session has been forced back to $self via |
1108
|
|
|
|
|
|
|
# POE::Kernel->stop(). |
1109
|
3887
|
100
|
66
|
|
|
8455
|
if ($type & (ET_STOP | ET_SIGDIE) or $kr_active_session eq $self) { |
1110
|
|
|
|
|
|
|
# Propagate the exception up to the safe rethrow point. |
1111
|
3869
|
|
|
|
|
27877
|
$kr_exception = $@; |
1112
|
|
|
|
|
|
|
} |
1113
|
|
|
|
|
|
|
else { |
1114
|
3946
|
|
|
|
|
5395
|
$self->_data_ev_enqueue( |
1115
|
|
|
|
|
|
|
$session, $self, EN_SIGNAL, ET_SIGDIE, [ |
1116
|
|
|
|
|
|
|
'DIE' => { |
1117
|
|
|
|
|
|
|
source_session => $source_session, |
1118
|
|
|
|
|
|
|
dest_session => $session, |
1119
|
|
|
|
|
|
|
event => $event, |
1120
|
|
|
|
|
|
|
file => $file, |
1121
|
|
|
|
|
|
|
line => $line, |
1122
|
|
|
|
|
|
|
from_state => $fromstate, |
1123
|
|
|
|
|
|
|
error_str => $@, |
1124
|
|
|
|
|
|
|
}, |
1125
|
|
|
|
|
|
|
], __FILE__, __LINE__, undef |
1126
|
|
|
|
|
|
|
); |
1127
|
|
|
|
|
|
|
} |
1128
|
|
|
|
|
|
|
} |
1129
|
|
|
|
|
|
|
else { |
1130
|
|
|
|
|
|
|
# Propagate the exception up to the safe rethrow point. |
1131
|
|
|
|
|
|
|
$kr_exception = $@; |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
} |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
# Global $sig{__DIE__} changed? For shame! |
1136
|
|
|
|
|
|
|
# TODO - This warning is only needed if a SIGDIE handler is active. |
1137
|
|
|
|
|
|
|
# TODO - Likewise, setting a SIGDIE with a __DIE__ handler in play |
1138
|
|
|
|
|
|
|
# will be tricky or impossible. There should be some message. |
1139
|
|
|
|
|
|
|
|
1140
|
5511
|
100
|
100
|
|
|
18547
|
if ( |
|
|
|
66
|
|
|
|
|
1141
|
|
|
|
|
|
|
(not defined $old_sig_die or $old_sig_die eq 'DEFAULT') and |
1142
|
|
|
|
|
|
|
$SIG{__DIE__} ne \&_dummy_sigdie_handler |
1143
|
|
|
|
|
|
|
) { |
1144
|
32
|
|
|
|
|
94
|
_warn( |
1145
|
|
|
|
|
|
|
" Event handler redefined global __DIE__ signal handler.\n", |
1146
|
|
|
|
|
|
|
" This may conflict with CATCH_EXCEPTIONS handling.\n", |
1147
|
|
|
|
|
|
|
" If global redefinition is necessary, do it in global code.\n", |
1148
|
|
|
|
|
|
|
); |
1149
|
|
|
|
|
|
|
|
1150
|
2765
|
|
|
|
|
15073
|
$SIG{__DIE__} = $old_sig_die; |
1151
|
|
|
|
|
|
|
} |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
# Clear out the event arguments list, in case there are POE-ish |
1154
|
|
|
|
|
|
|
# things in it. This allows them to destruct happily before we set |
1155
|
|
|
|
|
|
|
# the current session back. |
1156
|
|
|
|
|
|
|
|
1157
|
4758
|
|
|
|
|
16051
|
@$etc = ( ); |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
# Stringify the handler's return value if it belongs in the POE |
1160
|
|
|
|
|
|
|
# namespace. $return's scope exists beyond the post-dispatch |
1161
|
|
|
|
|
|
|
# processing, which includes POE's garbage collection. The scope |
1162
|
|
|
|
|
|
|
# bleed was known to break determinism in surprising ways. |
1163
|
|
|
|
|
|
|
|
1164
|
5470
|
100
|
100
|
|
|
179648
|
if (defined $return and substr(ref($return), 0, 5) eq 'POE::') { |
1165
|
1907
|
|
|
|
|
2979
|
$return = "$return"; |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
# Pop the active session and event, now that they're no longer |
1169
|
|
|
|
|
|
|
# active. |
1170
|
|
|
|
|
|
|
|
1171
|
3544
|
|
|
|
|
7230
|
($kr_active_session, $kr_active_event, $kr_active_event_type) = ( |
1172
|
|
|
|
|
|
|
$hold_active_session, $hold_active_event, $hold_active_event_type |
1173
|
|
|
|
|
|
|
); |
1174
|
|
|
|
|
|
|
|
1175
|
1926
|
|
|
|
|
2563
|
if (TRACE_EVENTS) { |
1176
|
|
|
|
|
|
|
my $string_ret = $return; |
1177
|
|
|
|
|
|
|
$string_ret = "undef" unless defined $string_ret; |
1178
|
|
|
|
|
|
|
_warn(" event $seq ``$event'' returns ($string_ret)\n"); |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
# Return doesn't matter unless ET_CALL, ET_START or ET_STOP. |
1182
|
3447
|
100
|
|
|
|
10287
|
return unless $type & (ET_CALL | ET_START | ET_STOP); |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
# Return what the handler did. This is used for call(). |
1185
|
2024
|
100
|
|
|
|
2778
|
return( $wantarray ? @$return : $return ); |
1186
|
|
|
|
|
|
|
} |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1189
|
|
|
|
|
|
|
# POE's main loop! Now with Tk and Event support! |
1190
|
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
|
# Do pre-run start-up. Initialize the event loop, and allocate a |
1192
|
|
|
|
|
|
|
# session structure to represent the Kernel. |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
sub _initialize_kernel_session { |
1195
|
2146
|
|
|
270
|
|
6484
|
my $self = shift; |
1196
|
|
|
|
|
|
|
|
1197
|
4632
|
|
|
|
|
23850
|
$self->loop_initialize(); |
1198
|
|
|
|
|
|
|
|
1199
|
303
|
|
|
|
|
451
|
$kr_exception = undef; |
1200
|
397
|
|
|
|
|
735
|
$kr_active_session = $self; |
1201
|
4078
|
|
|
|
|
8494
|
$self->_data_ses_allocate($self, $self->[KR_ID], undef); |
1202
|
|
|
|
|
|
|
} |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
# Do post-run cleanup. |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
sub _finalize_kernel { |
1207
|
4033
|
|
|
190
|
|
10907
|
my $self = shift; |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
# Disable signal watching since there's now no place for them to go. |
1210
|
330
|
|
|
|
|
1390
|
foreach ($self->_data_sig_get_safe_signals()) { |
1211
|
10303
|
|
|
|
|
18446
|
$self->loop_ignore_signal($_); |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
# Remove the kernel session's signal watcher. |
1215
|
4033
|
|
|
|
|
5508
|
$self->_data_sig_remove($self->ID, "IDLE"); |
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
# The main loop is done, no matter which event library ran it. |
1218
|
|
|
|
|
|
|
# sig before loop so that it clears the signal_pipe file handler |
1219
|
3957
|
|
|
|
|
4850
|
$self->_data_sig_finalize(); |
1220
|
3939
|
|
|
|
|
8086
|
$self->loop_finalize(); |
1221
|
3922
|
|
|
|
|
12031
|
$self->_data_extref_finalize(); |
1222
|
3905
|
|
|
|
|
26521
|
$self->_data_sid_finalize(); |
1223
|
1042
|
|
|
|
|
5028
|
$self->_data_alias_finalize(); |
1224
|
190
|
|
|
|
|
929
|
$self->_data_handle_finalize(); |
1225
|
190
|
|
|
|
|
756
|
$self->_data_ev_finalize(); |
1226
|
190
|
|
|
|
|
745
|
$self->_data_ses_finalize(); |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
sub run_while { |
1230
|
0
|
|
|
0
|
1
|
0
|
my ($self, $scalar_ref) = ($poe_kernel, @_[1..$#_]); |
1231
|
0
|
|
0
|
|
|
0
|
1 while $$scalar_ref and $self->run_one_timeslice(); |
1232
|
|
|
|
|
|
|
} |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
sub run_one_timeslice { |
1235
|
0
|
|
|
0
|
1
|
0
|
my $self = $poe_kernel; |
1236
|
|
|
|
|
|
|
|
1237
|
0
|
100
|
|
|
|
0
|
unless ($self->_data_ses_count()) { |
1238
|
0
|
|
|
|
|
0
|
$self->_finalize_kernel(); |
1239
|
0
|
|
|
|
|
0
|
$kr_run_warning |= KR_RUN_DONE; |
1240
|
0
|
100
|
|
|
|
0
|
$kr_exception and $self->_rethrow_kr_exception(); |
1241
|
0
|
|
|
|
|
0
|
return; |
1242
|
|
|
|
|
|
|
} |
1243
|
|
|
|
|
|
|
|
1244
|
0
|
|
|
|
|
0
|
$self->loop_do_timeslice(); |
1245
|
0
|
100
|
|
|
|
0
|
$kr_exception and $self->_rethrow_kr_exception(); |
1246
|
|
|
|
|
|
|
|
1247
|
0
|
|
|
|
|
0
|
return 1; |
1248
|
|
|
|
|
|
|
} |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
sub run { |
1251
|
|
|
|
|
|
|
# So run() can be called as a class method. |
1252
|
201
|
100
|
|
201
|
1
|
9931
|
POE::Kernel->new unless defined $poe_kernel; |
1253
|
201
|
|
|
|
|
347
|
my $self = $poe_kernel; |
1254
|
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
|
# Flag that run() was called. |
1256
|
201
|
|
|
|
|
923
|
$kr_run_warning |= KR_RUN_CALLED; |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
# TODO is this check expensive? ( do people run() more than 1 time? ) |
1259
|
201
|
100
|
|
|
|
1395
|
if( $kr_pid != $$ ) { |
1260
|
0
|
|
|
|
|
0
|
if ( ASSERT_USAGE ) { |
1261
|
|
|
|
|
|
|
_warn "Detected a fork, automatically calling ->has_forked()"; |
1262
|
|
|
|
|
|
|
} |
1263
|
0
|
|
|
|
|
0
|
$self->has_forked; |
1264
|
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
# Don't run the loop if we have no sessions |
1267
|
|
|
|
|
|
|
# Loop::Event will blow up, so we're doing this sanity check |
1268
|
34
|
50
|
|
|
|
304
|
if ( $self->_data_ses_count() == 0 ) { |
1269
|
|
|
|
|
|
|
# Emit noise only if we are under debug mode |
1270
|
167
|
|
|
|
|
1919
|
if ( ASSERT_DATA ) { |
1271
|
|
|
|
|
|
|
_warn("Not running the event loop because we have no sessions!\n"); |
1272
|
|
|
|
|
|
|
} |
1273
|
|
|
|
|
|
|
} else { |
1274
|
|
|
|
|
|
|
# All signals must be explicitly watched now. We do it here because |
1275
|
|
|
|
|
|
|
# it's too early in initialize_kernel_session. |
1276
|
33
|
|
|
|
|
178
|
$self->_data_sig_add($self, "IDLE", EN_SIGNAL); |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
# Run the loop! |
1279
|
35
|
|
|
|
|
180
|
$self->loop_run(); |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
# Cleanup |
1282
|
190
|
|
|
|
|
1378
|
$self->_finalize_kernel(); |
1283
|
|
|
|
|
|
|
} |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
# Clean up afterwards. |
1286
|
190
|
|
|
|
|
1066
|
$kr_run_warning |= KR_RUN_DONE; |
1287
|
|
|
|
|
|
|
|
1288
|
190
|
100
|
|
|
|
814
|
$kr_exception and $self->_rethrow_kr_exception(); |
1289
|
|
|
|
|
|
|
} |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
sub _rethrow_kr_exception { |
1292
|
179
|
|
|
11
|
|
373
|
my $self = shift; |
1293
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
# It's quite common to see people wrap POE::Kernel->run() in an eval |
1295
|
|
|
|
|
|
|
# block and start things again if an exception is caught. |
1296
|
|
|
|
|
|
|
# |
1297
|
|
|
|
|
|
|
# This little lexical dance is actually important. It allows |
1298
|
|
|
|
|
|
|
# $kr_exception to be cleared if the die() is caught. |
1299
|
|
|
|
|
|
|
|
1300
|
177
|
|
|
|
|
831
|
my $exception = $kr_exception; |
1301
|
11
|
|
|
|
|
18
|
$kr_exception = undef; |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
# The die is cast. |
1304
|
11
|
|
|
|
|
42
|
die $exception; |
1305
|
|
|
|
|
|
|
} |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
# Stops the kernel cold. XXX Experimental! |
1308
|
|
|
|
|
|
|
# No events happen as a result of this, all structures are cleaned up |
1309
|
|
|
|
|
|
|
# except the kernel's. Even the current session and POE::Kernel are |
1310
|
|
|
|
|
|
|
# cleaned up, which may introduce inconsistencies in the current |
1311
|
|
|
|
|
|
|
# session... as _dispatch_event() attempts to clean up for a defunct |
1312
|
|
|
|
|
|
|
# session. |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
sub stop { |
1315
|
|
|
|
|
|
|
# So stop() can be called as a class method. |
1316
|
18
|
|
|
18
|
1
|
47
|
my $self = $poe_kernel; |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
# May be called when the kernel's already stopped. Avoid problems |
1319
|
|
|
|
|
|
|
# trying to find child sessions when the kernel isn't registered. |
1320
|
18
|
100
|
|
|
|
53
|
if ($self->_data_ses_exists($self->ID)) { |
1321
|
7
|
|
|
|
|
21
|
my @children = ($self); |
1322
|
7
|
|
|
|
|
15
|
foreach my $session (@children) { |
1323
|
19
|
|
|
|
|
41
|
push @children, $self->_data_ses_get_children($session->ID); |
1324
|
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
|
# Don't stop believin'. Nor the POE::Kernel singleton. |
1327
|
7
|
|
|
|
|
13
|
shift @children; |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
# Walk backwards to avoid inconsistency errors. |
1330
|
7
|
|
|
|
|
16
|
foreach my $session (reverse @children) { |
1331
|
12
|
|
|
|
|
49
|
$self->_data_ses_stop($session->ID); |
1332
|
|
|
|
|
|
|
} |
1333
|
|
|
|
|
|
|
} |
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
# Roll back whether sessions were started. |
1336
|
18
|
|
|
|
|
78
|
$kr_run_warning &= ~KR_RUN_SESSION; |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
# So new sessions will not be child of the current defunct session. |
1339
|
18
|
|
|
|
|
27
|
$kr_active_session = $self; |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
# The GC mark list may prevent sessions from DESTROYing. |
1342
|
|
|
|
|
|
|
# Clean it up. |
1343
|
18
|
|
|
|
|
68
|
$self->_data_ses_gc_sweep(); |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
# Running stop() is recommended in a POE::Wheel::Run coderef |
1346
|
|
|
|
|
|
|
# Program, before setting up for the next POE::Kernel->run(). When |
1347
|
|
|
|
|
|
|
# the PID has changed, imply _data_sig_has_forked() during stop(). |
1348
|
|
|
|
|
|
|
|
1349
|
18
|
50
|
|
|
|
108
|
$poe_kernel->has_forked() if $kr_pid != $$; |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
# TODO - If we're polling for signals, then the reset gets it wrong. |
1352
|
|
|
|
|
|
|
# The reset doesn't count sigchld polling. If we must put this |
1353
|
|
|
|
|
|
|
# back, it MUST account for all internal events currently in play, |
1354
|
|
|
|
|
|
|
# or the child process will stall if it reruns POE::Kernel's loop. |
1355
|
|
|
|
|
|
|
#_idle_queue_reset(); |
1356
|
|
|
|
|
|
|
|
1357
|
18
|
|
|
|
|
81
|
return; |
1358
|
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
# Less invasive form of ->stop() + ->run() |
1361
|
|
|
|
|
|
|
sub has_forked { |
1362
|
4
|
50
|
|
4
|
1
|
3831
|
if( $kr_pid == $$ ) { |
1363
|
0
|
|
|
|
|
0
|
if ( ASSERT_USAGE ) { |
1364
|
|
|
|
|
|
|
_warn "You should only call ->has_forked() from the child process."; |
1365
|
|
|
|
|
|
|
} |
1366
|
0
|
|
|
|
|
0
|
return; |
1367
|
|
|
|
|
|
|
} |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
# So has_forked() can be called as a class method. |
1370
|
0
|
|
|
|
|
0
|
my $self = $poe_kernel; |
1371
|
|
|
|
|
|
|
|
1372
|
4
|
|
|
|
|
87
|
$kr_pid = $$; |
1373
|
4
|
|
|
|
|
63
|
$self->_recalc_id(); |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
# reset some stuff for the signals |
1376
|
4
|
|
|
|
|
174
|
$poe_kernel->_data_sig_has_forked; |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1380
|
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
|
sub DESTROY { |
1382
|
4
|
|
|
0
|
|
73
|
my $self = shift; |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
# Warn that a session never had the opportunity to run if one was |
1385
|
|
|
|
|
|
|
# created but run() was never called. |
1386
|
|
|
|
|
|
|
|
1387
|
0
|
0
|
|
|
|
0
|
unless ($kr_run_warning & KR_RUN_CALLED) { |
1388
|
0
|
0
|
|
|
|
0
|
if ($kr_run_warning & KR_RUN_SESSION) { |
1389
|
0
|
|
|
|
|
0
|
_warn( |
1390
|
|
|
|
|
|
|
"Sessions were started, but POE::Kernel's run() method was never\n", |
1391
|
|
|
|
|
|
|
"called to execute them. This usually happens because an error\n", |
1392
|
|
|
|
|
|
|
"occurred before POE::Kernel->run() could be called. Please fix\n", |
1393
|
|
|
|
|
|
|
"any errors above this notice, and be sure that POE::Kernel->run()\n", |
1394
|
|
|
|
|
|
|
"is called. See documentation for POE::Kernel's run() method for\n", |
1395
|
|
|
|
|
|
|
"another way to disable this warning.\n", |
1396
|
|
|
|
|
|
|
); |
1397
|
|
|
|
|
|
|
} |
1398
|
|
|
|
|
|
|
} |
1399
|
|
|
|
|
|
|
} |
1400
|
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1402
|
|
|
|
|
|
|
# _invoke_state is what _dispatch_event calls to dispatch a transition |
1403
|
|
|
|
|
|
|
# event. This is the kernel's _invoke_state so it can receive events. |
1404
|
|
|
|
|
|
|
# These are mostly signals, which are propagated down in |
1405
|
|
|
|
|
|
|
# _dispatch_event. |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
sub _invoke_state { |
1408
|
1617
|
|
|
1617
|
|
3330
|
my ($self, $source_session, $event, $etc) = @_; |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
# This is an event loop to poll for child processes without needing |
1411
|
|
|
|
|
|
|
# to catch SIGCHLD. |
1412
|
|
|
|
|
|
|
|
1413
|
1617
|
100
|
|
|
|
5040
|
if ($event eq EN_SCPOLL) { |
|
|
100
|
|
|
|
|
|
1414
|
369
|
|
|
|
|
2243
|
$self->_data_sig_handle_poll_event($etc->[0]); |
1415
|
|
|
|
|
|
|
} |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
# A signal was posted. Because signals propagate depth-first, this |
1418
|
|
|
|
|
|
|
# _invoke_state is called last in the dispatch. If the signal was |
1419
|
|
|
|
|
|
|
# SIGIDLE, then post a SIGZOMBIE if the main queue is still idle. |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
elsif ($event eq EN_SIGNAL) { |
1422
|
190
|
50
|
|
|
|
746
|
if ($etc->[0] eq 'IDLE') { |
1423
|
190
|
50
|
33
|
|
|
706
|
unless ( |
1424
|
|
|
|
|
|
|
$kr_queue->get_item_count() > $idle_queue_size or |
1425
|
|
|
|
|
|
|
$self->_data_handle_count() |
1426
|
|
|
|
|
|
|
) { |
1427
|
190
|
|
|
|
|
1967
|
$self->_data_ev_enqueue( |
1428
|
|
|
|
|
|
|
$self, $self, EN_SIGNAL, ET_SIGNAL, [ 'ZOMBIE' ], |
1429
|
|
|
|
|
|
|
__FILE__, __LINE__, undef |
1430
|
|
|
|
|
|
|
); |
1431
|
|
|
|
|
|
|
} |
1432
|
|
|
|
|
|
|
} |
1433
|
|
|
|
|
|
|
} |
1434
|
|
|
|
|
|
|
|
1435
|
1617
|
|
|
|
|
3089
|
return 0; |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
#============================================================================== |
1439
|
|
|
|
|
|
|
# SESSIONS |
1440
|
|
|
|
|
|
|
#============================================================================== |
1441
|
|
|
|
|
|
|
|
1442
|
|
|
|
|
|
|
# Dispatch _start to a session, allocating it in the kernel's data |
1443
|
|
|
|
|
|
|
# structures as a side effect. |
1444
|
|
|
|
|
|
|
|
1445
|
|
|
|
|
|
|
sub session_alloc { |
1446
|
813
|
|
|
813
|
1
|
3146
|
my ($self, $session, @args) = ($poe_kernel, @_[1..$#_]); |
1447
|
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
|
# If we already returned, then we must reinitialize. This is so |
1449
|
|
|
|
|
|
|
# $poe_kernel->run() will work correctly more than once. |
1450
|
813
|
100
|
|
|
|
2167
|
if ($kr_run_warning & KR_RUN_DONE) { |
1451
|
94
|
|
|
|
|
138
|
$kr_run_warning &= ~KR_RUN_DONE; |
1452
|
94
|
|
|
|
|
273
|
$self->_initialize_kernel_session(); |
1453
|
94
|
|
|
|
|
373
|
$self->_data_sig_initialize(); |
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
|
1456
|
813
|
|
|
|
|
940
|
if (ASSERT_DATA) { |
1457
|
|
|
|
|
|
|
if (defined $session->ID) { |
1458
|
|
|
|
|
|
|
_trap( |
1459
|
|
|
|
|
|
|
" ", $self->_data_alias_loggable($session->ID), |
1460
|
|
|
|
|
|
|
" already allocated\a" |
1461
|
|
|
|
|
|
|
); |
1462
|
|
|
|
|
|
|
} |
1463
|
|
|
|
|
|
|
} |
1464
|
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
|
# Register that a session was created. |
1466
|
813
|
|
|
|
|
2107
|
$kr_run_warning |= KR_RUN_SESSION; |
1467
|
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
|
# Allocate the session's data structure. This must be done before |
1469
|
|
|
|
|
|
|
# we dispatch anything regarding the new session. |
1470
|
155
|
|
|
|
|
947
|
my $new_sid = $self->_data_sid_allocate(); |
1471
|
812
|
|
|
|
|
1769
|
$session->_set_id($new_sid); |
1472
|
812
|
|
|
|
|
3382
|
$self->_data_ses_allocate($session, $new_sid, $kr_active_session->ID); |
1473
|
|
|
|
|
|
|
|
1474
|
812
|
|
|
|
|
2947
|
my $loggable = $self->_data_alias_loggable($new_sid); |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
# Tell the new session that it has been created. Catch the _start |
1477
|
|
|
|
|
|
|
# state's return value so we can pass it to the parent with the |
1478
|
|
|
|
|
|
|
# _child create. |
1479
|
|
|
|
|
|
|
# |
1480
|
|
|
|
|
|
|
# TODO - Void the context if the parent has no _child handler? |
1481
|
|
|
|
|
|
|
|
1482
|
812
|
|
|
|
|
2776
|
my $return = $self->_dispatch_event( |
1483
|
|
|
|
|
|
|
$session, $kr_active_session, |
1484
|
|
|
|
|
|
|
EN_START, ET_START, \@args, |
1485
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
1486
|
|
|
|
|
|
|
); |
1487
|
|
|
|
|
|
|
|
1488
|
798
|
100
|
|
|
|
3913
|
unless($self->_data_ses_exists($new_sid)) { |
1489
|
658
|
|
|
|
|
4400
|
if(TRACE_SESSIONS) { |
1490
|
|
|
|
|
|
|
_warn(" ", $loggable, " disappeared during ", EN_START); |
1491
|
|
|
|
|
|
|
} |
1492
|
608
|
|
|
|
|
3087
|
return $return; |
1493
|
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
# If the child has not detached itself---that is, if its parent is |
1496
|
|
|
|
|
|
|
# the currently active session---then notify the parent with a |
1497
|
|
|
|
|
|
|
# _child create event. Otherwise skip it, since we'd otherwise |
1498
|
|
|
|
|
|
|
# throw a create without a lose. |
1499
|
|
|
|
|
|
|
$self->_dispatch_event( |
1500
|
126
|
|
|
|
|
403
|
$self->_data_ses_get_parent($session->ID), $self, |
1501
|
|
|
|
|
|
|
EN_CHILD, ET_CHILD, [ CHILD_CREATE, $session, $return ], |
1502
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
1503
|
|
|
|
|
|
|
); |
1504
|
|
|
|
|
|
|
|
1505
|
140
|
50
|
|
|
|
457
|
unless ($self->_data_ses_exists($new_sid)) { |
1506
|
249
|
|
|
|
|
768
|
if (TRACE_SESSIONS) { |
1507
|
|
|
|
|
|
|
_warn(" ", $loggable, " disappeared during ", EN_CHILD, " dispatch"); |
1508
|
|
|
|
|
|
|
} |
1509
|
608
|
|
|
|
|
2201
|
return $return; |
1510
|
|
|
|
|
|
|
} |
1511
|
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
# Enqueue a delayed garbage-collection event so the session has time |
1513
|
|
|
|
|
|
|
# to do its thing before it goes. |
1514
|
|
|
|
|
|
|
$self->_data_ev_enqueue( |
1515
|
499
|
|
|
|
|
2680
|
$session, $session, EN_GC, ET_GC, [], |
1516
|
|
|
|
|
|
|
__FILE__, __LINE__, undef |
1517
|
|
|
|
|
|
|
); |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
# Detach a session from its parent. This breaks the parent/child |
1521
|
|
|
|
|
|
|
# relationship between the current session and its parent. Basically, |
1522
|
|
|
|
|
|
|
# the current session is given to the Kernel session. Unlike with |
1523
|
|
|
|
|
|
|
# _stop, the current session's children follow their parent. |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
sub detach_myself { |
1526
|
11
|
|
|
11
|
1
|
1022
|
my $self = $poe_kernel; |
1527
|
|
|
|
|
|
|
|
1528
|
260
|
|
|
|
|
2220
|
if (ASSERT_USAGE) { |
1529
|
|
|
|
|
|
|
_confess " must call detach_myself() from a running session" |
1530
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1531
|
|
|
|
|
|
|
} |
1532
|
|
|
|
|
|
|
|
1533
|
|
|
|
|
|
|
# Can't detach from the kernel. |
1534
|
11
|
100
|
|
|
|
38
|
if ($self->_data_ses_get_parent($kr_active_session->ID) == $self) { |
1535
|
383
|
|
|
|
|
5154
|
$! = EPERM; |
1536
|
0
|
|
|
|
|
0
|
return; |
1537
|
|
|
|
|
|
|
} |
1538
|
|
|
|
|
|
|
|
1539
|
0
|
|
|
|
|
0
|
my $old_parent = $self->_data_ses_get_parent($kr_active_session->ID); |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# Tell the old parent session that the child is departing. |
1542
|
|
|
|
|
|
|
# But not if the active event is ET_START, since that would generate |
1543
|
|
|
|
|
|
|
# a CHILD_LOSE without a CHILD_CREATE. |
1544
|
10
|
50
|
|
|
|
26
|
$self->_dispatch_event( |
1545
|
|
|
|
|
|
|
$old_parent, $self, |
1546
|
|
|
|
|
|
|
EN_CHILD, ET_CHILD, [ CHILD_LOSE, $kr_active_session, undef ], |
1547
|
|
|
|
|
|
|
(caller)[1,2], undef, monotime(), -__LINE__ |
1548
|
|
|
|
|
|
|
) |
1549
|
|
|
|
|
|
|
unless $kr_active_event_type & ET_START; |
1550
|
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
# Tell the new parent (kernel) that it's gaining a child. |
1552
|
|
|
|
|
|
|
# (Actually it doesn't care, so we don't do that here, but this is |
1553
|
|
|
|
|
|
|
# where the code would go if it ever does in the future.) |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
# Tell the current session that its parentage is changing. |
1556
|
10
|
|
|
|
|
88
|
$self->_dispatch_event( |
1557
|
|
|
|
|
|
|
$kr_active_session, $self, |
1558
|
|
|
|
|
|
|
EN_PARENT, ET_PARENT, [ $old_parent, $self ], |
1559
|
|
|
|
|
|
|
(caller)[1,2], undef, monotime(), -__LINE__ |
1560
|
|
|
|
|
|
|
); |
1561
|
|
|
|
|
|
|
|
1562
|
10
|
|
|
|
|
82
|
$self->_data_ses_move_child($kr_active_session->ID, $self->ID); |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
# Success! |
1565
|
10
|
|
|
|
|
40
|
return 1; |
1566
|
|
|
|
|
|
|
} |
1567
|
|
|
|
|
|
|
|
1568
|
|
|
|
|
|
|
# Detach a child from this, the parent. The session being detached |
1569
|
|
|
|
|
|
|
# must be a child of the current session. |
1570
|
|
|
|
|
|
|
|
1571
|
|
|
|
|
|
|
sub detach_child { |
1572
|
20
|
|
|
10
|
1
|
1943
|
my ($self, $child) = ($poe_kernel, @_[1..$#_]); |
1573
|
|
|
|
|
|
|
|
1574
|
10
|
|
|
|
|
11
|
if (ASSERT_USAGE) { |
1575
|
|
|
|
|
|
|
_confess " must call detach_child() from a running session" |
1576
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1577
|
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
|
|
1579
|
10
|
|
|
|
|
29
|
my $child_session = $self->_resolve_session($child); |
1580
|
9
|
100
|
|
|
|
36
|
unless (defined $child_session) { |
1581
|
9
|
|
|
|
|
22
|
$self->_explain_resolve_failure($child); |
1582
|
0
|
|
|
|
|
0
|
return; |
1583
|
|
|
|
|
|
|
} |
1584
|
|
|
|
|
|
|
|
1585
|
|
|
|
|
|
|
# Can't detach if it belongs to the kernel. TODO We shouldn't need |
1586
|
|
|
|
|
|
|
# to check for this. |
1587
|
0
|
50
|
|
|
|
0
|
if ($kr_active_session == $self) { |
1588
|
8
|
|
|
|
|
13
|
$! = EPERM; |
1589
|
0
|
|
|
|
|
0
|
return; |
1590
|
|
|
|
|
|
|
} |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
# Can't detach if it's not a child of the current session. |
1593
|
0
|
50
|
|
|
|
0
|
unless ( |
1594
|
|
|
|
|
|
|
$self->_data_ses_is_child($kr_active_session->ID, $child_session->ID) |
1595
|
|
|
|
|
|
|
) { |
1596
|
8
|
|
|
|
|
21
|
$! = EPERM; |
1597
|
0
|
|
|
|
|
0
|
return; |
1598
|
|
|
|
|
|
|
} |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
# Tell the current session that the child is departing. |
1601
|
|
|
|
|
|
|
$self->_dispatch_event( |
1602
|
0
|
|
|
|
|
0
|
$kr_active_session, $self, |
1603
|
|
|
|
|
|
|
EN_CHILD, ET_CHILD, [ CHILD_LOSE, $child_session, undef ], |
1604
|
|
|
|
|
|
|
(caller)[1,2], undef, monotime(), -__LINE__ |
1605
|
|
|
|
|
|
|
); |
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
# Tell the new parent (kernel) that it's gaining a child. |
1608
|
|
|
|
|
|
|
# (Actually it doesn't care, so we don't do that here, but this is |
1609
|
|
|
|
|
|
|
# where the code would go if it ever does in the future.) |
1610
|
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
|
# Tell the child session that its parentage is changing. |
1612
|
8
|
|
|
|
|
52
|
$self->_dispatch_event( |
1613
|
|
|
|
|
|
|
$child_session, $self, |
1614
|
|
|
|
|
|
|
EN_PARENT, ET_PARENT, [ $kr_active_session, $self ], |
1615
|
|
|
|
|
|
|
(caller)[1,2], undef, monotime(), -__LINE__ |
1616
|
|
|
|
|
|
|
); |
1617
|
|
|
|
|
|
|
|
1618
|
8
|
|
|
|
|
58
|
$self->_data_ses_move_child($child_session->ID, $self->ID); |
1619
|
|
|
|
|
|
|
|
1620
|
|
|
|
|
|
|
# Success! |
1621
|
8
|
|
|
|
|
32
|
return 1; |
1622
|
|
|
|
|
|
|
} |
1623
|
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
|
### Helpful accessors. |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
sub get_active_session { |
1627
|
1027
|
|
|
1019
|
1
|
7839
|
return $kr_active_session; |
1628
|
|
|
|
|
|
|
} |
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
sub get_active_event { |
1631
|
0
|
|
|
0
|
1
|
0
|
return $kr_active_event; |
1632
|
|
|
|
|
|
|
} |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
# FIXME - Should this exist? |
1635
|
|
|
|
|
|
|
sub get_event_count { |
1636
|
0
|
|
|
0
|
1
|
0
|
return $kr_queue->get_item_count(); |
1637
|
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
# FIXME - Should this exist? |
1640
|
|
|
|
|
|
|
sub get_next_event_time { |
1641
|
0
|
|
|
0
|
1
|
0
|
return $kr_queue->get_next_priority(); |
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
#============================================================================== |
1645
|
|
|
|
|
|
|
# EVENTS |
1646
|
|
|
|
|
|
|
#============================================================================== |
1647
|
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1649
|
|
|
|
|
|
|
# Post an event to the queue. |
1650
|
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
|
sub post { |
1652
|
326
|
|
|
326
|
1
|
14850
|
my ($self, $dest_session, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); |
1653
|
|
|
|
|
|
|
|
1654
|
326
|
|
|
|
|
605
|
if (ASSERT_USAGE) { |
1655
|
|
|
|
|
|
|
_confess " destination is undefined in post()" |
1656
|
|
|
|
|
|
|
unless defined $dest_session; |
1657
|
|
|
|
|
|
|
_confess " event is undefined in post()" unless defined $event_name; |
1658
|
|
|
|
|
|
|
_carp( |
1659
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1660
|
|
|
|
|
|
|
"effect cannot be achieved by posting it" |
1661
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1662
|
|
|
|
|
|
|
}; |
1663
|
|
|
|
|
|
|
|
1664
|
|
|
|
|
|
|
# Attempt to resolve the destination session reference against |
1665
|
|
|
|
|
|
|
# various things. |
1666
|
|
|
|
|
|
|
|
1667
|
326
|
|
|
|
|
674
|
my $session = $self->_resolve_session($dest_session); |
1668
|
325
|
100
|
|
|
|
593
|
unless (defined $session) { |
1669
|
317
|
|
|
|
|
753
|
$self->_explain_resolve_failure($dest_session); |
1670
|
316
|
|
|
|
|
753
|
return; |
1671
|
|
|
|
|
|
|
} |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# Enqueue the event for "now", which simulates FIFO in our |
1674
|
|
|
|
|
|
|
# time-ordered queue. |
1675
|
|
|
|
|
|
|
|
1676
|
|
|
|
|
|
|
$self->_data_ev_enqueue( |
1677
|
323
|
|
|
|
|
665
|
$session, $kr_active_session, $event_name, ET_POST, \@etc, |
1678
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event |
1679
|
|
|
|
|
|
|
); |
1680
|
7
|
|
|
|
|
17
|
return 1; |
1681
|
|
|
|
|
|
|
} |
1682
|
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1684
|
|
|
|
|
|
|
# Post an event to the queue for the current session. |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
sub yield { |
1687
|
752
|
|
|
752
|
1
|
4034861
|
my ($self, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); |
1688
|
|
|
|
|
|
|
|
1689
|
1068
|
|
|
|
|
2536
|
if (ASSERT_USAGE) { |
1690
|
|
|
|
|
|
|
_confess " must call yield() from a running session" |
1691
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1692
|
|
|
|
|
|
|
_confess " event name is undefined in yield()" |
1693
|
|
|
|
|
|
|
unless defined $event_name; |
1694
|
|
|
|
|
|
|
_carp( |
1695
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1696
|
|
|
|
|
|
|
"effect cannot be achieved by yielding it" |
1697
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1698
|
|
|
|
|
|
|
}; |
1699
|
|
|
|
|
|
|
|
1700
|
1068
|
|
|
|
|
3429
|
$self->_data_ev_enqueue( |
1701
|
|
|
|
|
|
|
$kr_active_session, $kr_active_session, $event_name, ET_POST, \@etc, |
1702
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event |
1703
|
|
|
|
|
|
|
); |
1704
|
|
|
|
|
|
|
|
1705
|
751
|
|
|
|
|
1708
|
undef; |
1706
|
|
|
|
|
|
|
} |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1709
|
|
|
|
|
|
|
# Call an event handler directly. |
1710
|
|
|
|
|
|
|
|
1711
|
|
|
|
|
|
|
sub call { |
1712
|
4265
|
|
|
3572
|
1
|
24261
|
my ($self, $dest_session, $event_name, @etc) = ($poe_kernel, @_[1..$#_]); |
1713
|
|
|
|
|
|
|
|
1714
|
4265
|
|
|
|
|
7715
|
if (ASSERT_USAGE) { |
1715
|
|
|
|
|
|
|
_confess " destination is undefined in call()" |
1716
|
|
|
|
|
|
|
unless defined $dest_session; |
1717
|
|
|
|
|
|
|
_confess " event is undefined in call()" unless defined $event_name; |
1718
|
|
|
|
|
|
|
_carp( |
1719
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1720
|
|
|
|
|
|
|
"effect cannot be achieved by calling it" |
1721
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1722
|
|
|
|
|
|
|
}; |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
# Attempt to resolve the destination session reference against |
1725
|
|
|
|
|
|
|
# various things. |
1726
|
|
|
|
|
|
|
|
1727
|
4265
|
|
|
|
|
9205
|
my $session = $self->_resolve_session($dest_session); |
1728
|
3571
|
100
|
|
|
|
5437
|
unless (defined $session) { |
1729
|
1122
|
|
|
|
|
2441
|
$self->_explain_resolve_failure($dest_session); |
1730
|
1121
|
|
|
|
|
2375
|
return; |
1731
|
|
|
|
|
|
|
} |
1732
|
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
# Dispatch the event right now, bypassing the queue altogether. |
1734
|
|
|
|
|
|
|
# This tends to be a Bad Thing to Do. |
1735
|
|
|
|
|
|
|
|
1736
|
|
|
|
|
|
|
# TODO The difference between synchronous and asynchronous events |
1737
|
|
|
|
|
|
|
# should be made more clear in the documentation, so that people |
1738
|
|
|
|
|
|
|
# have a tendency not to abuse them. I discovered in xws that |
1739
|
|
|
|
|
|
|
# mixing the two types makes it harder than necessary to write |
1740
|
|
|
|
|
|
|
# deterministic programs, but the difficulty can be ameliorated if |
1741
|
|
|
|
|
|
|
# programmers set some base rules and stick to them. |
1742
|
|
|
|
|
|
|
|
1743
|
3569
|
100
|
|
|
|
5590
|
if (wantarray) { |
1744
|
2
|
100
|
|
|
|
18
|
my @return_value = ( |
1745
|
|
|
|
|
|
|
($session == $kr_active_session) |
1746
|
|
|
|
|
|
|
? $session->_invoke_state( |
1747
|
|
|
|
|
|
|
$session, $event_name, \@etc, (caller)[1,2], |
1748
|
|
|
|
|
|
|
$kr_active_event |
1749
|
|
|
|
|
|
|
) |
1750
|
|
|
|
|
|
|
: $self->_dispatch_event( |
1751
|
|
|
|
|
|
|
$session, $kr_active_session, |
1752
|
|
|
|
|
|
|
$event_name, ET_CALL, \@etc, |
1753
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, monotime(), -__LINE__ |
1754
|
|
|
|
|
|
|
) |
1755
|
|
|
|
|
|
|
); |
1756
|
|
|
|
|
|
|
|
1757
|
1
|
50
|
|
|
|
403
|
$kr_exception and $self->_rethrow_kr_exception(); |
1758
|
|
|
|
|
|
|
|
1759
|
1122
|
|
|
|
|
1952
|
$! = 0; |
1760
|
1
|
|
|
|
|
4
|
return @return_value; |
1761
|
|
|
|
|
|
|
} |
1762
|
|
|
|
|
|
|
|
1763
|
2446
|
100
|
|
|
|
3764
|
if (defined wantarray) { |
1764
|
2
|
50
|
|
|
|
17
|
my $return_value = ( |
1765
|
|
|
|
|
|
|
$session == $kr_active_session |
1766
|
|
|
|
|
|
|
? $session->_invoke_state( |
1767
|
|
|
|
|
|
|
$session, $event_name, \@etc, (caller)[1,2], |
1768
|
|
|
|
|
|
|
$kr_active_event |
1769
|
|
|
|
|
|
|
) |
1770
|
|
|
|
|
|
|
: $self->_dispatch_event( |
1771
|
|
|
|
|
|
|
$session, $kr_active_session, |
1772
|
|
|
|
|
|
|
$event_name, ET_CALL, \@etc, |
1773
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, monotime(), -__LINE__ |
1774
|
|
|
|
|
|
|
) |
1775
|
|
|
|
|
|
|
); |
1776
|
|
|
|
|
|
|
|
1777
|
2
|
50
|
|
|
|
820
|
$kr_exception and $self->_rethrow_kr_exception(); |
1778
|
|
|
|
|
|
|
|
1779
|
1123
|
|
|
|
|
2004
|
$! = 0; |
1780
|
167
|
|
|
|
|
957
|
return $return_value; |
1781
|
|
|
|
|
|
|
} |
1782
|
|
|
|
|
|
|
|
1783
|
2609
|
100
|
|
|
|
5394
|
if ($session == $kr_active_session) { |
1784
|
2600
|
|
|
|
|
9722
|
$session->_invoke_state( |
1785
|
|
|
|
|
|
|
$session, $event_name, \@etc, (caller)[1,2], |
1786
|
|
|
|
|
|
|
$kr_active_event |
1787
|
|
|
|
|
|
|
); |
1788
|
|
|
|
|
|
|
} |
1789
|
|
|
|
|
|
|
else { |
1790
|
174
|
|
|
|
|
428
|
$self->_dispatch_event( |
1791
|
|
|
|
|
|
|
$session, $kr_active_session, |
1792
|
|
|
|
|
|
|
$event_name, ET_CALL, \@etc, |
1793
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, monotime(), -__LINE__ |
1794
|
|
|
|
|
|
|
); |
1795
|
|
|
|
|
|
|
} |
1796
|
|
|
|
|
|
|
|
1797
|
3389
|
50
|
|
|
|
24995
|
$kr_exception and $self->_rethrow_kr_exception(); |
1798
|
|
|
|
|
|
|
|
1799
|
3323
|
|
|
|
|
7780
|
$! = 0; |
1800
|
2499
|
|
|
|
|
8647
|
return; |
1801
|
|
|
|
|
|
|
} |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
#============================================================================== |
1804
|
|
|
|
|
|
|
# DELAYED EVENTS |
1805
|
|
|
|
|
|
|
#============================================================================== |
1806
|
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
|
sub alarm { |
1808
|
3659
|
|
|
2703
|
1
|
59269
|
my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); |
1809
|
|
|
|
|
|
|
|
1810
|
3659
|
|
|
|
|
4403
|
if (ASSERT_USAGE) { |
1811
|
|
|
|
|
|
|
_confess " must call alarm() from a running session" |
1812
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1813
|
|
|
|
|
|
|
_confess " event name is undefined in alarm()" |
1814
|
|
|
|
|
|
|
unless defined $event_name; |
1815
|
|
|
|
|
|
|
_carp( |
1816
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1817
|
|
|
|
|
|
|
"effect cannot be achieved by setting an alarm for it" |
1818
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1819
|
|
|
|
|
|
|
}; |
1820
|
|
|
|
|
|
|
|
1821
|
3659
|
100
|
|
|
|
10724
|
unless (defined $event_name) { |
1822
|
2541
|
|
|
|
|
4129
|
$self->_explain_return("invalid parameter to alarm() call"); |
1823
|
2539
|
|
|
|
|
5451
|
return EINVAL; |
1824
|
|
|
|
|
|
|
} |
1825
|
|
|
|
|
|
|
|
1826
|
2700
|
|
|
|
|
4443
|
$self->_data_ev_clear_alarm_by_name($kr_active_session->ID(), $event_name); |
1827
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
# Add the new alarm if it includes a time. Calling _data_ev_enqueue |
1829
|
|
|
|
|
|
|
# directly is faster than calling alarm_set to enqueue it. |
1830
|
161
|
50
|
|
|
|
484
|
if (defined $time) { |
1831
|
0
|
|
|
|
|
0
|
$self->_data_ev_enqueue |
1832
|
|
|
|
|
|
|
( $kr_active_session, $kr_active_session, |
1833
|
|
|
|
|
|
|
$event_name, ET_ALARM, [ @etc ], |
1834
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, $time, |
1835
|
|
|
|
|
|
|
); |
1836
|
|
|
|
|
|
|
} |
1837
|
|
|
|
|
|
|
else { |
1838
|
|
|
|
|
|
|
# The event queue has become empty? Stop the time watcher. |
1839
|
2700
|
100
|
|
|
|
5053
|
$self->loop_pause_time_watcher() unless $kr_queue->get_item_count(); |
1840
|
|
|
|
|
|
|
} |
1841
|
|
|
|
|
|
|
|
1842
|
2700
|
|
|
|
|
6823
|
return 0; |
1843
|
|
|
|
|
|
|
} |
1844
|
|
|
|
|
|
|
|
1845
|
|
|
|
|
|
|
# Add an alarm without clobbering previous alarms of the same name. |
1846
|
|
|
|
|
|
|
sub alarm_add { |
1847
|
1258
|
|
|
16
|
1
|
8785
|
my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); |
1848
|
|
|
|
|
|
|
|
1849
|
1313
|
|
|
|
|
2928
|
if (ASSERT_USAGE) { |
1850
|
|
|
|
|
|
|
_confess " must call alarm_add() from a running session" |
1851
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1852
|
|
|
|
|
|
|
_confess " undefined event name in alarm_add()" |
1853
|
|
|
|
|
|
|
unless defined $event_name; |
1854
|
|
|
|
|
|
|
_confess " undefined time in alarm_add()" unless defined $time; |
1855
|
|
|
|
|
|
|
_carp( |
1856
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1857
|
|
|
|
|
|
|
"effect cannot be achieved by adding an alarm for it" |
1858
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1859
|
|
|
|
|
|
|
}; |
1860
|
|
|
|
|
|
|
|
1861
|
2555
|
100
|
66
|
|
|
8121
|
unless (defined $event_name and defined $time) { |
1862
|
15
|
|
|
|
|
30
|
$self->_explain_return("invalid parameter to alarm_add() call"); |
1863
|
13
|
|
|
|
|
25
|
return EINVAL; |
1864
|
|
|
|
|
|
|
} |
1865
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
$self->_data_ev_enqueue |
1867
|
12
|
|
|
|
|
31
|
( $kr_active_session, $kr_active_session, |
1868
|
|
|
|
|
|
|
$event_name, ET_ALARM, [ @etc ], |
1869
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, $time, |
1870
|
|
|
|
|
|
|
); |
1871
|
|
|
|
|
|
|
|
1872
|
12
|
|
|
|
|
54
|
return 0; |
1873
|
|
|
|
|
|
|
} |
1874
|
|
|
|
|
|
|
|
1875
|
|
|
|
|
|
|
# Add a delay, which is like an alarm relative to the current time. |
1876
|
|
|
|
|
|
|
sub delay { |
1877
|
1066
|
|
|
1066
|
1
|
19869
|
my ($self, $event_name, $delay, @etc) = ($poe_kernel, @_[1..$#_]); |
1878
|
1066
|
|
|
|
|
3148
|
my $pri = monotime(); |
1879
|
|
|
|
|
|
|
|
1880
|
1078
|
|
|
|
|
1221
|
if (ASSERT_USAGE) { |
1881
|
|
|
|
|
|
|
_confess " must call delay() from a running session" |
1882
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1883
|
|
|
|
|
|
|
_confess " undefined event name in delay()" unless defined $event_name; |
1884
|
|
|
|
|
|
|
_carp( |
1885
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1886
|
|
|
|
|
|
|
"effect cannot be achieved by setting a delay for it" |
1887
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1888
|
|
|
|
|
|
|
}; |
1889
|
|
|
|
|
|
|
|
1890
|
1078
|
100
|
|
|
|
2883
|
unless (defined $event_name) { |
1891
|
289
|
|
|
|
|
699
|
$self->_explain_return("invalid parameter to delay() call"); |
1892
|
287
|
|
|
|
|
823
|
return EINVAL; |
1893
|
|
|
|
|
|
|
} |
1894
|
|
|
|
|
|
|
|
1895
|
1063
|
100
|
|
|
|
2327
|
if (defined $delay) { |
1896
|
615
|
|
|
|
|
1728
|
$self->_data_ev_clear_alarm_by_name($kr_active_session->ID(), $event_name); |
1897
|
|
|
|
|
|
|
|
1898
|
|
|
|
|
|
|
# Add the new alarm if it includes a time. Calling _data_ev_enqueue |
1899
|
|
|
|
|
|
|
# directly is faster than calling alarm_set to enqueue it. |
1900
|
615
|
|
|
|
|
5563
|
$self->_data_ev_enqueue |
1901
|
|
|
|
|
|
|
( $kr_active_session, $kr_active_session, |
1902
|
|
|
|
|
|
|
$event_name, ET_ALARM, [ @etc ], |
1903
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay |
1904
|
|
|
|
|
|
|
); |
1905
|
|
|
|
|
|
|
} |
1906
|
|
|
|
|
|
|
else { |
1907
|
448
|
|
|
|
|
1017
|
$self->alarm($event_name); |
1908
|
|
|
|
|
|
|
} |
1909
|
|
|
|
|
|
|
|
1910
|
1008
|
|
|
|
|
2872
|
return 0; |
1911
|
|
|
|
|
|
|
} |
1912
|
|
|
|
|
|
|
|
1913
|
|
|
|
|
|
|
# Add a delay without clobbering previous delays of the same name. |
1914
|
|
|
|
|
|
|
sub delay_add { |
1915
|
242
|
|
|
10
|
1
|
3087
|
my ($self, $event_name, $delay, @etc) = ($poe_kernel, @_[1..$#_]); |
1916
|
65
|
|
|
|
|
218
|
my $pri = monotime(); |
1917
|
|
|
|
|
|
|
|
1918
|
297
|
|
|
|
|
1068
|
if (ASSERT_USAGE) { |
1919
|
|
|
|
|
|
|
_confess " must call delay_add() from a running session" |
1920
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1921
|
|
|
|
|
|
|
_confess " undefined event name in delay_add()" |
1922
|
|
|
|
|
|
|
unless defined $event_name; |
1923
|
|
|
|
|
|
|
_confess " undefined time in delay_add()" unless defined $delay; |
1924
|
|
|
|
|
|
|
_carp( |
1925
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1926
|
|
|
|
|
|
|
"effect cannot be achieved by adding a delay for it" |
1927
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1928
|
|
|
|
|
|
|
}; |
1929
|
|
|
|
|
|
|
|
1930
|
10
|
100
|
66
|
|
|
36
|
unless (defined $event_name and defined $delay) { |
1931
|
9
|
|
|
|
|
32
|
$self->_explain_return("invalid parameter to delay_add() call"); |
1932
|
7
|
|
|
|
|
19
|
return EINVAL; |
1933
|
|
|
|
|
|
|
} |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
$self->_data_ev_enqueue |
1936
|
6
|
|
|
|
|
32
|
( $kr_active_session, $kr_active_session, |
1937
|
|
|
|
|
|
|
$event_name, ET_ALARM, [ @etc ], |
1938
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay |
1939
|
|
|
|
|
|
|
); |
1940
|
|
|
|
|
|
|
|
1941
|
6
|
|
|
|
|
54
|
return 0; |
1942
|
|
|
|
|
|
|
} |
1943
|
|
|
|
|
|
|
|
1944
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1945
|
|
|
|
|
|
|
# New style alarms. |
1946
|
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
|
# Set an alarm. This does more *and* less than plain alarm(). It |
1948
|
|
|
|
|
|
|
# only sets alarms (that's the less part), but it also returns an |
1949
|
|
|
|
|
|
|
# alarm ID (that's the more part). |
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
sub alarm_set { |
1952
|
241
|
|
|
241
|
1
|
5814
|
my ($self, $event_name, $time, @etc) = ($poe_kernel, @_[1..$#_]); |
1953
|
|
|
|
|
|
|
|
1954
|
241
|
|
|
|
|
222
|
if (ASSERT_USAGE) { |
1955
|
|
|
|
|
|
|
_confess " must call alarm_set() from a running session" |
1956
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1957
|
|
|
|
|
|
|
} |
1958
|
|
|
|
|
|
|
|
1959
|
247
|
100
|
|
|
|
509
|
unless (defined $event_name) { |
1960
|
245
|
|
|
|
|
382
|
$self->_explain_usage("undefined event name in alarm_set()"); |
1961
|
1
|
|
|
|
|
5
|
$! = EINVAL; |
1962
|
0
|
|
|
|
|
0
|
return; |
1963
|
|
|
|
|
|
|
} |
1964
|
|
|
|
|
|
|
|
1965
|
1
|
100
|
|
|
|
4
|
unless (defined $time) { |
1966
|
238
|
|
|
|
|
343
|
$self->_explain_usage("undefined time in alarm_set()"); |
1967
|
1
|
|
|
|
|
4
|
$! = EINVAL; |
1968
|
0
|
|
|
|
|
0
|
return; |
1969
|
|
|
|
|
|
|
} |
1970
|
|
|
|
|
|
|
|
1971
|
0
|
|
|
|
|
0
|
if (ASSERT_USAGE) { |
1972
|
|
|
|
|
|
|
_carp( |
1973
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
1974
|
|
|
|
|
|
|
"effect cannot be achieved by setting an alarm for it" |
1975
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
1976
|
|
|
|
|
|
|
} |
1977
|
|
|
|
|
|
|
|
1978
|
236
|
|
|
|
|
187
|
return $self->_data_ev_enqueue |
1979
|
|
|
|
|
|
|
( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], |
1980
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, $time, |
1981
|
|
|
|
|
|
|
); |
1982
|
|
|
|
|
|
|
} |
1983
|
|
|
|
|
|
|
|
1984
|
|
|
|
|
|
|
# Remove an alarm by its ID. TODO Now that alarms and events have |
1985
|
|
|
|
|
|
|
# been recombined, this will remove an event by its ID. However, |
1986
|
|
|
|
|
|
|
# nothing returns an event ID, so nobody knows what to remove. |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
sub alarm_remove { |
1989
|
466
|
|
|
230
|
1
|
5640
|
my ($self, $alarm_id) = ($poe_kernel, @_[1..$#_]); |
1990
|
|
|
|
|
|
|
|
1991
|
466
|
|
|
|
|
1217
|
if (ASSERT_USAGE) { |
1992
|
|
|
|
|
|
|
_confess " must call alarm_remove() from a running session" |
1993
|
|
|
|
|
|
|
if $kr_active_session == $self; |
1994
|
|
|
|
|
|
|
} |
1995
|
|
|
|
|
|
|
|
1996
|
230
|
100
|
|
|
|
766
|
unless (defined $alarm_id) { |
1997
|
221
|
|
|
|
|
364
|
$self->_explain_usage("undefined alarm id in alarm_remove()"); |
1998
|
1
|
|
|
|
|
3
|
$! = EINVAL; |
1999
|
0
|
|
|
|
|
0
|
return; |
2000
|
|
|
|
|
|
|
} |
2001
|
|
|
|
|
|
|
|
2002
|
8
|
|
|
|
|
23
|
my ($time, $event) = |
2003
|
|
|
|
|
|
|
$self->_data_ev_clear_alarm_by_id($kr_active_session->ID(), $alarm_id); |
2004
|
227
|
100
|
|
|
|
423
|
return unless defined $time; |
2005
|
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
|
# In a list context, return the alarm that was removed. In a scalar |
2007
|
|
|
|
|
|
|
# context, return a reference to the alarm that was removed. In a |
2008
|
|
|
|
|
|
|
# void context, return nothing. Either way this returns a defined |
2009
|
|
|
|
|
|
|
# value when someone needs something useful from it. |
2010
|
|
|
|
|
|
|
|
2011
|
227
|
100
|
|
|
|
459
|
return unless defined wantarray; |
2012
|
219
|
100
|
|
|
|
1129
|
return ( $event->[EV_NAME], $time, $event->[EV_ARGS] ) if wantarray; |
2013
|
4
|
|
|
|
|
20
|
return [ $event->[EV_NAME], $time, $event->[EV_ARGS] ]; |
2014
|
|
|
|
|
|
|
} |
2015
|
|
|
|
|
|
|
|
2016
|
|
|
|
|
|
|
# Move an alarm to a new time. This virtually removes the alarm and |
2017
|
|
|
|
|
|
|
# re-adds it somewhere else. In reality, adjust_priority() is |
2018
|
|
|
|
|
|
|
# optimized for this sort of thing. |
2019
|
|
|
|
|
|
|
|
2020
|
|
|
|
|
|
|
sub alarm_adjust { |
2021
|
37
|
|
|
35
|
1
|
7298
|
my ($self, $alarm_id, $delta) = ($poe_kernel, @_[1..$#_]); |
2022
|
|
|
|
|
|
|
|
2023
|
35
|
|
|
|
|
40
|
if (ASSERT_USAGE) { |
2024
|
|
|
|
|
|
|
_confess " must call alarm_adjust() from a running session" |
2025
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2026
|
|
|
|
|
|
|
} |
2027
|
|
|
|
|
|
|
|
2028
|
35
|
100
|
|
|
|
87
|
unless (defined $alarm_id) { |
2029
|
33
|
|
|
|
|
72
|
$self->_explain_usage("undefined alarm id in alarm_adjust()"); |
2030
|
1
|
|
|
|
|
3
|
$! = EINVAL; |
2031
|
0
|
|
|
|
|
0
|
return; |
2032
|
|
|
|
|
|
|
} |
2033
|
|
|
|
|
|
|
|
2034
|
1
|
100
|
|
|
|
4
|
unless (defined $delta) { |
2035
|
32
|
|
|
|
|
60
|
$self->_explain_usage("undefined alarm delta in alarm_adjust()"); |
2036
|
1
|
|
|
|
|
3
|
$! = EINVAL; |
2037
|
0
|
|
|
|
|
0
|
return; |
2038
|
|
|
|
|
|
|
} |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
my $my_alarm = sub { |
2041
|
30
|
|
|
3758
|
|
121
|
$_[0]->[EV_SESSION] == $kr_active_session; |
2042
|
0
|
|
|
|
|
0
|
}; |
2043
|
|
|
|
|
|
|
|
2044
|
3758
|
|
|
|
|
7609
|
return $self->_data_ev_adjust( $alarm_id, $my_alarm, undef, $delta ); |
2045
|
|
|
|
|
|
|
} |
2046
|
|
|
|
|
|
|
|
2047
|
|
|
|
|
|
|
# A convenient function for setting alarms relative to now. It also |
2048
|
|
|
|
|
|
|
# uses whichever time() POE::Kernel can find, which may be |
2049
|
|
|
|
|
|
|
# Time::HiRes'. |
2050
|
|
|
|
|
|
|
|
2051
|
|
|
|
|
|
|
sub delay_set { |
2052
|
|
|
|
|
|
|
# Always always always grab time() ASAP, so that the eventual |
2053
|
|
|
|
|
|
|
# time we set the delay for is as close as possible to the time |
2054
|
|
|
|
|
|
|
# at which they ASKED for the delay, not when we actually set it. |
2055
|
50
|
|
|
20
|
1
|
4894
|
my $t = walltime(); |
2056
|
20
|
|
|
|
|
61
|
my $pri = monotime(); |
2057
|
|
|
|
|
|
|
|
2058
|
|
|
|
|
|
|
# And now continue as normal |
2059
|
20
|
|
|
|
|
102
|
my ($self, $event_name, $seconds, @etc) = ($poe_kernel, @_[1..$#_]); |
2060
|
|
|
|
|
|
|
|
2061
|
20
|
|
|
|
|
39
|
if (ASSERT_USAGE) { |
2062
|
|
|
|
|
|
|
_confess " must call delay_set() from a running session" |
2063
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2064
|
|
|
|
|
|
|
} |
2065
|
|
|
|
|
|
|
|
2066
|
20
|
100
|
|
|
|
105
|
unless (defined $event_name) { |
2067
|
10
|
|
|
|
|
34
|
$self->_explain_usage("undefined event name in delay_set()"); |
2068
|
1
|
|
|
|
|
3
|
$! = EINVAL; |
2069
|
0
|
|
|
|
|
0
|
return; |
2070
|
|
|
|
|
|
|
} |
2071
|
|
|
|
|
|
|
|
2072
|
9
|
|
|
|
|
12
|
if (ASSERT_USAGE) { |
2073
|
|
|
|
|
|
|
_carp( |
2074
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
2075
|
|
|
|
|
|
|
"effect cannot be achieved by setting a delay for it" |
2076
|
|
|
|
|
|
|
) if exists $poes_own_events{$event_name}; |
2077
|
|
|
|
|
|
|
} |
2078
|
|
|
|
|
|
|
|
2079
|
17
|
100
|
|
|
|
37
|
unless (defined $seconds) { |
2080
|
9
|
|
|
|
|
33
|
$self->_explain_usage("undefined seconds in delay_set()"); |
2081
|
8
|
|
|
|
|
27
|
$! = EINVAL; |
2082
|
1
|
|
|
|
|
3
|
return; |
2083
|
|
|
|
|
|
|
} |
2084
|
|
|
|
|
|
|
|
2085
|
8
|
|
|
|
|
166
|
return $self->_data_ev_enqueue |
2086
|
|
|
|
|
|
|
( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ], |
2087
|
|
|
|
|
|
|
(caller)[1,2], $kr_active_event, $t, $seconds, $pri+$seconds |
2088
|
|
|
|
|
|
|
); |
2089
|
|
|
|
|
|
|
} |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
# Move a delay to a new offset from time(). As with alarm_adjust(), |
2092
|
|
|
|
|
|
|
# this is optimized internally for this sort of activity. |
2093
|
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
|
sub delay_adjust { |
2095
|
|
|
|
|
|
|
# Always always always grab time() ASAP, so that the eventual |
2096
|
|
|
|
|
|
|
# time we set the delay for is as close as possible to the time |
2097
|
|
|
|
|
|
|
# at which they ASKED for the delay, not when we actually set it. |
2098
|
5
|
|
|
5
|
1
|
1462
|
my $t = walltime(); |
2099
|
12
|
|
|
|
|
127
|
my $pri = monotime(); |
2100
|
|
|
|
|
|
|
|
2101
|
|
|
|
|
|
|
# And now continue as normal |
2102
|
5
|
|
|
|
|
16
|
my ($self, $alarm_id, $seconds) = ($poe_kernel, @_[1..$#_]); |
2103
|
|
|
|
|
|
|
|
2104
|
5
|
|
|
|
|
6
|
if (ASSERT_USAGE) { |
2105
|
|
|
|
|
|
|
_confess " must call delay_adjust() from a running session" |
2106
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2107
|
|
|
|
|
|
|
} |
2108
|
|
|
|
|
|
|
|
2109
|
5
|
100
|
|
|
|
17
|
unless (defined $alarm_id) { |
2110
|
3
|
|
|
|
|
16
|
$self->_explain_usage("undefined delay id in delay_adjust()"); |
2111
|
1
|
|
|
|
|
4
|
$! = EINVAL; |
2112
|
0
|
|
|
|
|
0
|
return; |
2113
|
|
|
|
|
|
|
} |
2114
|
|
|
|
|
|
|
|
2115
|
1
|
100
|
|
|
|
4
|
unless (defined $seconds) { |
2116
|
2
|
|
|
|
|
8
|
$self->_explain_usage("undefined delay seconds in delay_adjust()"); |
2117
|
1
|
|
|
|
|
2
|
$! = EINVAL; |
2118
|
0
|
|
|
|
|
0
|
return; |
2119
|
|
|
|
|
|
|
} |
2120
|
|
|
|
|
|
|
|
2121
|
|
|
|
|
|
|
my $my_delay = sub { |
2122
|
0
|
|
|
0
|
|
0
|
$_[0]->[EV_SESSION] == $kr_active_session; |
2123
|
0
|
|
|
|
|
0
|
}; |
2124
|
|
|
|
|
|
|
|
2125
|
0
|
|
|
|
|
0
|
if (TRACE_EVENTS) { |
2126
|
|
|
|
|
|
|
_warn(" adjusted event $alarm_id by $seconds seconds from $t"); |
2127
|
|
|
|
|
|
|
} |
2128
|
|
|
|
|
|
|
|
2129
|
0
|
|
|
|
|
0
|
return $self->_data_ev_set($alarm_id, $my_delay, $t, $pri, $seconds ); |
2130
|
|
|
|
|
|
|
} |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
# Remove all alarms for the current session. |
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
sub alarm_remove_all { |
2135
|
4
|
|
|
4
|
1
|
345
|
my $self = $poe_kernel; |
2136
|
|
|
|
|
|
|
|
2137
|
4
|
|
|
|
|
5
|
if (ASSERT_USAGE) { |
2138
|
|
|
|
|
|
|
_confess " must call alarm_remove_all() from a running session" |
2139
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2140
|
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
|
|
2142
|
|
|
|
|
|
|
# This should never happen, actually. |
2143
|
4
|
100
|
|
|
|
18
|
_trap "unknown session in alarm_remove_all call" unless ( |
2144
|
|
|
|
|
|
|
$self->_data_ses_exists($kr_active_session->ID) |
2145
|
|
|
|
|
|
|
); |
2146
|
|
|
|
|
|
|
|
2147
|
|
|
|
|
|
|
# Free every alarm owned by the session. This code is ripped off |
2148
|
|
|
|
|
|
|
# from the _stop code to flush everything. |
2149
|
|
|
|
|
|
|
|
2150
|
2
|
|
|
|
|
6
|
my @removed = $self->_data_ev_clear_alarm_by_session( |
2151
|
|
|
|
|
|
|
$kr_active_session->ID() |
2152
|
|
|
|
|
|
|
); |
2153
|
|
|
|
|
|
|
|
2154
|
2
|
50
|
|
|
|
6
|
return unless defined wantarray; |
2155
|
2
|
50
|
|
|
|
11
|
return @removed if wantarray; |
2156
|
0
|
|
|
|
|
0
|
return \@removed; |
2157
|
|
|
|
|
|
|
} |
2158
|
|
|
|
|
|
|
|
2159
|
|
|
|
|
|
|
#============================================================================== |
2160
|
|
|
|
|
|
|
# SELECTS |
2161
|
|
|
|
|
|
|
#============================================================================== |
2162
|
|
|
|
|
|
|
|
2163
|
|
|
|
|
|
|
sub _internal_select { |
2164
|
2808
|
|
|
2808
|
|
4277
|
my ($self, $session, $handle, $event_name, $mode, $args) = @_; |
2165
|
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
|
# If an event is included, then we're defining a filehandle watcher. |
2167
|
|
|
|
|
|
|
|
2168
|
2808
|
100
|
|
|
|
4710
|
if ($event_name) { |
2169
|
1191
|
|
|
|
|
13271
|
$self->_data_handle_add($handle, $mode, $session, $event_name, $args); |
2170
|
|
|
|
|
|
|
} |
2171
|
|
|
|
|
|
|
else { |
2172
|
1617
|
|
|
|
|
3951
|
$self->_data_handle_remove($handle, $mode, $session->ID); |
2173
|
|
|
|
|
|
|
} |
2174
|
|
|
|
|
|
|
} |
2175
|
|
|
|
|
|
|
|
2176
|
|
|
|
|
|
|
# A higher-level select() that manipulates read, write and expedite |
2177
|
|
|
|
|
|
|
# selects together. |
2178
|
|
|
|
|
|
|
|
2179
|
|
|
|
|
|
|
sub select { |
2180
|
112
|
|
|
112
|
1
|
1258
|
my ($self, $handle, $event_r, $event_w, $event_e, @args) = ( |
2181
|
|
|
|
|
|
|
$poe_kernel, @_[1..$#_] |
2182
|
|
|
|
|
|
|
); |
2183
|
|
|
|
|
|
|
|
2184
|
112
|
|
|
|
|
135
|
if (ASSERT_USAGE) { |
2185
|
|
|
|
|
|
|
_confess " must call select() from a running session" |
2186
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2187
|
|
|
|
|
|
|
_confess " undefined filehandle in select()" unless defined $handle; |
2188
|
|
|
|
|
|
|
_confess " invalid filehandle in select()" |
2189
|
|
|
|
|
|
|
unless defined fileno($handle); |
2190
|
|
|
|
|
|
|
foreach ($event_r, $event_w, $event_e) { |
2191
|
|
|
|
|
|
|
next unless defined $_; |
2192
|
|
|
|
|
|
|
_carp( |
2193
|
|
|
|
|
|
|
" The '$_' event is one of POE's own. Its " . |
2194
|
|
|
|
|
|
|
"effect cannot be achieved by setting a file watcher to it" |
2195
|
|
|
|
|
|
|
) if exists($poes_own_events{$_}); |
2196
|
|
|
|
|
|
|
} |
2197
|
|
|
|
|
|
|
} |
2198
|
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
|
$self->_internal_select( |
2200
|
112
|
|
|
|
|
288
|
$kr_active_session, $handle, $event_r, MODE_RD, \@args |
2201
|
|
|
|
|
|
|
); |
2202
|
111
|
|
|
|
|
297
|
$self->_internal_select( |
2203
|
|
|
|
|
|
|
$kr_active_session, $handle, $event_w, MODE_WR, \@args |
2204
|
|
|
|
|
|
|
); |
2205
|
110
|
|
|
|
|
309
|
$self->_internal_select( |
2206
|
|
|
|
|
|
|
$kr_active_session, $handle, $event_e, MODE_EX, \@args |
2207
|
|
|
|
|
|
|
); |
2208
|
109
|
|
|
|
|
204
|
return 0; |
2209
|
|
|
|
|
|
|
} |
2210
|
|
|
|
|
|
|
|
2211
|
|
|
|
|
|
|
# Only manipulate the read select. |
2212
|
|
|
|
|
|
|
sub select_read { |
2213
|
1848
|
|
|
1566
|
1
|
12941
|
my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); |
2214
|
|
|
|
|
|
|
|
2215
|
1568
|
|
|
|
|
3065
|
if (ASSERT_USAGE) { |
2216
|
|
|
|
|
|
|
_confess " must call select_read() from a running session" |
2217
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2218
|
|
|
|
|
|
|
_confess " undefined filehandle in select_read()" |
2219
|
|
|
|
|
|
|
unless defined $handle; |
2220
|
|
|
|
|
|
|
_confess " invalid filehandle in select_read()" |
2221
|
|
|
|
|
|
|
unless defined fileno($handle); |
2222
|
|
|
|
|
|
|
_carp( |
2223
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
2224
|
|
|
|
|
|
|
"effect cannot be achieved by setting a file watcher to it" |
2225
|
|
|
|
|
|
|
) if defined($event_name) and exists($poes_own_events{$event_name}); |
2226
|
|
|
|
|
|
|
}; |
2227
|
|
|
|
|
|
|
|
2228
|
1660
|
|
|
|
|
4434
|
$self->_internal_select( |
2229
|
|
|
|
|
|
|
$kr_active_session, $handle, $event_name, MODE_RD, \@args |
2230
|
|
|
|
|
|
|
); |
2231
|
1659
|
|
|
|
|
5857
|
return 0; |
2232
|
|
|
|
|
|
|
} |
2233
|
|
|
|
|
|
|
|
2234
|
|
|
|
|
|
|
# Only manipulate the write select. |
2235
|
|
|
|
|
|
|
sub select_write { |
2236
|
1924
|
|
|
925
|
1
|
7403
|
my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); |
2237
|
|
|
|
|
|
|
|
2238
|
1919
|
|
|
|
|
5330
|
if (ASSERT_USAGE) { |
2239
|
|
|
|
|
|
|
_confess " must call select_write() from a running session" |
2240
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2241
|
|
|
|
|
|
|
_confess " undefined filehandle in select_write()" |
2242
|
|
|
|
|
|
|
unless defined $handle; |
2243
|
|
|
|
|
|
|
_confess " invalid filehandle in select_write()" |
2244
|
|
|
|
|
|
|
unless defined fileno($handle); |
2245
|
|
|
|
|
|
|
_carp( |
2246
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
2247
|
|
|
|
|
|
|
"effect cannot be achieved by setting a file watcher to it" |
2248
|
|
|
|
|
|
|
) if defined($event_name) and exists($poes_own_events{$event_name}); |
2249
|
|
|
|
|
|
|
}; |
2250
|
|
|
|
|
|
|
|
2251
|
1825
|
|
|
|
|
5483
|
$self->_internal_select( |
2252
|
|
|
|
|
|
|
$kr_active_session, $handle, $event_name, MODE_WR, \@args |
2253
|
|
|
|
|
|
|
); |
2254
|
1824
|
|
|
|
|
7282
|
return 0; |
2255
|
|
|
|
|
|
|
} |
2256
|
|
|
|
|
|
|
|
2257
|
|
|
|
|
|
|
# Only manipulate the expedite select. |
2258
|
|
|
|
|
|
|
sub select_expedite { |
2259
|
697
|
|
|
3
|
1
|
3350
|
my ($self, $handle, $event_name, @args) = ($poe_kernel, @_[1..$#_]); |
2260
|
|
|
|
|
|
|
|
2261
|
696
|
|
|
|
|
11021
|
if (ASSERT_USAGE) { |
2262
|
|
|
|
|
|
|
_confess " must call select_expedite() from a running session" |
2263
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2264
|
|
|
|
|
|
|
_confess " undefined filehandle in select_expedite()" |
2265
|
|
|
|
|
|
|
unless defined $handle; |
2266
|
|
|
|
|
|
|
_confess " invalid filehandle in select_expedite()" |
2267
|
|
|
|
|
|
|
unless defined fileno($handle); |
2268
|
|
|
|
|
|
|
_carp( |
2269
|
|
|
|
|
|
|
" The '$event_name' event is one of POE's own. Its " . |
2270
|
|
|
|
|
|
|
"effect cannot be achieved by setting a file watcher to it" |
2271
|
|
|
|
|
|
|
) if defined($event_name) and exists($poes_own_events{$event_name}); |
2272
|
|
|
|
|
|
|
}; |
2273
|
|
|
|
|
|
|
|
2274
|
696
|
|
|
|
|
2983
|
$self->_internal_select( |
2275
|
|
|
|
|
|
|
$kr_active_session, $handle, $event_name, MODE_EX, \@args |
2276
|
|
|
|
|
|
|
); |
2277
|
695
|
|
|
|
|
2472
|
return 0; |
2278
|
|
|
|
|
|
|
} |
2279
|
|
|
|
|
|
|
|
2280
|
|
|
|
|
|
|
# Turn off a handle's write mode bit without doing |
2281
|
|
|
|
|
|
|
# garbage-collection things. |
2282
|
|
|
|
|
|
|
sub select_pause_write { |
2283
|
864
|
|
|
863
|
1
|
3976
|
my ($self, $handle) = ($poe_kernel, @_[1..$#_]); |
2284
|
|
|
|
|
|
|
|
2285
|
863
|
|
|
|
|
14280
|
if (ASSERT_USAGE) { |
2286
|
|
|
|
|
|
|
_confess " must call select_pause_write() from a running session" |
2287
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2288
|
|
|
|
|
|
|
_confess " undefined filehandle in select_pause_write()" |
2289
|
|
|
|
|
|
|
unless defined $handle; |
2290
|
|
|
|
|
|
|
_confess " invalid filehandle in select_pause_write()" |
2291
|
|
|
|
|
|
|
unless defined fileno($handle); |
2292
|
|
|
|
|
|
|
}; |
2293
|
|
|
|
|
|
|
|
2294
|
863
|
100
|
|
|
|
2250
|
return 0 unless $self->_data_handle_is_good($handle, MODE_WR); |
2295
|
|
|
|
|
|
|
|
2296
|
862
|
|
|
|
|
2836
|
$self->_data_handle_pause($handle, MODE_WR); |
2297
|
|
|
|
|
|
|
|
2298
|
861
|
|
|
|
|
2464
|
return 1; |
2299
|
|
|
|
|
|
|
} |
2300
|
|
|
|
|
|
|
|
2301
|
|
|
|
|
|
|
# Turn on a handle's write mode bit without doing garbage-collection |
2302
|
|
|
|
|
|
|
# things. |
2303
|
|
|
|
|
|
|
sub select_resume_write { |
2304
|
1194
|
|
|
532
|
1
|
6510
|
my ($self, $handle) = ($poe_kernel, @_[1..$#_]); |
2305
|
|
|
|
|
|
|
|
2306
|
1194
|
|
|
|
|
3285
|
if (ASSERT_USAGE) { |
2307
|
|
|
|
|
|
|
_confess " must call select_resume_write() from a running session" |
2308
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2309
|
|
|
|
|
|
|
_confess " undefined filehandle in select_resume_write()" |
2310
|
|
|
|
|
|
|
unless defined $handle; |
2311
|
|
|
|
|
|
|
_confess " invalid filehandle in select_resume_write()" |
2312
|
|
|
|
|
|
|
unless defined fileno($handle); |
2313
|
|
|
|
|
|
|
}; |
2314
|
|
|
|
|
|
|
|
2315
|
1194
|
100
|
|
|
|
3560
|
return 0 unless $self->_data_handle_is_good($handle, MODE_WR); |
2316
|
|
|
|
|
|
|
|
2317
|
531
|
|
|
|
|
1122
|
$self->_data_handle_resume($handle, MODE_WR); |
2318
|
|
|
|
|
|
|
|
2319
|
530
|
|
|
|
|
1280
|
return 1; |
2320
|
|
|
|
|
|
|
} |
2321
|
|
|
|
|
|
|
|
2322
|
|
|
|
|
|
|
# Turn off a handle's read mode bit without doing garbage-collection |
2323
|
|
|
|
|
|
|
# things. |
2324
|
|
|
|
|
|
|
sub select_pause_read { |
2325
|
510
|
|
|
73
|
1
|
2552
|
my ($self, $handle) = ($poe_kernel, @_[1..$#_]); |
2326
|
|
|
|
|
|
|
|
2327
|
510
|
|
|
|
|
1512
|
if (ASSERT_USAGE) { |
2328
|
|
|
|
|
|
|
_confess " must call select_pause_read() from a running session" |
2329
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2330
|
|
|
|
|
|
|
_confess " undefined filehandle in select_pause_read()" |
2331
|
|
|
|
|
|
|
unless defined $handle; |
2332
|
|
|
|
|
|
|
_confess " invalid filehandle in select_pause_read()" |
2333
|
|
|
|
|
|
|
unless defined fileno($handle); |
2334
|
|
|
|
|
|
|
}; |
2335
|
|
|
|
|
|
|
|
2336
|
510
|
100
|
|
|
|
1092
|
return 0 unless $self->_data_handle_is_good($handle, MODE_RD); |
2337
|
|
|
|
|
|
|
|
2338
|
72
|
|
|
|
|
141
|
$self->_data_handle_pause($handle, MODE_RD); |
2339
|
|
|
|
|
|
|
|
2340
|
71
|
|
|
|
|
178
|
return 1; |
2341
|
|
|
|
|
|
|
} |
2342
|
|
|
|
|
|
|
|
2343
|
|
|
|
|
|
|
# Turn on a handle's read mode bit without doing garbage-collection |
2344
|
|
|
|
|
|
|
# things. |
2345
|
|
|
|
|
|
|
sub select_resume_read { |
2346
|
141
|
|
|
71
|
1
|
1694
|
my ($self, $handle) = ($poe_kernel, @_[1..$#_]); |
2347
|
|
|
|
|
|
|
|
2348
|
141
|
|
|
|
|
254
|
if (ASSERT_USAGE) { |
2349
|
|
|
|
|
|
|
_confess " must call select_resume_read() from a running session" |
2350
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2351
|
|
|
|
|
|
|
_confess " undefined filehandle in select_resume_read()" |
2352
|
|
|
|
|
|
|
unless defined $handle; |
2353
|
|
|
|
|
|
|
_confess " invalid filehandle in select_resume_read()" |
2354
|
|
|
|
|
|
|
unless defined fileno($handle); |
2355
|
|
|
|
|
|
|
}; |
2356
|
|
|
|
|
|
|
|
2357
|
141
|
100
|
|
|
|
316
|
return 0 unless $self->_data_handle_is_good($handle, MODE_RD); |
2358
|
|
|
|
|
|
|
|
2359
|
70
|
|
|
|
|
145
|
$self->_data_handle_resume($handle, MODE_RD); |
2360
|
|
|
|
|
|
|
|
2361
|
69
|
|
|
|
|
208
|
return 1; |
2362
|
|
|
|
|
|
|
} |
2363
|
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
|
#============================================================================== |
2365
|
|
|
|
|
|
|
# Aliases: These functions expose the internal alias accessors with |
2366
|
|
|
|
|
|
|
# extra fun parameter/return value checking. |
2367
|
|
|
|
|
|
|
#============================================================================== |
2368
|
|
|
|
|
|
|
|
2369
|
|
|
|
|
|
|
### Set an alias in the current session. |
2370
|
|
|
|
|
|
|
|
2371
|
|
|
|
|
|
|
sub alias_set { |
2372
|
262
|
|
|
194
|
1
|
3886
|
my ($self, $name) = ($poe_kernel, @_[1..$#_]); |
2373
|
|
|
|
|
|
|
|
2374
|
262
|
|
|
|
|
427
|
if (ASSERT_USAGE) { |
2375
|
|
|
|
|
|
|
_confess " undefined alias in alias_set()" unless defined $name; |
2376
|
|
|
|
|
|
|
}; |
2377
|
|
|
|
|
|
|
|
2378
|
|
|
|
|
|
|
# Don't overwrite another session's alias. |
2379
|
262
|
|
|
|
|
763
|
my $existing_session = $self->_data_alias_resolve($name); |
2380
|
193
|
100
|
|
|
|
662
|
if (defined $existing_session) { |
2381
|
182
|
100
|
|
|
|
378
|
if ($existing_session != $kr_active_session) { |
2382
|
42
|
|
|
|
|
94
|
$self->_explain_usage("alias '$name' is in use by another session"); |
2383
|
1
|
|
|
|
|
6
|
return EEXIST; |
2384
|
|
|
|
|
|
|
} |
2385
|
4
|
|
|
|
|
7
|
return 0; |
2386
|
|
|
|
|
|
|
} |
2387
|
|
|
|
|
|
|
|
2388
|
51
|
|
|
|
|
107
|
$self->_data_alias_add($kr_active_session, $name); |
2389
|
147
|
|
|
|
|
450
|
return 0; |
2390
|
|
|
|
|
|
|
} |
2391
|
|
|
|
|
|
|
|
2392
|
|
|
|
|
|
|
### Remove an alias from the current session. |
2393
|
|
|
|
|
|
|
|
2394
|
|
|
|
|
|
|
sub alias_remove { |
2395
|
202
|
|
|
66
|
1
|
1708
|
my ($self, $name) = ($poe_kernel, @_[1..$#_]); |
2396
|
|
|
|
|
|
|
|
2397
|
66
|
|
|
|
|
64
|
if (ASSERT_USAGE) { |
2398
|
|
|
|
|
|
|
_confess " undefined alias in alias_remove()" unless defined $name; |
2399
|
|
|
|
|
|
|
}; |
2400
|
|
|
|
|
|
|
|
2401
|
66
|
|
|
|
|
163
|
my $existing_session = $self->_data_alias_resolve($name); |
2402
|
|
|
|
|
|
|
|
2403
|
65
|
100
|
|
|
|
192
|
unless (defined $existing_session) { |
2404
|
56
|
|
|
|
|
149
|
$self->_explain_usage("alias '$name' does not exist"); |
2405
|
2
|
|
|
|
|
8
|
return ESRCH; |
2406
|
|
|
|
|
|
|
} |
2407
|
|
|
|
|
|
|
|
2408
|
9
|
100
|
|
|
|
27
|
if ($existing_session != $kr_active_session) { |
2409
|
54
|
|
|
|
|
136
|
$self->_explain_usage("alias '$name' does not belong to current session"); |
2410
|
1
|
|
|
|
|
4
|
return EPERM; |
2411
|
|
|
|
|
|
|
} |
2412
|
|
|
|
|
|
|
|
2413
|
8
|
|
|
|
|
24
|
$self->_data_alias_remove($kr_active_session, $name); |
2414
|
60
|
|
|
|
|
174
|
return 0; |
2415
|
|
|
|
|
|
|
} |
2416
|
|
|
|
|
|
|
|
2417
|
|
|
|
|
|
|
### Resolve an alias into a session. |
2418
|
|
|
|
|
|
|
|
2419
|
|
|
|
|
|
|
sub alias_resolve { |
2420
|
63
|
|
|
11
|
1
|
2179
|
my ($self, $name) = ($poe_kernel, @_[1..$#_]); |
2421
|
|
|
|
|
|
|
|
2422
|
11
|
|
|
|
|
14
|
if (ASSERT_USAGE) { |
2423
|
|
|
|
|
|
|
_confess " undefined alias in alias_resolve()" unless defined $name; |
2424
|
|
|
|
|
|
|
}; |
2425
|
|
|
|
|
|
|
|
2426
|
11
|
|
|
|
|
28
|
return $self->_resolve_session($name); |
2427
|
|
|
|
|
|
|
} |
2428
|
|
|
|
|
|
|
|
2429
|
|
|
|
|
|
|
### List the aliases for a given session. |
2430
|
|
|
|
|
|
|
|
2431
|
|
|
|
|
|
|
sub alias_list { |
2432
|
18
|
|
|
8
|
1
|
512
|
my ($self, $search_session) = ($poe_kernel, @_[1..$#_]); |
2433
|
8
|
|
66
|
|
|
42
|
my $session = |
2434
|
|
|
|
|
|
|
$self->_resolve_session($search_session || $kr_active_session); |
2435
|
|
|
|
|
|
|
|
2436
|
8
|
100
|
|
|
|
20
|
unless (defined $session) { |
2437
|
0
|
|
|
|
|
0
|
$self->_explain_resolve_failure($search_session, "nonfatal"); |
2438
|
0
|
|
|
|
|
0
|
return; |
2439
|
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
|
|
2441
|
|
|
|
|
|
|
# Return whatever can be found. |
2442
|
8
|
|
|
|
|
22
|
my @alias_list = $self->_data_alias_list($session->ID); |
2443
|
8
|
100
|
|
|
|
40
|
return wantarray() ? @alias_list : $alias_list[0]; |
2444
|
|
|
|
|
|
|
} |
2445
|
|
|
|
|
|
|
|
2446
|
|
|
|
|
|
|
#============================================================================== |
2447
|
|
|
|
|
|
|
# Kernel and Session IDs |
2448
|
|
|
|
|
|
|
#============================================================================== |
2449
|
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
|
# Return the Kernel's "unique" ID. There's only so much uniqueness |
2451
|
|
|
|
|
|
|
# available; machines on separate private 10/8 networks may have |
2452
|
|
|
|
|
|
|
# identical kernel IDs. The chances of a collision are vanishingly |
2453
|
|
|
|
|
|
|
# small. |
2454
|
|
|
|
|
|
|
|
2455
|
|
|
|
|
|
|
# The Kernel and Session IDs are based on Philip Gwyn's code. I hope |
2456
|
|
|
|
|
|
|
# he still can recognize it. |
2457
|
|
|
|
|
|
|
|
2458
|
|
|
|
|
|
|
sub _recalc_id { |
2459
|
180
|
|
|
180
|
|
482
|
my $self = shift; |
2460
|
|
|
|
|
|
|
|
2461
|
180
|
|
|
|
|
1016
|
my $old_id = $self->[KR_ID]; |
2462
|
|
|
|
|
|
|
|
2463
|
180
|
|
|
|
|
328
|
my $hostname = eval { (uname)[1] }; |
|
180
|
|
|
|
|
2561
|
|
2464
|
180
|
50
|
|
|
|
902
|
$hostname = hostname() unless defined $hostname; |
2465
|
|
|
|
|
|
|
|
2466
|
540
|
|
|
|
|
2246
|
my $new_id = $self->[KR_ID] = join( |
2467
|
|
|
|
|
|
|
"-", $hostname, |
2468
|
540
|
|
|
|
|
2101
|
map { unpack "H*", $_ } |
2469
|
180
|
|
|
|
|
1044
|
map { pack "N", $_ } |
2470
|
|
|
|
|
|
|
(monotime(), $$, ++$kr_id_seq) |
2471
|
|
|
|
|
|
|
); |
2472
|
|
|
|
|
|
|
|
2473
|
180
|
100
|
|
|
|
823
|
if (defined $old_id) { |
2474
|
4
|
|
|
|
|
115
|
$self->_data_sig_relocate_kernel_id($old_id, $new_id); |
2475
|
4
|
|
|
|
|
87
|
$self->_data_ses_relocate_kernel_id($old_id, $new_id); |
2476
|
4
|
|
|
|
|
83
|
$self->_data_sid_relocate_kernel_id($old_id, $new_id); |
2477
|
4
|
|
|
|
|
110
|
$self->_data_handle_relocate_kernel_id($old_id, $new_id); |
2478
|
4
|
|
|
|
|
67
|
$self->_data_ev_relocate_kernel_id($old_id, $new_id); |
2479
|
4
|
|
|
|
|
48
|
$self->_data_alias_relocate_kernel_id($old_id, $new_id); |
2480
|
|
|
|
|
|
|
} |
2481
|
|
|
|
|
|
|
} |
2482
|
|
|
|
|
|
|
|
2483
|
15228
|
|
|
15228
|
1
|
90185
|
sub ID { $poe_kernel->[KR_ID] } |
2484
|
|
|
|
|
|
|
|
2485
|
|
|
|
|
|
|
# Resolve an ID to a session reference. This function is virtually |
2486
|
|
|
|
|
|
|
# moot now that _resolve_session does it too. This explicit call will |
2487
|
|
|
|
|
|
|
# be faster, though, so it's kept for things that can benefit from it. |
2488
|
|
|
|
|
|
|
|
2489
|
|
|
|
|
|
|
sub ID_id_to_session { |
2490
|
6
|
|
|
6
|
1
|
255
|
my ($self, $id) = ($poe_kernel, @_[1..$#_]); |
2491
|
|
|
|
|
|
|
|
2492
|
6
|
|
|
|
|
6
|
if (ASSERT_USAGE) { |
2493
|
|
|
|
|
|
|
_confess " undefined ID in ID_id_to_session()" unless defined $id; |
2494
|
|
|
|
|
|
|
}; |
2495
|
|
|
|
|
|
|
|
2496
|
6
|
|
|
|
|
23
|
my $session = $self->_data_sid_resolve($id); |
2497
|
5
|
100
|
|
|
|
16
|
return $session if defined $session; |
2498
|
|
|
|
|
|
|
|
2499
|
5
|
|
|
|
|
29
|
$self->_explain_return("ID does not exist"); |
2500
|
0
|
|
|
|
|
0
|
$! = ESRCH; |
2501
|
0
|
|
|
|
|
0
|
return; |
2502
|
|
|
|
|
|
|
} |
2503
|
|
|
|
|
|
|
|
2504
|
|
|
|
|
|
|
# Resolve a session reference to its corresponding ID. |
2505
|
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
|
sub ID_session_to_id { |
2507
|
33
|
|
|
33
|
1
|
742
|
my ($self, $session) = ($poe_kernel, @_[1..$#_]); |
2508
|
|
|
|
|
|
|
|
2509
|
33
|
|
|
|
|
44
|
if (ASSERT_USAGE) { |
2510
|
|
|
|
|
|
|
_confess " undefined session in ID_session_to_id()" |
2511
|
|
|
|
|
|
|
unless defined $session; |
2512
|
|
|
|
|
|
|
}; |
2513
|
|
|
|
|
|
|
|
2514
|
33
|
|
|
|
|
115
|
my $id = $self->_data_ses_resolve_to_id($session); |
2515
|
32
|
100
|
|
|
|
105
|
if (defined $id) { |
2516
|
31
|
|
|
|
|
72
|
$! = 0; |
2517
|
31
|
|
|
|
|
52
|
return $id; |
2518
|
|
|
|
|
|
|
} |
2519
|
|
|
|
|
|
|
|
2520
|
32
|
|
|
|
|
110
|
$self->_explain_return("session ($session) does not exist"); |
2521
|
0
|
|
|
|
|
0
|
$! = ESRCH; |
2522
|
0
|
|
|
|
|
0
|
return; |
2523
|
|
|
|
|
|
|
} |
2524
|
|
|
|
|
|
|
|
2525
|
|
|
|
|
|
|
#============================================================================== |
2526
|
|
|
|
|
|
|
# Extra reference counts, to keep sessions alive when things occur. |
2527
|
|
|
|
|
|
|
# They take session IDs because they may be called from resources at |
2528
|
|
|
|
|
|
|
# times where the session reference is otherwise unknown. |
2529
|
|
|
|
|
|
|
#============================================================================== |
2530
|
|
|
|
|
|
|
|
2531
|
|
|
|
|
|
|
sub refcount_increment { |
2532
|
105
|
|
|
105
|
1
|
1294
|
my ($self, $session_id, $tag) = ($poe_kernel, @_[1..$#_]); |
2533
|
|
|
|
|
|
|
|
2534
|
105
|
|
|
|
|
161
|
if (ASSERT_USAGE) { |
2535
|
|
|
|
|
|
|
_confess " undefined session ID in refcount_increment()" |
2536
|
|
|
|
|
|
|
unless defined $session_id; |
2537
|
|
|
|
|
|
|
_confess " undefined reference count tag in refcount_increment()" |
2538
|
|
|
|
|
|
|
unless defined $tag; |
2539
|
|
|
|
|
|
|
}; |
2540
|
|
|
|
|
|
|
|
2541
|
105
|
100
|
|
|
|
275
|
unless ($self->_data_ses_exists($session_id)) { |
2542
|
103
|
|
|
|
|
274
|
$self->_explain_return("session id $session_id does not exist"); |
2543
|
101
|
|
|
|
|
554
|
$! = ESRCH; |
2544
|
0
|
|
|
|
|
0
|
return; |
2545
|
|
|
|
|
|
|
} |
2546
|
|
|
|
|
|
|
|
2547
|
1
|
|
|
|
|
13
|
my $refcount = $self->_data_extref_inc($session_id, $tag); |
2548
|
|
|
|
|
|
|
# TODO trace it here |
2549
|
1
|
|
|
|
|
3
|
return $refcount; |
2550
|
|
|
|
|
|
|
} |
2551
|
|
|
|
|
|
|
|
2552
|
|
|
|
|
|
|
sub refcount_decrement { |
2553
|
205
|
|
|
104
|
1
|
2864
|
my ($self, $session_id, $tag) = ($poe_kernel, @_[1..$#_]); |
2554
|
|
|
|
|
|
|
|
2555
|
205
|
|
|
|
|
1164
|
if (ASSERT_USAGE) { |
2556
|
|
|
|
|
|
|
_confess " undefined session ID in refcount_decrement()" |
2557
|
|
|
|
|
|
|
unless defined $session_id; |
2558
|
|
|
|
|
|
|
_confess " undefined reference count tag in refcount_decrement()" |
2559
|
|
|
|
|
|
|
unless defined $tag; |
2560
|
|
|
|
|
|
|
}; |
2561
|
|
|
|
|
|
|
|
2562
|
104
|
100
|
|
|
|
285
|
unless ($self->_data_ses_exists($session_id)) { |
2563
|
102
|
|
|
|
|
6066
|
$self->_explain_return("session id $session_id does not exist"); |
2564
|
100
|
|
|
|
|
334
|
$! = ESRCH; |
2565
|
0
|
|
|
|
|
0
|
return; |
2566
|
|
|
|
|
|
|
} |
2567
|
|
|
|
|
|
|
|
2568
|
1
|
|
|
|
|
6
|
my $refcount = $self->_data_extref_dec($session_id, $tag); |
2569
|
|
|
|
|
|
|
|
2570
|
|
|
|
|
|
|
# TODO trace it here |
2571
|
1
|
|
|
|
|
3
|
return $refcount; |
2572
|
|
|
|
|
|
|
} |
2573
|
|
|
|
|
|
|
|
2574
|
|
|
|
|
|
|
#============================================================================== |
2575
|
|
|
|
|
|
|
# HANDLERS |
2576
|
|
|
|
|
|
|
#============================================================================== |
2577
|
|
|
|
|
|
|
|
2578
|
|
|
|
|
|
|
# Add or remove event handlers from sessions. |
2579
|
|
|
|
|
|
|
sub state { |
2580
|
2201
|
|
|
2101
|
1
|
8097
|
my ($self, $event, $state_code, $state_alias) = ($poe_kernel, @_[1..$#_]); |
2581
|
2201
|
100
|
|
|
|
7466
|
$state_alias = $event unless defined $state_alias; |
2582
|
|
|
|
|
|
|
|
2583
|
2101
|
|
|
|
|
2377
|
if (ASSERT_USAGE) { |
2584
|
|
|
|
|
|
|
_confess " must call state() from a running session" |
2585
|
|
|
|
|
|
|
if $kr_active_session == $self; |
2586
|
|
|
|
|
|
|
_confess " undefined event name in state()" unless defined $event; |
2587
|
|
|
|
|
|
|
_confess " can't call state() outside a session" if ( |
2588
|
|
|
|
|
|
|
$kr_active_session == $self |
2589
|
|
|
|
|
|
|
); |
2590
|
|
|
|
|
|
|
}; |
2591
|
|
|
|
|
|
|
|
2592
|
2101
|
100
|
66
|
|
|
8279
|
if ( |
2593
|
|
|
|
|
|
|
(ref($kr_active_session) ne '') && |
2594
|
|
|
|
|
|
|
(ref($kr_active_session) ne 'POE::Kernel') |
2595
|
|
|
|
|
|
|
) { |
2596
|
2093
|
|
|
|
|
5932
|
$kr_active_session->_register_state($event, $state_code, $state_alias); |
2597
|
2092
|
|
|
|
|
4804
|
return 0; |
2598
|
|
|
|
|
|
|
} |
2599
|
|
|
|
|
|
|
|
2600
|
|
|
|
|
|
|
# TODO A terminal signal (such as UIDESTROY) kills a session. The |
2601
|
|
|
|
|
|
|
# Kernel deallocates the session, which cascades destruction to its |
2602
|
|
|
|
|
|
|
# HEAP. That triggers a Wheel's destruction, which calls |
2603
|
|
|
|
|
|
|
# $kernel->state() to remove a state from the session. The session, |
2604
|
|
|
|
|
|
|
# though, is already gone. If TRACE_RETVALS and/or ASSERT_RETVALS |
2605
|
|
|
|
|
|
|
# is set, this causes a warning or fatal error. |
2606
|
|
|
|
|
|
|
|
2607
|
1310
|
|
|
|
|
8059
|
$self->_explain_return("session ($kr_active_session) does not exist"); |
2608
|
1309
|
|
|
|
|
6285
|
return ESRCH; |
2609
|
|
|
|
|
|
|
} |
2610
|
|
|
|
|
|
|
|
2611
|
|
|
|
|
|
|
1; |
2612
|
|
|
|
|
|
|
|
2613
|
|
|
|
|
|
|
__END__ |