line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::NFA; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
23020
|
use strict; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
115
|
|
4
|
|
|
|
|
|
|
|
5
|
3
|
|
|
3
|
|
13
|
use vars qw($VERSION); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
203
|
|
6
|
|
|
|
|
|
|
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places) |
7
|
|
|
|
|
|
|
|
8
|
3
|
|
|
3
|
|
15
|
use Carp qw(carp croak); |
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
1087
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
sub SPAWN_INLINES () { 'inline_states' } |
11
|
|
|
|
|
|
|
sub SPAWN_OBJECTS () { 'object_states' } |
12
|
|
|
|
|
|
|
sub SPAWN_PACKAGES () { 'package_states' } |
13
|
|
|
|
|
|
|
sub SPAWN_OPTIONS () { 'options' } |
14
|
|
|
|
|
|
|
sub SPAWN_RUNSTATE () { 'runstate' } |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub OPT_TRACE () { 'trace' } |
17
|
|
|
|
|
|
|
sub OPT_DEBUG () { 'debug' } |
18
|
|
|
|
|
|
|
sub OPT_DEFAULT () { 'default' } |
19
|
|
|
|
|
|
|
sub OPT_IMMEDIATE () { 'immediate' } |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub EN_DEFAULT () { '_default' } |
22
|
|
|
|
|
|
|
sub EN_START () { '_start' } |
23
|
|
|
|
|
|
|
sub EN_STOP () { '_stop' } |
24
|
|
|
|
|
|
|
sub EN_SIGNAL () { '_signal' } |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub NFA_EN_GOTO_STATE () { 'poe_nfa_goto_state' } |
27
|
|
|
|
|
|
|
sub NFA_EN_POP_STATE () { 'poe_nfa_pop_state' } |
28
|
|
|
|
|
|
|
sub NFA_EN_PUSH_STATE () { 'poe_nfa_push_state' } |
29
|
|
|
|
|
|
|
sub NFA_EN_STOP () { 'poe_nfa_stop' } |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub SELF_RUNSTATE () { 0 } |
32
|
|
|
|
|
|
|
sub SELF_OPTIONS () { 1 } |
33
|
|
|
|
|
|
|
sub SELF_STATES () { 2 } |
34
|
|
|
|
|
|
|
sub SELF_ID () { 3 } |
35
|
|
|
|
|
|
|
sub SELF_CURRENT () { 4 } |
36
|
|
|
|
|
|
|
sub SELF_STATE_STACK () { 5 } |
37
|
|
|
|
|
|
|
sub SELF_INTERNALS () { 6 } |
38
|
|
|
|
|
|
|
sub SELF_CURRENT_NAME () { 7 } |
39
|
|
|
|
|
|
|
sub SELF_IS_IN_INTERNAL () { 8 } |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub STACK_STATE () { 0 } |
42
|
|
|
|
|
|
|
sub STACK_EVENT () { 1 } |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Shorthand for defining a trace constant. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _define_trace { |
49
|
3
|
|
|
3
|
|
15
|
no strict 'refs'; |
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
652
|
|
50
|
|
|
|
|
|
|
|
51
|
3
|
|
|
3
|
|
13
|
local $^W = 0; |
52
|
|
|
|
|
|
|
|
53
|
3
|
|
|
|
|
5
|
foreach my $name (@_) { |
54
|
3
|
50
|
|
|
|
6
|
next if defined *{"TRACE_$name"}{CODE}; |
|
3
|
|
|
|
|
21
|
|
55
|
3
|
50
|
|
|
|
4
|
if (defined *{"POE::Kernel::TRACE_$name"}{CODE}) { |
|
3
|
|
|
|
|
18
|
|
56
|
|
|
|
|
|
|
eval( |
57
|
0
|
|
|
|
|
0
|
"sub TRACE_$name () { " . |
58
|
0
|
|
|
|
|
0
|
*{"POE::Kernel::TRACE_$name"}{CODE}->() . |
59
|
|
|
|
|
|
|
"}" |
60
|
|
|
|
|
|
|
); |
61
|
0
|
0
|
|
|
|
0
|
die if $@; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
else { |
64
|
3
|
|
|
|
|
120
|
eval "sub TRACE_$name () { TRACE_DEFAULT }"; |
65
|
3
|
50
|
|
|
|
759
|
die if $@; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
BEGIN { |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# ASSERT_DEFAULT changes the default value for other ASSERT_* |
75
|
|
|
|
|
|
|
# constants. It inherits POE::Kernel's ASSERT_DEFAULT value, if |
76
|
|
|
|
|
|
|
# it's present. |
77
|
|
|
|
|
|
|
|
78
|
3
|
50
|
|
3
|
|
16
|
unless (defined &ASSERT_DEFAULT) { |
79
|
3
|
100
|
|
|
|
11
|
if (defined &POE::Kernel::ASSERT_DEFAULT) { |
80
|
2
|
|
|
|
|
64
|
eval( "sub ASSERT_DEFAULT () { " . &POE::Kernel::ASSERT_DEFAULT . " }" ); |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
else { |
83
|
1
|
|
|
|
|
59
|
eval 'sub ASSERT_DEFAULT () { 0 }'; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
}; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# TRACE_DEFAULT changes the default value for other TRACE_* |
88
|
|
|
|
|
|
|
# constants. It inherits POE::Kernel's TRACE_DEFAULT value, if |
89
|
|
|
|
|
|
|
# it's present. |
90
|
|
|
|
|
|
|
|
91
|
3
|
50
|
|
|
|
13
|
unless (defined &TRACE_DEFAULT) { |
92
|
3
|
100
|
|
|
|
10
|
if (defined &POE::Kernel::TRACE_DEFAULT) { |
93
|
2
|
|
|
|
|
85
|
eval( "sub TRACE_DEFAULT () { " . &POE::Kernel::TRACE_DEFAULT . " }" ); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
else { |
96
|
1
|
|
|
|
|
35
|
eval 'sub TRACE_DEFAULT () { 0 }'; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
}; |
99
|
|
|
|
|
|
|
|
100
|
3
|
|
|
|
|
10
|
_define_trace("DESTROY"); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
104
|
|
|
|
|
|
|
# Export constants into calling packages. This is evil; perhaps |
105
|
|
|
|
|
|
|
# EXPORT_OK instead? The parameters NFA has in common with SESSION |
106
|
|
|
|
|
|
|
# (and other sessions) must be kept at the same offsets as each-other. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub OBJECT () { 0 } |
109
|
|
|
|
|
|
|
sub MACHINE () { 1 } |
110
|
|
|
|
|
|
|
sub KERNEL () { 2 } |
111
|
|
|
|
|
|
|
sub RUNSTATE () { 3 } |
112
|
|
|
|
|
|
|
sub EVENT () { 4 } |
113
|
|
|
|
|
|
|
sub SENDER () { 5 } |
114
|
|
|
|
|
|
|
sub STATE () { 6 } |
115
|
|
|
|
|
|
|
sub CALLER_FILE () { 7 } |
116
|
|
|
|
|
|
|
sub CALLER_LINE () { 8 } |
117
|
|
|
|
|
|
|
sub CALLER_STATE () { 9 } |
118
|
|
|
|
|
|
|
sub ARG0 () { 10 } |
119
|
|
|
|
|
|
|
sub ARG1 () { 11 } |
120
|
|
|
|
|
|
|
sub ARG2 () { 12 } |
121
|
|
|
|
|
|
|
sub ARG3 () { 13 } |
122
|
|
|
|
|
|
|
sub ARG4 () { 14 } |
123
|
|
|
|
|
|
|
sub ARG5 () { 15 } |
124
|
|
|
|
|
|
|
sub ARG6 () { 16 } |
125
|
|
|
|
|
|
|
sub ARG7 () { 17 } |
126
|
|
|
|
|
|
|
sub ARG8 () { 18 } |
127
|
|
|
|
|
|
|
sub ARG9 () { 19 } |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub import { |
130
|
9
|
|
|
9
|
|
871
|
my $package = caller(); |
131
|
3
|
|
|
3
|
|
27
|
no strict 'refs'; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
6738
|
|
132
|
9
|
|
|
|
|
18
|
*{ $package . '::OBJECT' } = \&OBJECT; |
|
9
|
|
|
|
|
36
|
|
133
|
9
|
|
|
|
|
14
|
*{ $package . '::MACHINE' } = \&MACHINE; |
|
9
|
|
|
|
|
24
|
|
134
|
9
|
|
|
|
|
11
|
*{ $package . '::KERNEL' } = \&KERNEL; |
|
9
|
|
|
|
|
21
|
|
135
|
9
|
|
|
|
|
10
|
*{ $package . '::RUNSTATE' } = \&RUNSTATE; |
|
9
|
|
|
|
|
29
|
|
136
|
9
|
|
|
|
|
10
|
*{ $package . '::EVENT' } = \&EVENT; |
|
9
|
|
|
|
|
24
|
|
137
|
9
|
|
|
|
|
10
|
*{ $package . '::SENDER' } = \&SENDER; |
|
9
|
|
|
|
|
19
|
|
138
|
9
|
|
|
|
|
10
|
*{ $package . '::STATE' } = \&STATE; |
|
9
|
|
|
|
|
30
|
|
139
|
9
|
|
|
|
|
12
|
*{ $package . '::ARG0' } = \&ARG0; |
|
9
|
|
|
|
|
23
|
|
140
|
9
|
|
|
|
|
11
|
*{ $package . '::ARG1' } = \&ARG1; |
|
9
|
|
|
|
|
20
|
|
141
|
9
|
|
|
|
|
12
|
*{ $package . '::ARG2' } = \&ARG2; |
|
9
|
|
|
|
|
22
|
|
142
|
9
|
|
|
|
|
8
|
*{ $package . '::ARG3' } = \&ARG3; |
|
9
|
|
|
|
|
25
|
|
143
|
9
|
|
|
|
|
12
|
*{ $package . '::ARG4' } = \&ARG4; |
|
9
|
|
|
|
|
21
|
|
144
|
9
|
|
|
|
|
9
|
*{ $package . '::ARG5' } = \&ARG5; |
|
9
|
|
|
|
|
22
|
|
145
|
9
|
|
|
|
|
8
|
*{ $package . '::ARG6' } = \&ARG6; |
|
9
|
|
|
|
|
18
|
|
146
|
9
|
|
|
|
|
14
|
*{ $package . '::ARG7' } = \&ARG7; |
|
9
|
|
|
|
|
28
|
|
147
|
9
|
|
|
|
|
10
|
*{ $package . '::ARG8' } = \&ARG8; |
|
9
|
|
|
|
|
18
|
|
148
|
9
|
|
|
|
|
10
|
*{ $package . '::ARG9' } = \&ARG9; |
|
9
|
|
|
|
|
4211
|
|
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
152
|
|
|
|
|
|
|
# Spawn a new state machine. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub _add_ref_states { |
155
|
9
|
|
|
9
|
|
12
|
my ($states, $refs) = @_; |
156
|
|
|
|
|
|
|
|
157
|
9
|
|
|
|
|
30
|
foreach my $state (keys %$refs) { |
158
|
9
|
|
|
|
|
15
|
$states->{$state} = {}; |
159
|
|
|
|
|
|
|
|
160
|
9
|
|
|
|
|
13
|
my $data = $refs->{$state}; |
161
|
9
|
100
|
|
|
|
162
|
croak "the data for state '$state' should be an array" unless ( |
162
|
|
|
|
|
|
|
ref $data eq 'ARRAY' |
163
|
|
|
|
|
|
|
); |
164
|
8
|
100
|
|
|
|
161
|
croak "the array for state '$state' has an odd number of elements" if ( |
165
|
|
|
|
|
|
|
@$data & 1 |
166
|
|
|
|
|
|
|
); |
167
|
|
|
|
|
|
|
|
168
|
7
|
|
|
|
|
29
|
while (my ($ref, $events) = splice(@$data, 0, 2)) { |
169
|
7
|
100
|
|
|
|
20
|
if (ref $events eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
170
|
4
|
|
|
|
|
9
|
foreach my $event (@$events) { |
171
|
10
|
|
|
|
|
47
|
$states->{$state}->{$event} = [ $ref, $event ]; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
elsif (ref $events eq 'HASH') { |
175
|
2
|
|
|
|
|
15
|
foreach my $event (keys %$events) { |
176
|
6
|
|
|
|
|
8
|
my $method = $events->{$event}; |
177
|
6
|
|
|
|
|
20
|
$states->{$state}->{$event} = [ $ref, $method ]; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
else { |
181
|
1
|
|
|
|
|
140
|
croak "events with '$ref' for state '$state' " . |
182
|
|
|
|
|
|
|
"need to be a hash or array ref"; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub spawn { |
189
|
18
|
|
|
18
|
1
|
6048
|
my ($type, @params) = @_; |
190
|
18
|
|
|
|
|
28
|
my @args; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# We treat the parameter list strictly as a hash. Rather than dying |
193
|
|
|
|
|
|
|
# here with a Perl error, we'll catch it and blame it on the user. |
194
|
|
|
|
|
|
|
|
195
|
18
|
100
|
|
|
|
239
|
croak "odd number of events/handlers (missing one or the other?)" |
196
|
|
|
|
|
|
|
if @params & 1; |
197
|
17
|
|
|
|
|
49
|
my %params = @params; |
198
|
|
|
|
|
|
|
|
199
|
17
|
100
|
|
|
|
173
|
croak "$type requires a working Kernel" |
200
|
|
|
|
|
|
|
unless defined $POE::Kernel::poe_kernel; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# Options are optional. |
203
|
16
|
|
|
|
|
37
|
my $options = delete $params{+SPAWN_OPTIONS}; |
204
|
16
|
50
|
|
|
|
41
|
$options = { } unless defined $options; |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# States are required. |
207
|
16
|
100
|
66
|
|
|
334
|
croak( |
|
|
|
100
|
|
|
|
|
208
|
|
|
|
|
|
|
"$type constructor requires at least one of the following parameters: " . |
209
|
|
|
|
|
|
|
join (", ", SPAWN_INLINES, SPAWN_OBJECTS, SPAWN_PACKAGES) |
210
|
|
|
|
|
|
|
) unless ( |
211
|
|
|
|
|
|
|
exists $params{+SPAWN_INLINES} or |
212
|
|
|
|
|
|
|
exists $params{+SPAWN_OBJECTS} or |
213
|
|
|
|
|
|
|
exists $params{+SPAWN_PACKAGES} |
214
|
|
|
|
|
|
|
); |
215
|
|
|
|
|
|
|
|
216
|
15
|
|
100
|
|
|
52
|
my $states = delete($params{+SPAWN_INLINES}) || {}; |
217
|
|
|
|
|
|
|
|
218
|
15
|
100
|
|
|
|
46
|
if (exists $params{+SPAWN_OBJECTS}) { |
219
|
2
|
|
|
|
|
4
|
my $objects = delete $params{+SPAWN_OBJECTS}; |
220
|
2
|
|
|
|
|
6
|
_add_ref_states($states, $objects); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
15
|
100
|
|
|
|
40
|
if (exists $params{+SPAWN_PACKAGES}) { |
224
|
7
|
|
|
|
|
15
|
my $packages = delete $params{+SPAWN_PACKAGES}; |
225
|
7
|
|
|
|
|
17
|
_add_ref_states($states, $packages); |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
12
|
|
100
|
|
|
69
|
my $runstate = delete($params{+SPAWN_RUNSTATE}) || {}; |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# These are unknown. |
231
|
12
|
100
|
|
|
|
193
|
croak( |
232
|
|
|
|
|
|
|
"$type constructor does not recognize these parameter names: ", |
233
|
|
|
|
|
|
|
join(', ', sort(keys(%params))) |
234
|
|
|
|
|
|
|
) if keys %params; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Build me. |
237
|
11
|
|
|
|
|
52
|
my $self = bless [ |
238
|
|
|
|
|
|
|
$runstate, # SELF_RUNSTATE |
239
|
|
|
|
|
|
|
$options, # SELF_OPTIONS |
240
|
|
|
|
|
|
|
$states, # SELF_STATES |
241
|
|
|
|
|
|
|
undef, # SELF_ID |
242
|
|
|
|
|
|
|
undef, # SELF_CURRENT |
243
|
|
|
|
|
|
|
[ ], # SELF_STATE_STACK |
244
|
|
|
|
|
|
|
{ }, # SELF_INTERNALS |
245
|
|
|
|
|
|
|
'(undef)', # SELF_CURRENT_NAME |
246
|
|
|
|
|
|
|
0, # SELF_IS_IN_INTERNAL |
247
|
|
|
|
|
|
|
], $type; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# Register the machine with the POE kernel. |
250
|
11
|
|
|
|
|
45
|
$POE::Kernel::poe_kernel->session_alloc($self); |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
# Return it for immediate reuse. |
253
|
11
|
|
|
|
|
53
|
return $self; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
257
|
|
|
|
|
|
|
# Another good inheritance candidate. |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub DESTROY { |
260
|
11
|
|
|
11
|
|
21
|
my $self = shift; |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# NFA's data structures are destroyed through Perl's usual garbage |
263
|
|
|
|
|
|
|
# collection. TRACE_DESTROY here just shows what's in the session |
264
|
|
|
|
|
|
|
# before the destruction finishes. |
265
|
|
|
|
|
|
|
|
266
|
11
|
|
|
|
|
59
|
TRACE_DESTROY and do { |
267
|
|
|
|
|
|
|
POE::Kernel::_warn( |
268
|
|
|
|
|
|
|
"----- NFA $self Leak Check -----\n", |
269
|
|
|
|
|
|
|
"-- Namespace (HEAP):\n" |
270
|
|
|
|
|
|
|
); |
271
|
|
|
|
|
|
|
foreach (sort keys (%{$self->[SELF_RUNSTATE]})) { |
272
|
|
|
|
|
|
|
POE::Kernel::_warn(" $_ = ", $self->[SELF_RUNSTATE]->{$_}, "\n"); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
POE::Kernel::_warn("-- Options:\n"); |
275
|
|
|
|
|
|
|
foreach (sort keys (%{$self->[SELF_OPTIONS]})) { |
276
|
|
|
|
|
|
|
POE::Kernel::_warn(" $_ = ", $self->[SELF_OPTIONS]->{$_}, "\n"); |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
POE::Kernel::_warn("-- States:\n"); |
279
|
|
|
|
|
|
|
foreach (sort keys (%{$self->[SELF_STATES]})) { |
280
|
|
|
|
|
|
|
POE::Kernel::_warn(" $_ = ", $self->[SELF_STATES]->{$_}, "\n"); |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
}; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub _invoke_state { |
288
|
504
|
|
|
496
|
|
843
|
my ($self, $sender, $event, $args, $file, $line, $fromstate) = @_; |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
# Trace the state invocation if tracing is enabled. |
291
|
|
|
|
|
|
|
|
292
|
504
|
50
|
|
|
|
1275
|
if ($self->[SELF_OPTIONS]->{+OPT_TRACE}) { |
293
|
8
|
|
|
|
|
42
|
POE::Kernel::_warn( |
294
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), " -> $event\n" |
295
|
|
|
|
|
|
|
); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# Discard troublesome things. |
299
|
502
|
100
|
|
|
|
1091
|
return if $event eq EN_START; |
300
|
493
|
100
|
|
|
|
1024
|
return if $event eq EN_STOP; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
# Stop request has come through the queue. Shut us down. |
303
|
482
|
100
|
|
|
|
1799
|
if ($event eq NFA_EN_STOP) { |
304
|
10
|
|
|
|
|
41
|
$POE::Kernel::poe_kernel->_data_ses_stop($self->ID); |
305
|
2
|
|
|
|
|
6
|
return; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
# Make a state transition. |
309
|
480
|
100
|
|
|
|
936
|
if ($event eq NFA_EN_GOTO_STATE) { |
310
|
82
|
|
|
|
|
162
|
my ($new_state, $enter_event, @enter_args) = @$args; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# Make sure the new state exists. |
313
|
82
|
50
|
|
|
|
263
|
POE::Kernel::_die( |
314
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
315
|
|
|
|
|
|
|
" tried to enter nonexistent state '$new_state'\n" |
316
|
|
|
|
|
|
|
) |
317
|
|
|
|
|
|
|
unless exists $self->[SELF_STATES]->{$new_state}; |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# If an enter event was specified, make sure that exists too. |
320
|
92
|
50
|
33
|
|
|
607
|
POE::Kernel::_die( |
|
|
|
66
|
|
|
|
|
321
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
322
|
|
|
|
|
|
|
" tried to invoke nonexistent enter event '$enter_event' ", |
323
|
|
|
|
|
|
|
"in state '$new_state'\n" |
324
|
|
|
|
|
|
|
) |
325
|
|
|
|
|
|
|
unless ( |
326
|
|
|
|
|
|
|
not defined $enter_event or |
327
|
|
|
|
|
|
|
( length $enter_event and |
328
|
|
|
|
|
|
|
exists $self->[SELF_STATES]->{$new_state}->{$enter_event} |
329
|
|
|
|
|
|
|
) |
330
|
|
|
|
|
|
|
); |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
# Invoke the current state's leave event, if one exists. |
333
|
74
|
50
|
|
|
|
209
|
$self->_invoke_state( $self, 'leave', [], undef, undef, undef ) |
334
|
|
|
|
|
|
|
if exists $self->[SELF_CURRENT]->{leave}; |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Enter the new state. |
337
|
74
|
|
|
|
|
143
|
$self->[SELF_CURRENT] = $self->[SELF_STATES]->{$new_state}; |
338
|
74
|
|
|
|
|
101
|
$self->[SELF_CURRENT_NAME] = $new_state; |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# Invoke the new state's enter event, if requested. |
341
|
74
|
100
|
|
|
|
297
|
$self->_invoke_state( |
342
|
|
|
|
|
|
|
$self, $enter_event, \@enter_args, undef, undef, undef |
343
|
|
|
|
|
|
|
) if defined $enter_event; |
344
|
|
|
|
|
|
|
|
345
|
74
|
|
|
|
|
190
|
return undef; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
# Push a state transition. |
349
|
398
|
100
|
|
|
|
826
|
if ($event eq NFA_EN_PUSH_STATE) { |
350
|
|
|
|
|
|
|
|
351
|
20
|
|
|
|
|
65
|
my @args = @$args; |
352
|
20
|
|
|
|
|
79
|
push( |
353
|
20
|
|
|
|
|
26
|
@{$self->[SELF_STATE_STACK]}, |
354
|
|
|
|
|
|
|
[ $self->[SELF_CURRENT_NAME], # STACK_STATE |
355
|
|
|
|
|
|
|
shift(@args), # STACK_EVENT |
356
|
|
|
|
|
|
|
] |
357
|
|
|
|
|
|
|
); |
358
|
20
|
|
|
|
|
80
|
$self->_invoke_state( |
359
|
|
|
|
|
|
|
$self, NFA_EN_GOTO_STATE, \@args, undef, undef, undef |
360
|
|
|
|
|
|
|
); |
361
|
|
|
|
|
|
|
|
362
|
20
|
|
|
|
|
65
|
return undef; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# Pop a state transition. |
366
|
378
|
100
|
|
|
|
802
|
if ($event eq NFA_EN_POP_STATE) { |
367
|
|
|
|
|
|
|
|
368
|
20
|
|
|
|
|
78
|
POE::Kernel::_die( |
369
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
370
|
|
|
|
|
|
|
" tried to pop a state from an empty stack\n" |
371
|
|
|
|
|
|
|
) |
372
|
20
|
50
|
|
|
|
32
|
unless @{ $self->[SELF_STATE_STACK] }; |
373
|
|
|
|
|
|
|
|
374
|
20
|
|
|
|
|
61
|
my ($previous_state, $previous_event) = @{ |
375
|
20
|
|
|
|
|
30
|
pop @{ $self->[SELF_STATE_STACK] } |
|
20
|
|
|
|
|
29
|
|
376
|
|
|
|
|
|
|
}; |
377
|
20
|
|
|
|
|
100
|
$self->_invoke_state( |
378
|
|
|
|
|
|
|
$self, NFA_EN_GOTO_STATE, |
379
|
|
|
|
|
|
|
[ $previous_state, $previous_event, @$args ], |
380
|
|
|
|
|
|
|
undef, undef, undef |
381
|
|
|
|
|
|
|
); |
382
|
|
|
|
|
|
|
|
383
|
20
|
|
|
|
|
84
|
return undef; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Stop. |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# Try to find the event handler in the current state or the internal |
389
|
|
|
|
|
|
|
# event handlers used by wheels and the like. |
390
|
358
|
|
|
|
|
455
|
my ( $handler, $is_in_internal ); |
391
|
|
|
|
|
|
|
|
392
|
358
|
100
|
|
|
|
1060
|
if (exists $self->[SELF_CURRENT]->{$event}) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
393
|
352
|
|
|
|
|
655
|
$handler = $self->[SELF_CURRENT]->{$event}; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
elsif (exists $self->[SELF_INTERNALS]->{$event}) { |
397
|
2
|
|
|
|
|
4
|
$handler = $self->[SELF_INTERNALS]->{$event}; |
398
|
2
|
|
|
|
|
7
|
$is_in_internal = ++$self->[SELF_IS_IN_INTERNAL]; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
# If it wasn't found in either of those, then check for _default in |
402
|
|
|
|
|
|
|
# the current state. |
403
|
|
|
|
|
|
|
elsif (exists $self->[SELF_CURRENT]->{+EN_DEFAULT}) { |
404
|
|
|
|
|
|
|
# If we get this far, then there's a _default event to redirect |
405
|
|
|
|
|
|
|
# the event to. Trace the redirection. |
406
|
4
|
50
|
|
|
|
15
|
if ($self->[SELF_OPTIONS]->{+OPT_TRACE}) { |
407
|
0
|
|
|
|
|
0
|
POE::Kernel::_warn( |
408
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
409
|
|
|
|
|
|
|
" -> $event redirected to EN_DEFAULT in state ", |
410
|
|
|
|
|
|
|
"'$self->[SELF_CURRENT_NAME]'\n" |
411
|
|
|
|
|
|
|
); |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
4
|
|
|
|
|
10
|
$handler = $self->[SELF_CURRENT]->{+EN_DEFAULT}; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# Transform the parameters for _default. ARG1 and beyond are |
417
|
|
|
|
|
|
|
# copied so they can't be altered at a distance. |
418
|
4
|
|
|
|
|
12
|
$args = [ $event, [@$args] ]; |
419
|
4
|
|
|
|
|
6
|
$event = EN_DEFAULT; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# No external event handler, no internal event handler, and no |
423
|
|
|
|
|
|
|
# external _default handler. This is a grievous error, and now we |
424
|
|
|
|
|
|
|
# must die. |
425
|
|
|
|
|
|
|
elsif ($event ne EN_SIGNAL) { |
426
|
0
|
|
|
|
|
0
|
POE::Kernel::_die( |
427
|
|
|
|
|
|
|
"a '$event' event was sent from $file at $line to session ", |
428
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), |
429
|
|
|
|
|
|
|
", but session ", $POE::Kernel::poe_kernel->ID_session_to_id($self), |
430
|
|
|
|
|
|
|
" has neither a handler for it nor one for _default ", |
431
|
|
|
|
|
|
|
"in its current state, '$self->[SELF_CURRENT_NAME]'\n" |
432
|
|
|
|
|
|
|
); |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# Inline event handlers are invoked this way. |
436
|
|
|
|
|
|
|
|
437
|
358
|
|
|
|
|
356
|
my $return; |
438
|
358
|
100
|
|
|
|
755
|
if (ref($handler) eq 'CODE') { |
439
|
318
|
|
|
|
|
1506
|
$return = $handler->( |
440
|
|
|
|
|
|
|
undef, # OBJECT |
441
|
|
|
|
|
|
|
$self, # MACHINE |
442
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel, # KERNEL |
443
|
|
|
|
|
|
|
$self->[SELF_RUNSTATE], # RUNSTATE |
444
|
|
|
|
|
|
|
$event, # EVENT |
445
|
|
|
|
|
|
|
$sender, # SENDER |
446
|
|
|
|
|
|
|
$self->[SELF_CURRENT_NAME], # STATE |
447
|
|
|
|
|
|
|
$file, # CALLER_FILE_NAME |
448
|
|
|
|
|
|
|
$line, # CALLER_FILE_LINE |
449
|
|
|
|
|
|
|
$fromstate, # CALLER_STATE |
450
|
|
|
|
|
|
|
@$args # ARG0.. |
451
|
|
|
|
|
|
|
); |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# Package and object handlers are invoked this way. |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
else { |
457
|
40
|
|
|
|
|
97
|
my ($object, $method) = @$handler; |
458
|
40
|
|
|
|
|
250
|
$return = $object->$method( # OBJECT (package, implied) |
459
|
|
|
|
|
|
|
$self, # MACHINE |
460
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel, # KERNEL |
461
|
|
|
|
|
|
|
$self->[SELF_RUNSTATE], # RUNSTATE |
462
|
|
|
|
|
|
|
$event, # EVENT |
463
|
|
|
|
|
|
|
$sender, # SENDER |
464
|
|
|
|
|
|
|
$self->[SELF_CURRENT_NAME], # STATE |
465
|
|
|
|
|
|
|
$file, # CALLER_FILE_NAME |
466
|
|
|
|
|
|
|
$line, # CALLER_FILE_LINE |
467
|
|
|
|
|
|
|
$fromstate, # CALLER_STATE |
468
|
|
|
|
|
|
|
@$args # ARG0.. |
469
|
|
|
|
|
|
|
); |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
358
|
100
|
|
|
|
3096
|
$self->[SELF_IS_IN_INTERNAL]-- if $is_in_internal; |
473
|
|
|
|
|
|
|
|
474
|
358
|
|
|
|
|
860
|
return $return; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
478
|
|
|
|
|
|
|
# Add, remove or replace event handlers in the session. This is going |
479
|
|
|
|
|
|
|
# to be tricky since wheels need this but the event handlers can't be |
480
|
|
|
|
|
|
|
# limited to a single state. I think they'll go in a hidden internal |
481
|
|
|
|
|
|
|
# state, or something. |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
sub _register_state { |
484
|
2
|
|
|
2
|
|
4
|
my ($self, $name, $handler, $method) = @_; |
485
|
2
|
50
|
|
|
|
6
|
$method = $name unless defined $method; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
# Deprecate _signal. |
488
|
2
|
50
|
|
|
|
7
|
if ($name eq EN_SIGNAL) { |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
# Report the problem outside POE. |
491
|
0
|
|
|
|
|
0
|
my $caller_level = 0; |
492
|
0
|
|
|
|
|
0
|
local $Carp::CarpLevel = 1; |
493
|
0
|
|
|
|
|
0
|
while ( (caller $caller_level)[0] =~ /^POE::/ ) { |
494
|
0
|
|
|
|
|
0
|
$caller_level++; |
495
|
0
|
|
|
|
|
0
|
$Carp::CarpLevel++; |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
croak( |
499
|
0
|
|
|
|
|
0
|
",----- DEPRECATION ERROR -----\n", |
500
|
|
|
|
|
|
|
"| The _signal event is deprecated. Please use sig() to register\n", |
501
|
|
|
|
|
|
|
"| an explicit signal handler instead.\n", |
502
|
|
|
|
|
|
|
"`-----------------------------\n", |
503
|
|
|
|
|
|
|
); |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
# There is a handler, so try to define the state. This replaces an |
506
|
|
|
|
|
|
|
# existing state. |
507
|
|
|
|
|
|
|
|
508
|
2
|
50
|
|
|
|
11
|
if ($handler) { |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
# Coderef handlers are inline states. |
511
|
|
|
|
|
|
|
|
512
|
2
|
50
|
|
|
|
7
|
if (ref($handler) eq 'CODE') { |
|
|
0
|
|
|
|
|
|
513
|
2
|
50
|
33
|
|
|
8
|
POE::Kernel::_carp( |
514
|
|
|
|
|
|
|
"redefining handler for event($name) for session(", |
515
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), ")" |
516
|
|
|
|
|
|
|
) |
517
|
|
|
|
|
|
|
if ( |
518
|
|
|
|
|
|
|
$self->[SELF_OPTIONS]->{+OPT_DEBUG} and |
519
|
|
|
|
|
|
|
(exists $self->[SELF_INTERNALS]->{$name}) |
520
|
|
|
|
|
|
|
); |
521
|
2
|
|
|
|
|
7
|
$self->[SELF_INTERNALS]->{$name} = $handler; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
# Non-coderef handlers may be package or object states. See if |
525
|
|
|
|
|
|
|
# the method belongs to the handler. |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
elsif ($handler->can($method)) { |
528
|
0
|
0
|
0
|
|
|
0
|
POE::Kernel::_carp( |
529
|
|
|
|
|
|
|
"redefining handler for event($name) for session(", |
530
|
|
|
|
|
|
|
$POE::Kernel::poe_kernel->ID_session_to_id($self), ")" |
531
|
|
|
|
|
|
|
) |
532
|
|
|
|
|
|
|
if ( |
533
|
|
|
|
|
|
|
$self->[SELF_OPTIONS]->{+OPT_DEBUG} && |
534
|
|
|
|
|
|
|
(exists $self->[SELF_INTERNALS]->{$name}) |
535
|
|
|
|
|
|
|
); |
536
|
0
|
|
|
|
|
0
|
$self->[SELF_INTERNALS]->{$name} = [ $handler, $method ]; |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
# Something's wrong. This code also seems wrong, since |
540
|
|
|
|
|
|
|
# ref($handler) can't be 'CODE'. |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
else { |
543
|
0
|
0
|
0
|
|
|
0
|
if ( |
544
|
|
|
|
|
|
|
(ref($handler) eq 'CODE') and |
545
|
|
|
|
|
|
|
$self->[SELF_OPTIONS]->{+OPT_TRACE} |
546
|
|
|
|
|
|
|
) { |
547
|
0
|
|
|
|
|
0
|
POE::Kernel::_carp( |
548
|
|
|
|
|
|
|
$self->fetch_id(), |
549
|
|
|
|
|
|
|
" : handler for event($name) is not a proper ref - not registered" |
550
|
|
|
|
|
|
|
) |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
else { |
553
|
0
|
0
|
|
|
|
0
|
unless ($handler->can($method)) { |
554
|
0
|
0
|
|
|
|
0
|
if (length ref($handler)) { |
555
|
0
|
|
|
|
|
0
|
croak "object $handler does not have a '$method' method" |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
else { |
558
|
0
|
|
|
|
|
0
|
croak "package $handler does not have a '$method' method"; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# No handler. Delete the state! |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
else { |
568
|
0
|
|
|
|
|
0
|
delete $self->[SELF_INTERNALS]->{$name}; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
573
|
|
|
|
|
|
|
# Return the session's ID. This is a thunk into POE::Kernel, where |
574
|
|
|
|
|
|
|
# the session ID really lies. This is a good inheritance candidate. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
sub _set_id { |
577
|
11
|
|
|
11
|
|
17
|
my ($self, $id) = @_; |
578
|
11
|
|
|
|
|
33
|
$self->[SELF_ID] = $id; |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
sub ID { |
582
|
3101
|
|
|
3101
|
1
|
10496
|
return shift()->[SELF_ID]; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
586
|
|
|
|
|
|
|
# Return the session's current state's name. |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
sub get_current_state { |
589
|
2
|
|
|
2
|
1
|
533
|
my $self = shift; |
590
|
2
|
|
|
|
|
14
|
return $self->[SELF_CURRENT_NAME]; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# Fetch the session's run state. In rare cases, libraries may need to |
596
|
|
|
|
|
|
|
# break encapsulation this way, probably also using |
597
|
|
|
|
|
|
|
# $kernel->get_current_session as an accessory to the crime. |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
sub get_runstate { |
600
|
2
|
|
|
2
|
1
|
6
|
my $self = shift; |
601
|
2
|
|
|
|
|
12
|
return $self->[SELF_RUNSTATE]; |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
605
|
|
|
|
|
|
|
# Set or fetch session options. This is virtually identical to |
606
|
|
|
|
|
|
|
# POE::Session and a good inheritance candidate. |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
sub option { |
609
|
8
|
|
|
8
|
1
|
1419
|
my $self = shift; |
610
|
8
|
|
|
|
|
9
|
my %return_values; |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# Options are set in pairs. |
613
|
|
|
|
|
|
|
|
614
|
8
|
|
|
|
|
20
|
while (@_ >= 2) { |
615
|
4
|
|
|
|
|
10
|
my ($flag, $value) = splice(@_, 0, 2); |
616
|
4
|
|
|
|
|
10
|
$flag = lc($flag); |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# If the value is defined, then set the option. |
619
|
|
|
|
|
|
|
|
620
|
4
|
100
|
|
|
|
10
|
if (defined $value) { |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# Change some handy values into boolean representations. This |
623
|
|
|
|
|
|
|
# clobbers the user's original values for the sake of DWIM-ism. |
624
|
|
|
|
|
|
|
|
625
|
2
|
50
|
|
|
|
6
|
($value = 1) if ($value =~ /^(on|yes|true)$/i); |
626
|
2
|
50
|
|
|
|
20
|
($value = 0) if ($value =~ /^(no|off|false)$/i); |
627
|
|
|
|
|
|
|
|
628
|
2
|
|
|
|
|
6
|
$return_values{$flag} = $self->[SELF_OPTIONS]->{$flag}; |
629
|
2
|
|
|
|
|
7
|
$self->[SELF_OPTIONS]->{$flag} = $value; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
# Remove the option if the value is undefined. |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
else { |
635
|
2
|
|
|
|
|
15
|
$return_values{$flag} = delete $self->[SELF_OPTIONS]->{$flag}; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
# If only one option is left, then there's no value to set, so we |
640
|
|
|
|
|
|
|
# fetch its value. |
641
|
|
|
|
|
|
|
|
642
|
8
|
100
|
|
|
|
18
|
if (@_) { |
643
|
4
|
|
|
|
|
9
|
my $flag = lc(shift); |
644
|
4
|
100
|
|
|
|
16
|
$return_values{$flag} = ( |
645
|
|
|
|
|
|
|
exists($self->[SELF_OPTIONS]->{$flag}) |
646
|
|
|
|
|
|
|
? $self->[SELF_OPTIONS]->{$flag} |
647
|
|
|
|
|
|
|
: undef |
648
|
|
|
|
|
|
|
); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# If only one option was set or fetched, then return it as a scalar. |
652
|
|
|
|
|
|
|
# Otherwise return it as a hash of option names and values. |
653
|
|
|
|
|
|
|
|
654
|
8
|
|
|
|
|
19
|
my @return_keys = keys(%return_values); |
655
|
8
|
50
|
|
|
|
16
|
if (@return_keys == 1) { |
656
|
8
|
|
|
|
|
26
|
return $return_values{$return_keys[0]}; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
else { |
659
|
0
|
|
|
|
|
0
|
return \%return_values; |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
664
|
|
|
|
|
|
|
# This stuff is identical to the stuff in POE::Session. Good |
665
|
|
|
|
|
|
|
# inheritance candidate. |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
# Create an anonymous sub that, when called, posts an event back to a |
668
|
|
|
|
|
|
|
# session. This is highly experimental code to support Tk widgets and |
669
|
|
|
|
|
|
|
# maybe Event callbacks. There's no guarantee that this code works |
670
|
|
|
|
|
|
|
# yet, nor is there one that it'll be here in the next version. |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
# This maps postback references (stringified; blessing, and thus |
673
|
|
|
|
|
|
|
# refcount, removed) to parent session IDs. Members are set when |
674
|
|
|
|
|
|
|
# postbacks are created, and postbacks' DESTROY methods use it to |
675
|
|
|
|
|
|
|
# perform the necessary cleanup when they go away. Thanks to njt for |
676
|
|
|
|
|
|
|
# steering me right on this one. |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
my %postback_parent_id; |
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::NFA::Postback::DESTROY { |
685
|
2
|
|
|
2
|
|
6
|
my $self = shift; |
686
|
2
|
|
|
|
|
9
|
my $parent_id = delete $postback_parent_id{$self}; |
687
|
2
|
|
|
|
|
12
|
$POE::Kernel::poe_kernel->refcount_decrement( $parent_id, 'postback' ); |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# Tune postbacks depending on variations in toolkit behavior. |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
BEGIN { |
693
|
|
|
|
|
|
|
# Tk blesses its callbacks internally, so we need to wrap our |
694
|
|
|
|
|
|
|
# blessed callbacks in unblessed ones. Otherwise our postback's |
695
|
|
|
|
|
|
|
# DESTROY method probably won't be called. |
696
|
3
|
50
|
|
3
|
|
13
|
if (exists $INC{'Tk.pm'}) { |
697
|
0
|
|
|
|
|
0
|
eval 'sub USING_TK () { 1 }'; |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
else { |
700
|
3
|
|
|
|
|
1330
|
eval 'sub USING_TK () { 0 }'; |
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
}; |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
# Create a postback closure, maintaining referential integrity in the |
705
|
|
|
|
|
|
|
# process. The next step is to give it to something that expects to |
706
|
|
|
|
|
|
|
# be handed a callback. |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
sub postback { |
709
|
2
|
|
|
2
|
1
|
6
|
my ($self, $event, @etc) = @_; |
710
|
2
|
|
|
|
|
9
|
my $id = $POE::Kernel::poe_kernel->ID_session_to_id(shift); |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
my $postback = bless sub { |
713
|
2
|
|
|
2
|
|
13
|
$POE::Kernel::poe_kernel->post( $id, $event, [ @etc ], [ @_ ] ); |
714
|
2
|
|
|
|
|
6
|
return 0; |
715
|
2
|
|
|
|
|
28
|
}, 'POE::NFA::Postback'; |
716
|
|
|
|
|
|
|
|
717
|
2
|
|
|
|
|
24
|
$postback_parent_id{$postback} = $id; |
718
|
2
|
|
|
|
|
9
|
$POE::Kernel::poe_kernel->refcount_increment( $id, 'postback' ); |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
# Tk blesses its callbacks, so we must present one that isn't |
721
|
|
|
|
|
|
|
# blessed. Otherwise Tk's blessing would divert our DESTROY call to |
722
|
|
|
|
|
|
|
# its own, and that's not right. |
723
|
|
|
|
|
|
|
|
724
|
2
|
|
|
0
|
|
4
|
return sub { $postback->(@_) } if USING_TK; |
|
0
|
|
|
|
|
0
|
|
725
|
2
|
|
|
|
|
9
|
return $postback; |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
# Create a synchronous callback closure. The return value will be |
729
|
|
|
|
|
|
|
# passed to whatever is handed the callback. |
730
|
|
|
|
|
|
|
# |
731
|
|
|
|
|
|
|
# TODO - Should callbacks hold reference counts like postbacks do? |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
sub callback { |
734
|
2
|
|
|
2
|
1
|
428
|
my ($self, $event, @etc) = @_; |
735
|
2
|
|
|
|
|
18
|
my $id = $POE::Kernel::poe_kernel->ID_session_to_id($self); |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
my $callback = sub { |
738
|
2
|
|
|
2
|
|
36
|
return $POE::Kernel::poe_kernel->call( $id, $event, [ @etc ], [ @_ ] ); |
739
|
2
|
|
|
|
|
14
|
}; |
740
|
|
|
|
|
|
|
|
741
|
2
|
|
|
|
|
25
|
$callback; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
#============================================================================== |
745
|
|
|
|
|
|
|
# New methods. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
sub goto_state { |
748
|
34
|
|
|
34
|
1
|
171
|
my ($self, $new_state, $entry_event, @entry_args) = @_; |
749
|
34
|
100
|
66
|
|
|
178
|
if (defined $self->[SELF_CURRENT] && !$self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { |
750
|
26
|
|
|
|
|
101
|
$POE::Kernel::poe_kernel->post( |
751
|
|
|
|
|
|
|
$self, NFA_EN_GOTO_STATE, |
752
|
|
|
|
|
|
|
$new_state, $entry_event, @entry_args |
753
|
|
|
|
|
|
|
); |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
else { |
756
|
8
|
|
|
|
|
48
|
$POE::Kernel::poe_kernel->call( |
757
|
|
|
|
|
|
|
$self, NFA_EN_GOTO_STATE, |
758
|
|
|
|
|
|
|
$new_state, $entry_event, @entry_args |
759
|
|
|
|
|
|
|
); |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
sub stop { |
764
|
2
|
|
|
2
|
1
|
10
|
my $self = shift; |
765
|
2
|
|
|
|
|
8
|
$POE::Kernel::poe_kernel->post( $self, NFA_EN_STOP ); |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
sub call_state { |
769
|
20
|
|
|
20
|
1
|
208
|
my ($self, $return_event, $new_state, $entry_event, @entry_args) = @_; |
770
|
20
|
50
|
|
|
|
81
|
if ($self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { |
771
|
0
|
|
|
|
|
0
|
$POE::Kernel::poe_kernel->call( |
772
|
|
|
|
|
|
|
$self, NFA_EN_PUSH_STATE, |
773
|
|
|
|
|
|
|
$return_event, |
774
|
|
|
|
|
|
|
$new_state, $entry_event, @entry_args |
775
|
|
|
|
|
|
|
); |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
else { |
778
|
20
|
|
|
|
|
90
|
$POE::Kernel::poe_kernel->post( |
779
|
|
|
|
|
|
|
$self, NFA_EN_PUSH_STATE, |
780
|
|
|
|
|
|
|
$return_event, |
781
|
|
|
|
|
|
|
$new_state, $entry_event, @entry_args |
782
|
|
|
|
|
|
|
); |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
} |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
sub return_state { |
787
|
20
|
|
|
20
|
1
|
288
|
my ($self, @entry_args) = @_; |
788
|
20
|
50
|
|
|
|
67
|
if ($self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) { |
789
|
0
|
|
|
|
|
0
|
$POE::Kernel::poe_kernel->call( $self, NFA_EN_POP_STATE, @entry_args ); |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
else { |
792
|
20
|
|
|
|
|
87
|
$POE::Kernel::poe_kernel->post( $self, NFA_EN_POP_STATE, @entry_args ); |
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
1; |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
__END__ |