line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Session; |
2
|
|
|
|
|
|
|
|
3
|
170
|
|
|
170
|
|
1861
|
use strict; |
|
170
|
|
|
|
|
225
|
|
|
170
|
|
|
|
|
6206
|
|
4
|
|
|
|
|
|
|
|
5
|
170
|
|
|
170
|
|
646
|
use vars qw($VERSION); |
|
170
|
|
|
|
|
243
|
|
|
170
|
|
|
|
|
7368
|
|
6
|
|
|
|
|
|
|
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places) |
7
|
|
|
|
|
|
|
|
8
|
170
|
|
|
170
|
|
833
|
use Carp qw(carp croak); |
|
170
|
|
|
|
|
206
|
|
|
170
|
|
|
|
|
8576
|
|
9
|
170
|
|
|
170
|
|
770
|
use Errno; |
|
170
|
|
|
|
|
199
|
|
|
170
|
|
|
|
|
34729
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
sub SE_NAMESPACE () { 0 } |
12
|
|
|
|
|
|
|
sub SE_OPTIONS () { 1 } |
13
|
|
|
|
|
|
|
sub SE_STATES () { 2 } |
14
|
|
|
|
|
|
|
sub SE_ID () { 3 } |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub CREATE_ARGS () { 'args' } |
17
|
|
|
|
|
|
|
sub CREATE_OPTIONS () { 'options' } |
18
|
|
|
|
|
|
|
sub CREATE_INLINES () { 'inline_states' } |
19
|
|
|
|
|
|
|
sub CREATE_PACKAGES () { 'package_states' } |
20
|
|
|
|
|
|
|
sub CREATE_OBJECTS () { 'object_states' } |
21
|
|
|
|
|
|
|
sub CREATE_HEAP () { 'heap' } |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub OPT_TRACE () { 'trace' } |
24
|
|
|
|
|
|
|
sub OPT_DEBUG () { 'debug' } |
25
|
|
|
|
|
|
|
sub OPT_DEFAULT () { 'default' } |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub EN_START () { '_start' } |
28
|
|
|
|
|
|
|
sub EN_DEFAULT () { '_default' } |
29
|
|
|
|
|
|
|
sub EN_SIGNAL () { '_signal' } |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
32
|
|
|
|
|
|
|
# Debugging flags for subsystems. They're done as double evals here |
33
|
|
|
|
|
|
|
# so that someone may define them before using POE::Session (or POE), |
34
|
|
|
|
|
|
|
# and the pre-defined value will take precedence over the defaults |
35
|
|
|
|
|
|
|
# here. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Shorthand for defining an assert constant. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub _define_assert { |
40
|
170
|
|
|
170
|
|
789
|
no strict 'refs'; |
|
170
|
|
|
|
|
236
|
|
|
170
|
|
|
|
|
22607
|
|
41
|
170
|
|
|
170
|
|
397
|
foreach my $name (@_) { |
42
|
|
|
|
|
|
|
|
43
|
170
|
|
|
|
|
672
|
local $^W = 0; |
44
|
|
|
|
|
|
|
|
45
|
170
|
50
|
|
|
|
210
|
next if defined *{"ASSERT_$name"}{CODE}; |
|
170
|
|
|
|
|
1109
|
|
46
|
170
|
50
|
|
|
|
212
|
if (defined *{"POE::Kernel::ASSERT_$name"}{CODE}) { |
|
170
|
|
|
|
|
977
|
|
47
|
|
|
|
|
|
|
eval( |
48
|
0
|
|
|
|
|
0
|
"sub ASSERT_$name () { " . |
49
|
0
|
|
|
|
|
0
|
*{"POE::Kernel::ASSERT_$name"}{CODE}->() . |
50
|
|
|
|
|
|
|
"}" |
51
|
|
|
|
|
|
|
); |
52
|
0
|
0
|
|
|
|
0
|
die if $@; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
else { |
55
|
170
|
|
|
|
|
5052
|
eval "sub ASSERT_$name () { ASSERT_DEFAULT }"; |
56
|
170
|
50
|
|
|
|
1055
|
die if $@; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# Shorthand for defining a trace constant. |
62
|
|
|
|
|
|
|
sub _define_trace { |
63
|
170
|
|
|
170
|
|
747
|
no strict 'refs'; |
|
170
|
|
|
|
|
195
|
|
|
170
|
|
|
|
|
32198
|
|
64
|
|
|
|
|
|
|
|
65
|
170
|
|
|
170
|
|
410
|
local $^W = 0; |
66
|
|
|
|
|
|
|
|
67
|
170
|
|
|
|
|
318
|
foreach my $name (@_) { |
68
|
170
|
50
|
|
|
|
200
|
next if defined *{"TRACE_$name"}{CODE}; |
|
170
|
|
|
|
|
851
|
|
69
|
170
|
50
|
|
|
|
193
|
if (defined *{"POE::Kernel::TRACE_$name"}{CODE}) { |
|
170
|
|
|
|
|
909
|
|
70
|
|
|
|
|
|
|
eval( |
71
|
0
|
|
|
|
|
0
|
"sub TRACE_$name () { " . |
72
|
0
|
|
|
|
|
0
|
*{"POE::Kernel::TRACE_$name"}{CODE}->() . |
73
|
|
|
|
|
|
|
"}" |
74
|
|
|
|
|
|
|
); |
75
|
0
|
0
|
|
|
|
0
|
die if $@; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
else { |
78
|
170
|
|
|
|
|
4893
|
eval "sub TRACE_$name () { TRACE_DEFAULT }"; |
79
|
170
|
50
|
|
|
|
34567
|
die if $@; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
BEGIN { |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# ASSERT_DEFAULT changes the default value for other ASSERT_* |
87
|
|
|
|
|
|
|
# constants. It inherits POE::Kernel's ASSERT_DEFAULT value, if |
88
|
|
|
|
|
|
|
# it's present. |
89
|
|
|
|
|
|
|
|
90
|
170
|
50
|
|
170
|
|
722
|
unless (defined &ASSERT_DEFAULT) { |
91
|
170
|
50
|
|
|
|
619
|
if (defined &POE::Kernel::ASSERT_DEFAULT) { |
92
|
170
|
|
|
|
|
6341
|
eval( "sub ASSERT_DEFAULT () { " . &POE::Kernel::ASSERT_DEFAULT . " }" ); |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
else { |
95
|
0
|
|
|
|
|
0
|
eval 'sub ASSERT_DEFAULT () { 0 }'; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
}; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# TRACE_DEFAULT changes the default value for other TRACE_* |
100
|
|
|
|
|
|
|
# constants. It inherits POE::Kernel's TRACE_DEFAULT value, if |
101
|
|
|
|
|
|
|
# it's present. |
102
|
|
|
|
|
|
|
|
103
|
170
|
50
|
|
|
|
710
|
unless (defined &TRACE_DEFAULT) { |
104
|
170
|
50
|
|
|
|
429
|
if (defined &POE::Kernel::TRACE_DEFAULT) { |
105
|
170
|
|
|
|
|
4620
|
eval( "sub TRACE_DEFAULT () { " . &POE::Kernel::TRACE_DEFAULT . " }" ); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
else { |
108
|
0
|
|
|
|
|
0
|
eval 'sub TRACE_DEFAULT () { 0 }'; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
}; |
111
|
|
|
|
|
|
|
|
112
|
170
|
|
|
|
|
512
|
_define_assert("STATES"); |
113
|
170
|
|
|
|
|
401
|
_define_trace("DESTROY"); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
117
|
|
|
|
|
|
|
# Export constants into calling packages. This is evil; perhaps |
118
|
|
|
|
|
|
|
# EXPORT_OK instead? The parameters NFA has in common with SESSION |
119
|
|
|
|
|
|
|
# (and other sessions) must be kept at the same offsets as each-other. |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub OBJECT () { 0 } # TODO - deprecate and replace with SELF |
122
|
|
|
|
|
|
|
sub SESSION () { 1 } |
123
|
|
|
|
|
|
|
sub KERNEL () { 2 } |
124
|
|
|
|
|
|
|
sub HEAP () { 3 } |
125
|
|
|
|
|
|
|
sub STATE () { 4 } # TODO - deprecate and replace with EVENT |
126
|
|
|
|
|
|
|
sub SENDER () { 5 } |
127
|
|
|
|
|
|
|
# NFA keeps its state in 6. unused in session so that args match up. |
128
|
|
|
|
|
|
|
sub CALLER_FILE () { 7 } |
129
|
|
|
|
|
|
|
sub CALLER_LINE () { 8 } |
130
|
|
|
|
|
|
|
sub CALLER_STATE () { 9 } # TODO - deprecate and replace with CALLER_EVENT |
131
|
|
|
|
|
|
|
sub ARG0 () { 10 } |
132
|
|
|
|
|
|
|
sub ARG1 () { 11 } |
133
|
|
|
|
|
|
|
sub ARG2 () { 12 } |
134
|
|
|
|
|
|
|
sub ARG3 () { 13 } |
135
|
|
|
|
|
|
|
sub ARG4 () { 14 } |
136
|
|
|
|
|
|
|
sub ARG5 () { 15 } |
137
|
|
|
|
|
|
|
sub ARG6 () { 16 } |
138
|
|
|
|
|
|
|
sub ARG7 () { 17 } |
139
|
|
|
|
|
|
|
sub ARG8 () { 18 } |
140
|
|
|
|
|
|
|
sub ARG9 () { 19 } |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub import { |
143
|
361
|
|
|
361
|
|
849
|
my $package = caller(); |
144
|
170
|
|
|
170
|
|
829
|
no strict 'refs'; |
|
170
|
|
|
|
|
218
|
|
|
170
|
|
|
|
|
353959
|
|
145
|
361
|
|
|
|
|
627
|
*{ $package . '::OBJECT' } = \&OBJECT; |
|
361
|
|
|
|
|
1665
|
|
146
|
361
|
|
|
|
|
550
|
*{ $package . '::SESSION' } = \&SESSION; |
|
361
|
|
|
|
|
1060
|
|
147
|
361
|
|
|
|
|
498
|
*{ $package . '::KERNEL' } = \&KERNEL; |
|
361
|
|
|
|
|
997
|
|
148
|
361
|
|
|
|
|
479
|
*{ $package . '::HEAP' } = \&HEAP; |
|
361
|
|
|
|
|
1322
|
|
149
|
361
|
|
|
|
|
438
|
*{ $package . '::STATE' } = \&STATE; |
|
361
|
|
|
|
|
1005
|
|
150
|
361
|
|
|
|
|
487
|
*{ $package . '::SENDER' } = \&SENDER; |
|
361
|
|
|
|
|
972
|
|
151
|
361
|
|
|
|
|
486
|
*{ $package . '::ARG0' } = \&ARG0; |
|
361
|
|
|
|
|
3493
|
|
152
|
361
|
|
|
|
|
452
|
*{ $package . '::ARG1' } = \&ARG1; |
|
361
|
|
|
|
|
1065
|
|
153
|
361
|
|
|
|
|
486
|
*{ $package . '::ARG2' } = \&ARG2; |
|
361
|
|
|
|
|
1081
|
|
154
|
361
|
|
|
|
|
517
|
*{ $package . '::ARG3' } = \&ARG3; |
|
361
|
|
|
|
|
944
|
|
155
|
361
|
|
|
|
|
442
|
*{ $package . '::ARG4' } = \&ARG4; |
|
361
|
|
|
|
|
901
|
|
156
|
361
|
|
|
|
|
455
|
*{ $package . '::ARG5' } = \&ARG5; |
|
361
|
|
|
|
|
896
|
|
157
|
361
|
|
|
|
|
424
|
*{ $package . '::ARG6' } = \&ARG6; |
|
361
|
|
|
|
|
887
|
|
158
|
361
|
|
|
|
|
508
|
*{ $package . '::ARG7' } = \&ARG7; |
|
361
|
|
|
|
|
2463
|
|
159
|
361
|
|
|
|
|
473
|
*{ $package . '::ARG8' } = \&ARG8; |
|
361
|
|
|
|
|
874
|
|
160
|
361
|
|
|
|
|
446
|
*{ $package . '::ARG9' } = \&ARG9; |
|
361
|
|
|
|
|
940
|
|
161
|
361
|
|
|
|
|
473
|
*{ $package . '::CALLER_FILE' } = \&CALLER_FILE; |
|
361
|
|
|
|
|
14623
|
|
162
|
361
|
|
|
|
|
494
|
*{ $package . '::CALLER_LINE' } = \&CALLER_LINE; |
|
361
|
|
|
|
|
929
|
|
163
|
361
|
|
|
|
|
453
|
*{ $package . '::CALLER_STATE' } = \&CALLER_STATE; |
|
361
|
|
|
|
|
9401
|
|
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub instantiate { |
167
|
801
|
|
|
801
|
1
|
1356
|
my $type = shift; |
168
|
|
|
|
|
|
|
|
169
|
801
|
50
|
|
|
|
2039
|
croak "$type requires a working Kernel" |
170
|
|
|
|
|
|
|
unless defined $POE::Kernel::poe_kernel; |
171
|
|
|
|
|
|
|
|
172
|
801
|
|
|
|
|
2914
|
my $self = |
173
|
|
|
|
|
|
|
bless [ { }, # SE_NAMESPACE |
174
|
|
|
|
|
|
|
{ }, # SE_OPTIONS |
175
|
|
|
|
|
|
|
{ }, # SE_STATES |
176
|
|
|
|
|
|
|
], $type; |
177
|
|
|
|
|
|
|
|
178
|
801
|
|
|
|
|
1061
|
if (ASSERT_STATES) { |
179
|
|
|
|
|
|
|
$self->[SE_OPTIONS]->{+OPT_DEFAULT} = 1; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
801
|
|
|
|
|
2966
|
return $self; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub try_alloc { |
186
|
1451
|
|
|
801
|
1
|
2559
|
my ($self, @args) = @_; |
187
|
|
|
|
|
|
|
# Verify that the session has a special start state, otherwise how |
188
|
|
|
|
|
|
|
# do we know what to do? Don't even bother registering the session |
189
|
|
|
|
|
|
|
# if the start state doesn't exist. |
190
|
|
|
|
|
|
|
|
191
|
801
|
50
|
|
|
|
2229
|
if (exists $self->[SE_STATES]->{+EN_START}) { |
192
|
801
|
|
|
|
|
3435
|
$POE::Kernel::poe_kernel->session_alloc($self, @args); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
else { |
195
|
0
|
|
|
|
|
0
|
carp( "discarding session ", |
196
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
197
|
|
|
|
|
|
|
" - no '_start' state" |
198
|
|
|
|
|
|
|
); |
199
|
0
|
|
|
|
|
0
|
$self = undef; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
737
|
|
|
|
|
12773
|
$self; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
206
|
|
|
|
|
|
|
# New style constructor. This uses less DWIM and more DWIS, and it's |
207
|
|
|
|
|
|
|
# more comfortable for some folks; especially the ones who don't quite |
208
|
|
|
|
|
|
|
# know WTM. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub create { |
211
|
803
|
|
|
803
|
1
|
229205
|
my ($type, @params) = @_; |
212
|
803
|
|
|
|
|
1193
|
my @args; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# We treat the parameter list strictly as a hash. Rather than dying |
215
|
|
|
|
|
|
|
# here with a Perl error, we'll catch it and blame it on the user. |
216
|
|
|
|
|
|
|
|
217
|
803
|
100
|
|
|
|
2425
|
if (@params & 1) { |
218
|
2
|
|
|
|
|
197
|
croak "odd number of events/handlers (missing one or the other?)"; |
219
|
|
|
|
|
|
|
} |
220
|
801
|
|
|
|
|
2997
|
my %params = @params; |
221
|
|
|
|
|
|
|
|
222
|
801
|
|
|
|
|
2798
|
my $self = $type->instantiate(\%params); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Process _start arguments. We try to do the right things with what |
225
|
|
|
|
|
|
|
# we're given. If the arguments are a list reference, map its items |
226
|
|
|
|
|
|
|
# to ARG0..ARGn; otherwise make whatever the heck it is be ARG0. |
227
|
|
|
|
|
|
|
|
228
|
801
|
100
|
|
|
|
2306
|
if (exists $params{+CREATE_ARGS}) { |
229
|
358
|
50
|
|
|
|
1323
|
if (ref($params{+CREATE_ARGS}) eq 'ARRAY') { |
230
|
358
|
|
|
|
|
443
|
push @args, @{$params{+CREATE_ARGS}}; |
|
358
|
|
|
|
|
853
|
|
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
else { |
233
|
0
|
|
|
|
|
0
|
push @args, $params{+CREATE_ARGS}; |
234
|
|
|
|
|
|
|
} |
235
|
358
|
|
|
|
|
845
|
delete $params{+CREATE_ARGS}; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# Process session options here. Several options may be set. |
239
|
|
|
|
|
|
|
|
240
|
801
|
100
|
|
|
|
2009
|
if (exists $params{+CREATE_OPTIONS}) { |
241
|
4
|
50
|
|
|
|
16
|
if (ref($params{+CREATE_OPTIONS}) eq 'HASH') { |
242
|
4
|
|
|
|
|
10
|
$self->[SE_OPTIONS] = $params{+CREATE_OPTIONS}; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
else { |
245
|
0
|
|
|
|
|
0
|
croak "options for $type constructor is expected to be a HASH reference"; |
246
|
|
|
|
|
|
|
} |
247
|
4
|
|
|
|
|
12
|
delete $params{+CREATE_OPTIONS}; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# Get down to the business of defining states. |
251
|
|
|
|
|
|
|
|
252
|
801
|
|
|
|
|
2995
|
while (my ($param_name, $param_value) = each %params) { |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Inline states are expected to be state-name/coderef pairs. |
255
|
|
|
|
|
|
|
|
256
|
1190
|
100
|
|
|
|
3949
|
if ($param_name eq CREATE_INLINES) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
257
|
694
|
50
|
|
|
|
1843
|
croak "$param_name does not refer to a hash" |
258
|
|
|
|
|
|
|
unless (ref($param_value) eq 'HASH'); |
259
|
|
|
|
|
|
|
|
260
|
694
|
|
|
|
|
2340
|
while (my ($state, $handler) = each(%$param_value)) { |
261
|
4863
|
50
|
|
|
|
7545
|
croak "inline state for '$state' needs a CODE reference" |
262
|
|
|
|
|
|
|
unless (ref($handler) eq 'CODE'); |
263
|
4863
|
|
|
|
|
6795
|
$self->_register_state($state, $handler); |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# Package states are expected to be package-name/list-or-hashref |
268
|
|
|
|
|
|
|
# pairs. If the second part of the pair is a arrayref, then the |
269
|
|
|
|
|
|
|
# package methods are expected to be named after the states |
270
|
|
|
|
|
|
|
# they'll handle. If it's a hashref, then the keys are state |
271
|
|
|
|
|
|
|
# names and the values are package methods that implement them. |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
elsif ($param_name eq CREATE_PACKAGES) { |
274
|
200
|
50
|
|
|
|
670
|
croak "$param_name does not refer to an array" |
275
|
|
|
|
|
|
|
unless (ref($param_value) eq 'ARRAY'); |
276
|
200
|
50
|
|
|
|
598
|
croak "the array for $param_name has an odd number of elements" |
277
|
|
|
|
|
|
|
if (@$param_value & 1); |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# Copy the parameters so they aren't destroyed. |
280
|
200
|
|
|
|
|
475
|
my @param_value = @$param_value; |
281
|
200
|
|
|
|
|
955
|
while (my ($package, $handlers) = splice(@param_value, 0, 2)) { |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# TODO What do we do if the package name has some sort of |
284
|
|
|
|
|
|
|
# blessing? Do we use the blessed thingy's package, or do we |
285
|
|
|
|
|
|
|
# maybe complain because the user might have wanted to make |
286
|
|
|
|
|
|
|
# object states instead? |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# An array of handlers. The array's items are passed through |
289
|
|
|
|
|
|
|
# as both state names and package method names. |
290
|
|
|
|
|
|
|
|
291
|
103
|
100
|
|
|
|
2338
|
if (ref($handlers) eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
292
|
100
|
|
|
|
|
355
|
foreach my $method (@$handlers) { |
293
|
863
|
|
|
|
|
1295
|
$self->_register_state($method, $package, $method); |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# A hash of handlers. Hash keys are state names; values are |
298
|
|
|
|
|
|
|
# package methods to implement them. |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
elsif (ref($handlers) eq 'HASH') { |
301
|
3
|
|
|
|
|
15
|
while (my ($state, $method) = each %$handlers) { |
302
|
7
|
|
|
|
|
13
|
$self->_register_state($state, $package, $method); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
else { |
307
|
0
|
|
|
|
|
0
|
croak( "states for package '$package' " . |
308
|
|
|
|
|
|
|
"need to be a hash or array ref" |
309
|
|
|
|
|
|
|
); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# Object states are expected to be object-reference/ |
315
|
|
|
|
|
|
|
# list-or-hashref pairs. They must be passed to &create in a list |
316
|
|
|
|
|
|
|
# reference instead of a hash reference because making object |
317
|
|
|
|
|
|
|
# references into hash keys loses their blessings. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
elsif ($param_name eq CREATE_OBJECTS) { |
320
|
104
|
50
|
|
|
|
250
|
croak "$param_name does not refer to an array" |
321
|
|
|
|
|
|
|
unless (ref($param_value) eq 'ARRAY'); |
322
|
104
|
50
|
|
|
|
217
|
croak "the array for $param_name has an odd number of elements" |
323
|
|
|
|
|
|
|
if (@$param_value & 1); |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# Copy the parameters so they aren't destroyed. |
326
|
104
|
|
|
|
|
161
|
my @param_value = @$param_value; |
327
|
104
|
|
|
|
|
357
|
while (@param_value) { |
328
|
7
|
|
|
|
|
18
|
my ($object, $handlers) = splice(@param_value, 0, 2); |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# Verify that the object is an object. This may catch simple |
331
|
|
|
|
|
|
|
# mistakes; or it may be overkill since it already checks that |
332
|
|
|
|
|
|
|
# $param_value is a arrayref. |
333
|
|
|
|
|
|
|
|
334
|
7
|
50
|
|
|
|
20
|
carp "'$object' is not an object" unless ref($object); |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# An array of handlers. The array's items are passed through |
337
|
|
|
|
|
|
|
# as both state names and object method names. |
338
|
|
|
|
|
|
|
|
339
|
7
|
100
|
|
|
|
25
|
if (ref($handlers) eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
340
|
4
|
|
|
|
|
12
|
foreach my $method (@$handlers) { |
341
|
13
|
|
|
|
|
25
|
$self->_register_state($method, $object, $method); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# A hash of handlers. Hash keys are state names; values are |
346
|
|
|
|
|
|
|
# package methods to implement them. |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
elsif (ref($handlers) eq 'HASH') { |
349
|
3
|
|
|
|
|
14
|
while (my ($state, $method) = each %$handlers) { |
350
|
7
|
|
|
|
|
12
|
$self->_register_state($state, $object, $method); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
else { |
355
|
0
|
|
|
|
|
0
|
croak "states for object '$object' need to be a hash or array ref"; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
# Import an external heap. This is a convenience, since it |
362
|
|
|
|
|
|
|
# eliminates the need to connect _start options to heap values. |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
elsif ($param_name eq CREATE_HEAP) { |
365
|
192
|
|
|
|
|
594
|
$self->[SE_NAMESPACE] = $param_value; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
else { |
369
|
0
|
|
|
|
|
0
|
croak "unknown $type parameter: $param_name"; |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
801
|
|
|
|
|
2524
|
return $self->try_alloc(@args); |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
sub DESTROY { |
379
|
557
|
|
|
557
|
|
1128
|
my $self = shift; |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
# Session's data structures are destroyed through Perl's usual |
382
|
|
|
|
|
|
|
# garbage collection. TRACE_DESTROY here just shows what's in the |
383
|
|
|
|
|
|
|
# session before the destruction finishes. |
384
|
|
|
|
|
|
|
|
385
|
557
|
|
|
|
|
10201
|
TRACE_DESTROY and do { |
386
|
|
|
|
|
|
|
require Data::Dumper; |
387
|
|
|
|
|
|
|
POE::Kernel::_warn( |
388
|
|
|
|
|
|
|
"----- Session $self Leak Check -----\n", |
389
|
|
|
|
|
|
|
"-- Namespace (HEAP):\n", |
390
|
|
|
|
|
|
|
Data::Dumper::Dumper($self->[SE_NAMESPACE]), |
391
|
|
|
|
|
|
|
"-- Options:\n", |
392
|
|
|
|
|
|
|
); |
393
|
|
|
|
|
|
|
foreach (sort keys (%{$self->[SE_OPTIONS]})) { |
394
|
|
|
|
|
|
|
POE::Kernel::_warn(" $_ = ", $self->[SE_OPTIONS]->{$_}, "\n"); |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
POE::Kernel::_warn("-- States:\n"); |
397
|
|
|
|
|
|
|
foreach (sort keys (%{$self->[SE_STATES]})) { |
398
|
|
|
|
|
|
|
POE::Kernel::_warn(" $_ = ", $self->[SE_STATES]->{$_}, "\n"); |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
}; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
sub _invoke_state { |
406
|
9163
|
|
|
8897
|
|
67852
|
my ($self, $source_session, $state, $etc, $file, $line, $fromstate) = @_; |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Trace the state invocation if tracing is enabled. |
409
|
|
|
|
|
|
|
|
410
|
9163
|
100
|
|
|
|
347048
|
if ($self->[SE_OPTIONS]->{+OPT_TRACE}) { |
411
|
274
|
|
|
|
|
3118
|
POE::Kernel::_warn( |
412
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
413
|
|
|
|
|
|
|
" -> $state (from $file at $line)\n" |
414
|
|
|
|
|
|
|
); |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
# The desired destination state doesn't exist in this session. |
418
|
|
|
|
|
|
|
# Attempt to redirect the state transition to _default. |
419
|
|
|
|
|
|
|
|
420
|
9163
|
100
|
|
|
|
23959
|
unless (exists $self->[SE_STATES]->{$state}) { |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# There's no _default either; redirection's not happening today. |
423
|
|
|
|
|
|
|
# Drop the state transition event on the floor, and optionally |
424
|
|
|
|
|
|
|
# make some noise about it. |
425
|
|
|
|
|
|
|
|
426
|
581
|
100
|
|
|
|
2146
|
unless (exists $self->[SE_STATES]->{+EN_DEFAULT}) { |
427
|
461
|
50
|
|
|
|
1934
|
$! = exists &Errno::ENOSYS ? &Errno::ENOSYS : &Errno::EIO; |
428
|
461
|
100
|
66
|
|
|
1402
|
if ($self->[SE_OPTIONS]->{+OPT_DEFAULT} and $state ne EN_SIGNAL) { |
429
|
267
|
|
|
|
|
2314
|
my $loggable_self = |
430
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->_data_alias_loggable($self->ID); |
431
|
1755
|
|
|
|
|
8445
|
POE::Kernel::_warn( |
432
|
|
|
|
|
|
|
"a '$state' event was sent from $file at $line to $loggable_self ", |
433
|
|
|
|
|
|
|
"but $loggable_self has neither a handler for it ", |
434
|
|
|
|
|
|
|
"nor one for _default\n" |
435
|
|
|
|
|
|
|
); |
436
|
|
|
|
|
|
|
} |
437
|
195
|
|
|
|
|
456
|
return undef; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# If we get this far, then there's a _default state to redirect |
441
|
|
|
|
|
|
|
# the transition to. Trace the redirection. |
442
|
|
|
|
|
|
|
|
443
|
122
|
50
|
|
|
|
260
|
if ($self->[SE_OPTIONS]->{+OPT_TRACE}) { |
444
|
0
|
|
|
|
|
0
|
POE::Kernel::_warn( |
445
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
446
|
|
|
|
|
|
|
" -> $state redirected to _default\n" |
447
|
|
|
|
|
|
|
); |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
# Transmogrify the original state transition into a corresponding |
451
|
|
|
|
|
|
|
# _default invocation. ARG1 is copied from $etc so it can't be |
452
|
|
|
|
|
|
|
# altered from a distance. |
453
|
|
|
|
|
|
|
|
454
|
122
|
|
|
|
|
266
|
$etc = [ $state, [@$etc] ]; |
455
|
122
|
|
|
|
|
146
|
$state = EN_DEFAULT; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# If we get this far, then the state can be invoked. So invoke it |
459
|
|
|
|
|
|
|
# already! |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
# Inline states are invoked this way. |
462
|
|
|
|
|
|
|
|
463
|
8702
|
100
|
|
|
|
22593
|
if (ref($self->[SE_STATES]->{$state}) eq 'CODE') { |
464
|
6175
|
|
|
|
|
26747
|
return $self->[SE_STATES]->{$state}-> |
465
|
|
|
|
|
|
|
( undef, # object |
466
|
|
|
|
|
|
|
$self, # session |
467
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel, # kernel |
468
|
|
|
|
|
|
|
$self->[SE_NAMESPACE], # heap |
469
|
|
|
|
|
|
|
$state, # state |
470
|
|
|
|
|
|
|
$source_session, # sender |
471
|
|
|
|
|
|
|
undef, # unused #6 |
472
|
|
|
|
|
|
|
$file, # caller file name |
473
|
|
|
|
|
|
|
$line, # caller file line |
474
|
|
|
|
|
|
|
$fromstate, # caller state |
475
|
|
|
|
|
|
|
@$etc # args |
476
|
|
|
|
|
|
|
); |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# Package and object states are invoked this way. |
480
|
|
|
|
|
|
|
|
481
|
2527
|
|
|
|
|
2605
|
my ($object, $method) = @{$self->[SE_STATES]->{$state}}; |
|
2527
|
|
|
|
|
4569
|
|
482
|
|
|
|
|
|
|
return |
483
|
2527
|
|
|
|
|
10654
|
$object->$method # package/object (implied) |
484
|
|
|
|
|
|
|
( $self, # session |
485
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel, # kernel |
486
|
|
|
|
|
|
|
$self->[SE_NAMESPACE], # heap |
487
|
|
|
|
|
|
|
$state, # state |
488
|
|
|
|
|
|
|
$source_session, # sender |
489
|
|
|
|
|
|
|
undef, # unused #6 |
490
|
|
|
|
|
|
|
$file, # caller file name |
491
|
|
|
|
|
|
|
$line, # caller file line |
492
|
|
|
|
|
|
|
$fromstate, # caller state |
493
|
|
|
|
|
|
|
@$etc # args |
494
|
|
|
|
|
|
|
); |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
498
|
|
|
|
|
|
|
# Add, remove or replace states in the session. |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
sub _register_state { |
501
|
7843
|
|
|
7843
|
|
10411
|
my ($self, $name, $handler, $method) = @_; |
502
|
7843
|
100
|
|
|
|
13430
|
$method = $name unless defined $method; |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
# Deprecate _signal. |
505
|
|
|
|
|
|
|
# RC 2004-09-07 - Decided to leave this in because it blames |
506
|
|
|
|
|
|
|
# problems with _signal on the user for using it. It should |
507
|
|
|
|
|
|
|
# probably go away after a little while, but not during the other |
508
|
|
|
|
|
|
|
# deprecations. |
509
|
|
|
|
|
|
|
|
510
|
7843
|
50
|
|
|
|
12525
|
if ($name eq EN_SIGNAL) { |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
# Report the problem outside POE. |
513
|
0
|
|
|
|
|
0
|
my $caller_level = 0; |
514
|
0
|
|
|
|
|
0
|
local $Carp::CarpLevel = 1; |
515
|
0
|
|
|
|
|
0
|
while ( (caller $caller_level)[0] =~ /^POE::/ ) { |
516
|
0
|
|
|
|
|
0
|
$caller_level++; |
517
|
0
|
|
|
|
|
0
|
$Carp::CarpLevel++; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
croak( |
521
|
0
|
|
|
|
|
0
|
",----- DEPRECATION ERROR -----\n", |
522
|
|
|
|
|
|
|
"| The _signal event is deprecated. Please use sig() to register\n", |
523
|
|
|
|
|
|
|
"| an explicit signal handler instead.\n", |
524
|
|
|
|
|
|
|
"`-----------------------------\n", |
525
|
|
|
|
|
|
|
); |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
# There is a handler, so try to define the state. This replaces an |
529
|
|
|
|
|
|
|
# existing state. |
530
|
|
|
|
|
|
|
|
531
|
7843
|
100
|
|
|
|
10544
|
if ($handler) { |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# Coderef handlers are inline states. |
534
|
|
|
|
|
|
|
|
535
|
6886
|
100
|
|
|
|
13216
|
if (ref($handler) eq 'CODE') { |
|
|
50
|
|
|
|
|
|
536
|
5996
|
50
|
66
|
|
|
12608
|
carp( "redefining handler for event($name) for session(", |
537
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), ")" |
538
|
|
|
|
|
|
|
) |
539
|
|
|
|
|
|
|
if ( $self->[SE_OPTIONS]->{+OPT_DEBUG} && |
540
|
|
|
|
|
|
|
(exists $self->[SE_STATES]->{$name}) |
541
|
|
|
|
|
|
|
); |
542
|
5996
|
|
|
|
|
20875
|
$self->[SE_STATES]->{$name} = $handler; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# Non-coderef handlers may be package or object states. See if |
546
|
|
|
|
|
|
|
# the method belongs to the handler. |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
elsif ($handler->can($method)) { |
549
|
890
|
50
|
33
|
|
|
2208
|
carp( "redefining handler for event($name) for session(", |
550
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), ")" |
551
|
|
|
|
|
|
|
) |
552
|
|
|
|
|
|
|
if ( $self->[SE_OPTIONS]->{+OPT_DEBUG} && |
553
|
|
|
|
|
|
|
(exists $self->[SE_STATES]->{$name}) |
554
|
|
|
|
|
|
|
); |
555
|
890
|
|
|
|
|
5501
|
$self->[SE_STATES]->{$name} = [ $handler, $method ]; |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
# Something's wrong. This code also seems wrong, since |
559
|
|
|
|
|
|
|
# ref($handler) can't be 'CODE'. |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
else { |
562
|
0
|
0
|
0
|
|
|
0
|
if ( (ref($handler) eq 'CODE') and |
563
|
|
|
|
|
|
|
$self->[SE_OPTIONS]->{+OPT_TRACE} |
564
|
|
|
|
|
|
|
) { |
565
|
0
|
|
|
|
|
0
|
carp( $POE::Kernel::poe_kernel->ID_session_to_id($self), |
566
|
|
|
|
|
|
|
" : handler for event($name) is not a proper ref - not registered" |
567
|
|
|
|
|
|
|
) |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
else { |
570
|
0
|
0
|
|
|
|
0
|
unless ($handler->can($method)) { |
571
|
0
|
0
|
|
|
|
0
|
if (length ref($handler)) { |
572
|
0
|
|
|
|
|
0
|
croak "object $handler does not have a '$method' method" |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
else { |
575
|
0
|
|
|
|
|
0
|
croak "package $handler does not have a '$method' method"; |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
# No handler. Delete the state! |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
else { |
585
|
957
|
|
|
|
|
8726
|
delete $self->[SE_STATES]->{$name}; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
590
|
|
|
|
|
|
|
# Return the session's ID. This is a thunk into POE::Kernel, where |
591
|
|
|
|
|
|
|
# the session ID really lies. |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
sub _set_id { |
594
|
809
|
|
|
809
|
|
1436
|
my ($self, $id) = @_; |
595
|
809
|
|
|
|
|
2274
|
$self->[SE_ID] = $id; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
sub ID { |
599
|
833826
|
|
|
833826
|
1
|
1626680
|
return shift()->[SE_ID]; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
603
|
|
|
|
|
|
|
# Set or fetch session options. |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
sub option { |
606
|
8
|
|
|
8
|
1
|
1975
|
my $self = shift; |
607
|
8
|
|
|
|
|
10
|
my %return_values; |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
# Options are set in pairs. |
610
|
|
|
|
|
|
|
|
611
|
8
|
|
|
|
|
24
|
while (@_ >= 2) { |
612
|
4
|
|
|
|
|
10
|
my ($flag, $value) = splice(@_, 0, 2); |
613
|
4
|
|
|
|
|
8
|
$flag = lc($flag); |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# If the value is defined, then set the option. |
616
|
|
|
|
|
|
|
|
617
|
4
|
50
|
|
|
|
9
|
if (defined $value) { |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# Change some handy values into boolean representations. This |
620
|
|
|
|
|
|
|
# clobbers the user's original values for the sake of DWIM-ism. |
621
|
|
|
|
|
|
|
|
622
|
4
|
50
|
|
|
|
11
|
($value = 1) if ($value =~ /^(on|yes|true)$/i); |
623
|
4
|
50
|
|
|
|
9
|
($value = 0) if ($value =~ /^(no|off|false)$/i); |
624
|
|
|
|
|
|
|
|
625
|
4
|
|
|
|
|
10
|
$return_values{$flag} = $self->[SE_OPTIONS]->{$flag}; |
626
|
4
|
|
|
|
|
16
|
$self->[SE_OPTIONS]->{$flag} = $value; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# Remove the option if the value is undefined. |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
else { |
632
|
0
|
|
|
|
|
0
|
$return_values{$flag} = delete $self->[SE_OPTIONS]->{$flag}; |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
# If only one option is left, then there's no value to set, so we |
637
|
|
|
|
|
|
|
# fetch its value. |
638
|
|
|
|
|
|
|
|
639
|
8
|
100
|
|
|
|
17
|
if (@_) { |
640
|
4
|
|
|
|
|
8
|
my $flag = lc(shift); |
641
|
4
|
50
|
|
|
|
25
|
$return_values{$flag} = |
642
|
|
|
|
|
|
|
( exists($self->[SE_OPTIONS]->{$flag}) |
643
|
|
|
|
|
|
|
? $self->[SE_OPTIONS]->{$flag} |
644
|
|
|
|
|
|
|
: undef |
645
|
|
|
|
|
|
|
); |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
# If only one option was set or fetched, then return it as a scalar. |
649
|
|
|
|
|
|
|
# Otherwise return it as a hash of option names and values. |
650
|
|
|
|
|
|
|
|
651
|
8
|
|
|
|
|
29
|
my @return_keys = keys(%return_values); |
652
|
8
|
50
|
|
|
|
20
|
if (@return_keys == 1) { |
653
|
8
|
|
|
|
|
30
|
return $return_values{$return_keys[0]}; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
else { |
656
|
0
|
|
|
|
|
0
|
return \%return_values; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# Fetch the session's heap. In rare cases, libraries may need to |
661
|
|
|
|
|
|
|
# break encapsulation this way, probably also using |
662
|
|
|
|
|
|
|
# $kernel->get_current_session as an accessory to the crime. |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
sub get_heap { |
665
|
2
|
|
|
2
|
1
|
4
|
my $self = shift; |
666
|
2
|
|
|
|
|
10
|
return $self->[SE_NAMESPACE]; |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
670
|
|
|
|
|
|
|
# Create an anonymous sub that, when called, posts an event back to a |
671
|
|
|
|
|
|
|
# session. This maps postback references (stringified; blessing, and |
672
|
|
|
|
|
|
|
# thus refcount, removed) to parent session IDs. Members are set when |
673
|
|
|
|
|
|
|
# postbacks are created, and postbacks' DESTROY methods use it to |
674
|
|
|
|
|
|
|
# perform the necessary cleanup when they go away. Thanks to njt for |
675
|
|
|
|
|
|
|
# steering me right on this one. |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
my %anonevent_parent_id; |
678
|
|
|
|
|
|
|
my %anonevent_weakened; |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# I assume that when the postback owner loses all reference to it, |
681
|
|
|
|
|
|
|
# they are done posting things back to us. That's when the postback's |
682
|
|
|
|
|
|
|
# DESTROY is triggered, and referential integrity is maintained. |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
sub POE::Session::AnonEvent::DESTROY { |
685
|
15
|
|
|
15
|
|
569
|
my $self = shift; |
686
|
15
|
|
|
|
|
44
|
my $parent_id = delete $anonevent_parent_id{$self}; |
687
|
15
|
50
|
|
|
|
50
|
unless (delete $anonevent_weakened{$self}) { |
688
|
15
|
|
|
|
|
62
|
$POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'anon_event' ); |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
sub POE::Session::AnonEvent::weaken { |
693
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
694
|
0
|
0
|
|
|
|
0
|
unless ($anonevent_weakened{$self}) { |
695
|
0
|
|
|
|
|
0
|
my $parent_id = $anonevent_parent_id{$self}; |
696
|
0
|
|
|
|
|
0
|
$POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'anon_event' ); |
697
|
0
|
|
|
|
|
0
|
$anonevent_weakened{$self} = 1; |
698
|
|
|
|
|
|
|
} |
699
|
0
|
|
|
|
|
0
|
return $self; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# Tune postbacks depending on variations in toolkit behavior. |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
BEGIN { |
705
|
|
|
|
|
|
|
# Tk blesses its callbacks internally, so we need to wrap our |
706
|
|
|
|
|
|
|
# blessed callbacks in unblessed ones. Otherwise our postback's |
707
|
|
|
|
|
|
|
# DESTROY method probably won't be called. |
708
|
170
|
50
|
|
170
|
|
817
|
if (exists $INC{'Tk.pm'}) { |
709
|
0
|
|
|
|
|
0
|
eval 'sub USING_TK () { 1 }'; |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
else { |
712
|
170
|
|
|
|
|
43586
|
eval 'sub USING_TK () { 0 }'; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
}; |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
# Create a postback closure, maintaining referential integrity in the |
717
|
|
|
|
|
|
|
# process. The next step is to give it to something that expects to |
718
|
|
|
|
|
|
|
# be handed a callback. |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
sub postback { |
721
|
7
|
|
|
7
|
1
|
50
|
my ($self, $event, @etc) = @_; |
722
|
7
|
|
|
|
|
27
|
my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
my $postback = bless sub { |
725
|
7
|
|
|
7
|
|
413
|
$POE::Kernel::poe_kernel->post( $id, $event, [ @etc ], [ @_ ] ); |
726
|
7
|
|
|
|
|
23
|
return 0; |
727
|
7
|
|
|
|
|
55
|
}, 'POE::Session::AnonEvent'; |
728
|
|
|
|
|
|
|
|
729
|
7
|
|
|
|
|
34
|
$anonevent_parent_id{$postback} = $id; |
730
|
7
|
|
|
|
|
26
|
$POE::Kernel::poe_kernel->refcount_increment( $id, 'anon_event' ); |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# Tk blesses its callbacks, so we must present one that isn't |
733
|
|
|
|
|
|
|
# blessed. Otherwise Tk's blessing would divert our DESTROY call to |
734
|
|
|
|
|
|
|
# its own, and that's not right. |
735
|
|
|
|
|
|
|
|
736
|
7
|
|
|
0
|
|
28
|
return sub { $postback->(@_) } if USING_TK; |
|
0
|
|
|
|
|
0
|
|
737
|
7
|
|
|
|
|
32
|
return $postback; |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
# Create a synchronous callback closure. The return value will be |
741
|
|
|
|
|
|
|
# passed to whatever is handed the callback. |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
sub callback { |
744
|
8
|
|
|
8
|
1
|
22
|
my ($self, $event, @etc) = @_; |
745
|
8
|
|
|
|
|
40
|
my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
my $callback = bless sub { |
748
|
8
|
|
|
8
|
|
444
|
$POE::Kernel::poe_kernel->call( $id, $event, [ @etc ], [ @_ ] ); |
749
|
8
|
|
|
|
|
56
|
}, 'POE::Session::AnonEvent'; |
750
|
|
|
|
|
|
|
|
751
|
8
|
|
|
|
|
26
|
$anonevent_parent_id{$callback} = $id; |
752
|
8
|
|
|
|
|
30
|
$POE::Kernel::poe_kernel->refcount_increment( $id, 'anon_event' ); |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
# Tk blesses its callbacks, so we must present one that isn't |
755
|
|
|
|
|
|
|
# blessed. Otherwise Tk's blessing would divert our DESTROY call to |
756
|
|
|
|
|
|
|
# its own, and that's not right. |
757
|
|
|
|
|
|
|
|
758
|
8
|
|
|
0
|
|
9
|
return sub { $callback->(@_) } if USING_TK; |
|
0
|
|
|
|
|
|
|
759
|
8
|
|
|
|
|
37
|
return $callback; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
1; |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
__END__ |