File Coverage

blib/lib/POE/Kernel.pm
Criterion Covered Total %
statement 691 770 89.7
branch 239 286 83.5
condition 61 96 63.5
subroutine 101 112 90.1
pod 49 49 100.0
total 1141 1313 86.9


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