File Coverage

blib/lib/POE/Session.pm
Criterion Covered Total %
statement 210 249 84.3
branch 71 120 59.1
condition 5 12 41.6
subroutine 27 30 90.0
pod 8 8 100.0
total 321 419 76.6


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__