File Coverage

blib/lib/POE/NFA.pm
Criterion Covered Total %
statement 212 237 89.4
branch 78 116 67.2
condition 15 28 53.5
subroutine 28 29 96.5
pod 11 11 100.0
total 344 421 81.7


line stmt bran cond sub pod time code
1             package POE::NFA;
2              
3 3     3   15552 use strict;
  3         4  
  3         114  
4              
5 3     3   13 use vars qw($VERSION);
  3         4  
  3         136  
6             $VERSION = '1.365'; # NOTE - Should be #.### (three decimal places)
7              
8 3     3   11 use Carp qw(carp croak);
  3         4  
  3         998  
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   13 no strict 'refs';
  3         3  
  3         551  
50              
51 3     3   10 local $^W = 0;
52              
53 3         6 foreach my $name (@_) {
54 3 50       4 next if defined *{"TRACE_$name"}{CODE};
  3         16  
55 3 50       4 if (defined *{"POE::Kernel::TRACE_$name"}{CODE}) {
  3         12  
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         82 eval "sub TRACE_$name () { TRACE_DEFAULT }";
65 3 50       545 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   20 unless (defined &ASSERT_DEFAULT) {
79 3 100       8 if (defined &POE::Kernel::ASSERT_DEFAULT) {
80 2         89 eval( "sub ASSERT_DEFAULT () { " . &POE::Kernel::ASSERT_DEFAULT . " }" );
81             }
82             else {
83 1         36 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       11 unless (defined &TRACE_DEFAULT) {
92 3 100       9 if (defined &POE::Kernel::TRACE_DEFAULT) {
93 2         49 eval( "sub TRACE_DEFAULT () { " . &POE::Kernel::TRACE_DEFAULT . " }" );
94             }
95             else {
96 1         20 eval 'sub TRACE_DEFAULT () { 0 }';
97             }
98             };
99              
100 3         7 _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   1098 my $package = caller();
131 3     3   21 no strict 'refs';
  3         7  
  3         6013  
132 9         15 *{ $package . '::OBJECT' } = \&OBJECT;
  9         34  
133 9         12 *{ $package . '::MACHINE' } = \&MACHINE;
  9         23  
134 9         10 *{ $package . '::KERNEL' } = \&KERNEL;
  9         25  
135 9         12 *{ $package . '::RUNSTATE' } = \&RUNSTATE;
  9         22  
136 9         13 *{ $package . '::EVENT' } = \&EVENT;
  9         22  
137 9         11 *{ $package . '::SENDER' } = \&SENDER;
  9         21  
138 9         10 *{ $package . '::STATE' } = \&STATE;
  9         23  
139 9         13 *{ $package . '::ARG0' } = \&ARG0;
  9         23  
140 9         10 *{ $package . '::ARG1' } = \&ARG1;
  9         23  
141 9         10 *{ $package . '::ARG2' } = \&ARG2;
  9         21  
142 9         9 *{ $package . '::ARG3' } = \&ARG3;
  9         25  
143 9         13 *{ $package . '::ARG4' } = \&ARG4;
  9         25  
144 9         10 *{ $package . '::ARG5' } = \&ARG5;
  9         23  
145 9         12 *{ $package . '::ARG6' } = \&ARG6;
  9         24  
146 9         10 *{ $package . '::ARG7' } = \&ARG7;
  9         24  
147 9         12 *{ $package . '::ARG8' } = \&ARG8;
  9         18  
148 9         13 *{ $package . '::ARG9' } = \&ARG9;
  9         3669  
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         21 foreach my $state (keys %$refs) {
158 9         17 $states->{$state} = {};
159              
160 9         12 my $data = $refs->{$state};
161 9 100       145 croak "the data for state '$state' should be an array" unless (
162             ref $data eq 'ARRAY'
163             );
164 8 100       107 croak "the array for state '$state' has an odd number of elements" if (
165             @$data & 1
166             );
167              
168 7         25 while (my ($ref, $events) = splice(@$data, 0, 2)) {
169 7 100       22 if (ref $events eq 'ARRAY') {
    100          
170 4         7 foreach my $event (@$events) {
171 10         43 $states->{$state}->{$event} = [ $ref, $event ];
172             }
173             }
174             elsif (ref $events eq 'HASH') {
175 2         6 foreach my $event (keys %$events) {
176 6         6 my $method = $events->{$event};
177 6         18 $states->{$state}->{$event} = [ $ref, $method ];
178             }
179             }
180             else {
181 1         137 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 4207 my ($type, @params) = @_;
190 18         23 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       233 croak "odd number of events/handlers (missing one or the other?)"
196             if @params & 1;
197 17         46 my %params = @params;
198              
199 17 100       139 croak "$type requires a working Kernel"
200             unless defined $POE::Kernel::poe_kernel;
201              
202             # Options are optional.
203 16         32 my $options = delete $params{+SPAWN_OPTIONS};
204 16 50       43 $options = { } unless defined $options;
205              
206             # States are required.
207 16 100 66     235 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     40 my $states = delete($params{+SPAWN_INLINES}) || {};
217              
218 15 100       37 if (exists $params{+SPAWN_OBJECTS}) {
219 2         3 my $objects = delete $params{+SPAWN_OBJECTS};
220 2         5 _add_ref_states($states, $objects);
221             }
222              
223 15 100       31 if (exists $params{+SPAWN_PACKAGES}) {
224 7         13 my $packages = delete $params{+SPAWN_PACKAGES};
225 7         12 _add_ref_states($states, $packages);
226             }
227              
228 12   100     72 my $runstate = delete($params{+SPAWN_RUNSTATE}) || {};
229              
230             # These are unknown.
231 12 100       139 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         55 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         63 return $self;
254             }
255              
256             #------------------------------------------------------------------------------
257             # Another good inheritance candidate.
258              
259             sub DESTROY {
260 11     11   17 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         42 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   965 my ($self, $sender, $event, $args, $file, $line, $fromstate) = @_;
289              
290             # Trace the state invocation if tracing is enabled.
291              
292 504 50       1135 if ($self->[SELF_OPTIONS]->{+OPT_TRACE}) {
293 8         46 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       921 return if $event eq EN_START;
300 493 100       854 return if $event eq EN_STOP;
301              
302             # Stop request has come through the queue. Shut us down.
303 482 100       849 if ($event eq NFA_EN_STOP) {
304 10         50 $POE::Kernel::poe_kernel->_data_ses_stop($self->ID);
305 2         9 return;
306             }
307              
308             # Make a state transition.
309 480 100       856 if ($event eq NFA_EN_GOTO_STATE) {
310 82         177 my ($new_state, $enter_event, @enter_args) = @$args;
311              
312             # Make sure the new state exists.
313 82 50       296 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     644 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       222 $self->_invoke_state( $self, 'leave', [], undef, undef, undef )
334             if exists $self->[SELF_CURRENT]->{leave};
335              
336             # Enter the new state.
337 74         155 $self->[SELF_CURRENT] = $self->[SELF_STATES]->{$new_state};
338 74         128 $self->[SELF_CURRENT_NAME] = $new_state;
339              
340             # Invoke the new state's enter event, if requested.
341 74 100       317 $self->_invoke_state(
342             $self, $enter_event, \@enter_args, undef, undef, undef
343             ) if defined $enter_event;
344              
345 74         211 return undef;
346             }
347              
348             # Push a state transition.
349 398 100       731 if ($event eq NFA_EN_PUSH_STATE) {
350              
351 20         78 my @args = @$args;
352 20         85 push(
353 20         27 @{$self->[SELF_STATE_STACK]},
354             [ $self->[SELF_CURRENT_NAME], # STACK_STATE
355             shift(@args), # STACK_EVENT
356             ]
357             );
358 20         96 $self->_invoke_state(
359             $self, NFA_EN_GOTO_STATE, \@args, undef, undef, undef
360             );
361              
362 20         66 return undef;
363             }
364              
365             # Pop a state transition.
366 378 100       604 if ($event eq NFA_EN_POP_STATE) {
367              
368 20         82 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       37 unless @{ $self->[SELF_STATE_STACK] };
373              
374 20         73 my ($previous_state, $previous_event) = @{
375 20         37 pop @{ $self->[SELF_STATE_STACK] }
  20         26  
376             };
377 20         128 $self->_invoke_state(
378             $self, NFA_EN_GOTO_STATE,
379             [ $previous_state, $previous_event, @$args ],
380             undef, undef, undef
381             );
382              
383 20         83 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         364 my ( $handler, $is_in_internal );
391              
392 358 100       1063 if (exists $self->[SELF_CURRENT]->{$event}) {
    100          
    50          
    0          
393 352         552 $handler = $self->[SELF_CURRENT]->{$event};
394             }
395              
396             elsif (exists $self->[SELF_INTERNALS]->{$event}) {
397 2         5 $handler = $self->[SELF_INTERNALS]->{$event};
398 2         5 $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       18 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         9 $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         16 $args = [ $event, [@$args] ];
419 4         11 $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         374 my $return;
438 358 100       699 if (ref($handler) eq 'CODE') {
439 318         1097 $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         92 my ($object, $method) = @$handler;
458 40         294 $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       3609 $self->[SELF_IS_IN_INTERNAL]-- if $is_in_internal;
473              
474 358         813 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   5 my ($self, $name, $handler, $method) = @_;
485 2 50       7 $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       7 if ($handler) {
509              
510             # Coderef handlers are inline states.
511              
512 2 50       6 if (ref($handler) eq 'CODE') {
    0          
513 2 50 33     10 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         8 $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   19 my ($self, $id) = @_;
578 11         29 $self->[SELF_ID] = $id;
579             }
580              
581             sub ID {
582 3101     3101 1 10093 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 932 my $self = shift;
590 2         13 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 5 my $self = shift;
601 2         13 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 1872 my $self = shift;
610 8         8 my %return_values;
611              
612             # Options are set in pairs.
613              
614 8         22 while (@_ >= 2) {
615 4         11 my ($flag, $value) = splice(@_, 0, 2);
616 4         7 $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       5 ($value = 0) if ($value =~ /^(no|off|false)$/i);
627              
628 2         7 $return_values{$flag} = $self->[SELF_OPTIONS]->{$flag};
629 2         6 $self->[SELF_OPTIONS]->{$flag} = $value;
630             }
631              
632             # Remove the option if the value is undefined.
633              
634             else {
635 2         12 $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       17 if (@_) {
643 4         11 my $flag = lc(shift);
644 4 100       22 $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       27 if (@return_keys == 1) {
656 8         30 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   5 my $self = shift;
686 2         7 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         1206 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         7 my $id = $POE::Kernel::poe_kernel->ID_session_to_id(shift);
711              
712             my $postback = bless sub {
713 2     2   11 $POE::Kernel::poe_kernel->post( $id, $event, [ @etc ], [ @_ ] );
714 2         4 return 0;
715 2         16 }, 'POE::NFA::Postback';
716              
717 2         16 $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   2 return sub { $postback->(@_) } if USING_TK;
  0         0  
725 2         8 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 755 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   28 return $POE::Kernel::poe_kernel->call( $id, $event, [ @etc ], [ @_ ] );
739 2         13 };
740              
741 2         7 $callback;
742             }
743              
744             #==============================================================================
745             # New methods.
746              
747             sub goto_state {
748 34     34 1 197 my ($self, $new_state, $entry_event, @entry_args) = @_;
749 34 100 66     200 if (defined $self->[SELF_CURRENT] && !$self->[SELF_OPTIONS]->{+OPT_IMMEDIATE}) {
750 26         105 $POE::Kernel::poe_kernel->post(
751             $self, NFA_EN_GOTO_STATE,
752             $new_state, $entry_event, @entry_args
753             );
754             }
755             else {
756 8         57 $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 11 my $self = shift;
765 2         9 $POE::Kernel::poe_kernel->post( $self, NFA_EN_STOP );
766             }
767              
768             sub call_state {
769 20     20 1 203 my ($self, $return_event, $new_state, $entry_event, @entry_args) = @_;
770 20 50       74 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         77 $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 261 my ($self, @entry_args) = @_;
788 20 50       66 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         74 $POE::Kernel::poe_kernel->post( $self, NFA_EN_POP_STATE, @entry_args );
793             }
794             }
795              
796             1;
797              
798             __END__