1# The data necessary to manage signals, and the accessors to get at 2# that data in a sane fashion. 3 4package POE::Resource::Signals; 5 6use vars qw($VERSION); 7$VERSION = '1.368'; # NOTE - Should be #.### (three decimal places) 8 9# These methods are folded into POE::Kernel; 10package POE::Kernel; 11 12use strict; 13 14use POE::Pipe::OneWay; 15use POE::Resource::FileHandles; 16use POSIX qw(:sys_wait_h sigprocmask SIG_SETMASK); 17 18### Map watched signal names to the sessions that are watching them 19### and the events that must be delivered when they occur. 20 21sub SEV_EVENT () { 0 } 22sub SEV_ARGS () { 1 } 23sub SEV_SESSION () { 2 } 24 25my %kr_signals; 26# ( $signal_name => 27# { $session_id => 28# [ $event_name, SEV_EVENT 29# $event_args, SEV_ARGS 30# $session_ref, SEV_SESSION 31# ], 32# ..., 33# }, 34# ..., 35# ); 36 37my %kr_sessions_to_signals; 38# ( $session_id => 39# { $signal_name => 40# [ $event_name, SEV_EVENT 41# $event_args, SEV_ARGS 42# $session_ref, SEV_SESSION 43# ], 44# ..., 45# }, 46# ..., 47# ); 48 49my %kr_pids_to_events; 50# { $pid => 51# { $session_id => 52# [ $blessed_session, # PID_SESSION 53# $event_name, # PID_EVENT 54# $args, # PID_ARGS 55# ] 56# } 57# } 58 59my %kr_sessions_to_pids; 60# { $session_id => { $pid => 1 } } 61 62sub PID_SESSION () { 0 } 63sub PID_EVENT () { 1 } 64sub PID_ARGS () { 2 } 65 66sub _data_sig_relocate_kernel_id { 67 my ($self, $old_id, $new_id) = @_; 68 69 while (my ($signal, $sig_rec) = each %kr_signals) { 70 next unless exists $sig_rec->{$old_id}; 71 $sig_rec->{$new_id} = delete $sig_rec->{$old_id}; 72 } 73 74 $kr_sessions_to_signals{$new_id} = delete $kr_sessions_to_signals{$old_id} 75 if exists $kr_sessions_to_signals{$old_id}; 76 77 while (my ($pid, $pid_rec) = each %kr_pids_to_events) { 78 next unless exists $pid_rec->{$old_id}; 79 $pid_rec->{$new_id} = delete $pid_rec->{$old_id}; 80 } 81 82 $kr_sessions_to_pids{$new_id} = delete $kr_sessions_to_pids{$old_id} 83 if exists $kr_sessions_to_pids{$old_id}; 84} 85 86# Bookkeeping per dispatched signal. 87 88# TODO - Why not lexicals? 89use vars ( 90 '@kr_signaled_sessions', # The sessions touched by a signal. 91 '$kr_signal_total_handled', # How many sessions handled a signal. 92 '$kr_signal_type', # The type of signal being dispatched. 93); 94 95#my @kr_signaled_sessions; # The sessions touched by a signal. 96#my $kr_signal_total_handled; # How many sessions handled a signal. 97#my $kr_signal_type; # The type of signal being dispatched. 98 99# A flag to tell whether we're currently polling for signals. 100# Under USE_SIGCHLD, determines whether a SIGCHLD polling event has 101# already been queued. 102my $polling_for_signals = 0; 103 104# There may be latent subprocesses in some environments. 105# Or we may need to "always loop once" if we're polling for SIGCHLD. 106# This constant lets us define those exceptional cases. 107# We had some in the past, but as of 2013-10-06 we seem to have 108# eliminated those special cases. 109use constant BASE_SIGCHLD_COUNT => 0; 110 111my $kr_has_child_procs = BASE_SIGCHLD_COUNT; 112 113# A list of special signal types. Signals that aren't listed here are 114# benign (they do not kill sessions at all). "Terminal" signals are 115# the ones that UNIX defaults to killing processes with. Thus STOP is 116# not terminal. 117 118sub SIGTYPE_BENIGN () { 0x00 } 119sub SIGTYPE_TERMINAL () { 0x01 } 120sub SIGTYPE_NONMASKABLE () { 0x02 } 121 122my %_signal_types = ( 123 QUIT => SIGTYPE_TERMINAL, 124 INT => SIGTYPE_TERMINAL, 125 KILL => SIGTYPE_TERMINAL, 126 TERM => SIGTYPE_TERMINAL, 127 HUP => SIGTYPE_TERMINAL, 128 IDLE => SIGTYPE_TERMINAL, 129 DIE => SIGTYPE_TERMINAL, 130 ZOMBIE => SIGTYPE_NONMASKABLE, 131 UIDESTROY => SIGTYPE_NONMASKABLE, 132); 133 134# Build a list of useful, real signals. Nonexistent signals, and ones 135# which are globally unhandled, usually cause segmentation faults if 136# perl was poorly configured. Some signals aren't available in some 137# environments. 138 139my %_safe_signals; 140 141sub _data_sig_initialize { 142 my $self = shift; 143 144 $self->_data_sig_reset_procs; 145 146 $poe_kernel->[KR_SIGNALS] = \%kr_signals; 147 $poe_kernel->[KR_PIDS] = \%kr_pids_to_events; 148 149 # In case we're called multiple times. 150 unless (keys %_safe_signals) { 151 foreach my $signal (keys %SIG) { 152 153 # Nonexistent signals, and ones which are globally unhandled. 154 next if ( 155 $signal =~ /^ 156 ( NUM\d+ 157 |__[A-Z0-9]+__ 158 |ALL|CATCHALL|DEFER|HOLD|IGNORE|MAX|PAUSE 159 |RTMIN|RTMAX|SETS 160 |SEGV 161 | 162 ) 163 $/x 164 ); 165 166 # Windows doesn't have a SIGBUS, but the debugger causes SIGBUS 167 # to be entered into %SIG. It's fatal to register its handler. 168 next if $signal eq 'BUS' and RUNNING_IN_HELL; 169 170 # Apache uses SIGCHLD and/or SIGCLD itself, so we can't. 171 next if $signal =~ /^CH?LD$/ and exists $INC{'Apache.pm'}; 172 173 $_safe_signals{$signal} = 1; 174 } 175 176 # Reset some important signal handlers. The rest remain 177 # untouched. 178 179 $self->loop_ignore_signal("CHLD") if exists $SIG{CHLD}; 180 $self->loop_ignore_signal("CLD") if exists $SIG{CLD}; 181 $self->loop_ignore_signal("PIPE") if exists $SIG{PIPE}; 182 183 $self->_data_sig_pipe_build if USE_SIGNAL_PIPE; 184 } 185} 186 187sub _data_sig_has_forked { 188 my( $self ) = @_; 189 $self->_data_sig_reset_procs; 190 if( USE_SIGNAL_PIPE ) { 191 $self->_data_sig_mask_all; 192 $self->_data_sig_pipe_finalize; 193 $self->_data_sig_pipe_build; 194 $self->_data_sig_unmask_all; 195 } 196} 197 198sub _data_sig_reset_procs { 199 my $self = shift; 200 # Initialize this to a true value so our waitpid() loop can run at 201 # least once. Starts false when running in an Apache handler so our 202 # SIGCHLD hijinks don't interfere with the web server. 203 $self->_data_sig_cease_polling(); 204 $kr_has_child_procs = BASE_SIGCHLD_COUNT; 205} 206 207 208### Return signals that are safe to manipulate. 209 210sub _data_sig_get_safe_signals { 211 return keys %_safe_signals; 212} 213 214### End-run leak checking. 215our $finalizing; 216 217sub _data_sig_finalize { 218 my( $self ) = @_; 219 my $finalized_ok = 1; 220 # tell _data_sig_pipe_send to ignore CHLD that waitpid might provoke 221 local $finalizing = 1; 222 223 $self->_data_sig_pipe_finalize; 224 225 while (my ($sig, $sig_rec) = each(%kr_signals)) { 226 $finalized_ok = 0; 227 _warn "!!! Leaked signal $sig\n"; 228 while (my ($sid, $ses_rec) = each(%{$kr_signals{$sig}})) { 229 my ($event, $args, $session) = @$ses_rec; 230 _warn "!!!\t$sid = $session -> $event (@$args)\n"; 231 } 232 } 233 234 while (my ($sid, $ses_rec) = each(%kr_sessions_to_signals)) { 235 $finalized_ok = 0; 236 _warn "!!! Leaked signal cross-reference: $sid\n"; 237 while (my ($sig, $sig_rec) = each(%{$kr_signals{$sid}})) { 238 my ($event, $args) = @$sig_rec; 239 _warn "!!!\t$sig = $event (@$args)\n"; 240 } 241 } 242 243 while (my ($sid, $pid_rec) = each(%kr_sessions_to_pids)) { 244 $finalized_ok = 0; 245 my @pids = keys %$pid_rec; 246 _warn "!!! Leaked session to PID map: $sid -> (@pids)\n"; 247 } 248 249 while (my ($pid, $ses_rec) = each(%kr_pids_to_events)) { 250 $finalized_ok = 0; 251 _warn "!!! Leaked PID to event map: $pid\n"; 252 while (my ($sid, $ev_rec, $ses) = each %$ses_rec) { 253 _warn "!!!\t$ses -> $ev_rec->[PID_EVENT] (@{$ev_rec->[PID_ARGS]})\n"; 254 } 255 } 256 257 if ($kr_has_child_procs) { 258 _warn "!!! Kernel has $kr_has_child_procs child process(es).\n"; 259 } 260 261 if ($polling_for_signals) { 262 _warn "!!! Finalizing signals while polling is active.\n"; 263 } 264 265 if (USE_SIGNAL_PIPE and $self->_data_sig_pipe_has_signals()) { 266 _warn "!!! Finalizing signals while signal pipe contains messages.\n"; 267 } 268 269 if (exists $kr_signals{CHLD}) { 270 _warn "!!! Finalizing signals while a blanket _child signal is watched.\n"; 271 } 272 273 %_safe_signals = (); 274 275 unless (RUNNING_IN_HELL) { 276 local $!; 277 local $?; 278 279 my $leaked_children = 0; 280 281 PROCESS: until ((my $pid = waitpid( -1, WNOHANG )) == -1) { 282 $finalized_ok = 0; 283 $leaked_children++; 284 285 if ($pid == 0) { 286 _warn( 287 "!!! At least one child process is still running " . 288 "when POE::Kernel->run() is ready to return.\n" 289 ); 290 last PROCESS; 291 } 292 293 _warn( 294 "!!! Stopped child process (PID $pid) reaped " . 295 "when POE::Kernel->run() is ready to return.\n" 296 ); 297 } 298 299 if ($leaked_children) { 300 _warn("!!! Be sure to use sig_child() to reap child processes.\n"); 301 _warn("!!! In extreme cases, failure to reap child processes has\n"); 302 _warn("!!! resulted in a slow 'fork bomb' that has halted systems.\n"); 303 } 304 } 305 306 return $finalized_ok; 307} 308 309### Add a signal to a session. 310 311sub _data_sig_add { 312 my ($self, $session, $signal, $event, $args) = @_; 313 314 my $sid = $session->ID; 315 $kr_sessions_to_signals{$sid}->{$signal} = [ $event, $args || [], $session ]; 316 $self->_data_sig_signal_watch($sid, $signal); 317 $kr_signals{$signal}->{$sid} = [ $event, $args || [], $session ]; 318} 319 320sub _data_sig_signal_watch { 321 my ($self, $sid, $signal) = @_; 322 323 # TODO - $sid not used? 324 325 # First session to watch the signal. 326 # Ask the event loop to watch the signal. 327 if ( 328 !exists($kr_signals{$signal}) and 329 exists($_safe_signals{$signal}) and 330 ($signal ne "CHLD" or !scalar(keys %kr_sessions_to_pids)) 331 ) { 332 $self->loop_watch_signal($signal); 333 } 334} 335 336sub _data_sig_signal_ignore { 337 my ($self, $sid, $signal) = @_; 338 339 # TODO - $sid not used? 340 341 if ( 342 !exists($kr_signals{$signal}) and 343 exists($_safe_signals{$signal}) and 344 ($signal ne "CHLD" or !scalar(keys %kr_sessions_to_pids)) 345 ) { 346 $self->loop_ignore_signal($signal); 347 } 348} 349 350### Remove a signal from a session. 351 352sub _data_sig_remove { 353 my ($self, $sid, $signal) = @_; 354 355 delete $kr_sessions_to_signals{$sid}->{$signal}; 356 delete $kr_sessions_to_signals{$sid} 357 unless keys(%{$kr_sessions_to_signals{$sid}}); 358 359 delete $kr_signals{$signal}->{$sid}; 360 361 # Last watcher for that signal. Stop watching it internally. 362 unless (keys %{$kr_signals{$signal}}) { 363 delete $kr_signals{$signal}; 364 $self->_data_sig_signal_ignore($sid, $signal); 365 } 366} 367 368### Clear all the signals from a session. 369 370# XXX - It's ok to clear signals from a session that doesn't exist. 371# Usually it means that the signals are being cleared, but it might 372# mean that the session really doesn't exist. Should we care? 373 374sub _data_sig_clear_session { 375 my ($self, $sid) = @_; 376 377 if (exists $kr_sessions_to_signals{$sid}) { # avoid autoviv 378 foreach (keys %{$kr_sessions_to_signals{$sid}}) { 379 $self->_data_sig_remove($sid, $_); 380 } 381 } 382 383 if (exists $kr_sessions_to_pids{$sid}) { # avoid autoviv 384 foreach (keys %{$kr_sessions_to_pids{$sid}}) { 385 $self->_data_sig_pid_ignore($sid, $_); 386 } 387 } 388} 389 390### Watch and ignore PIDs. 391 392sub _data_sig_pid_watch { 393 my ($self, $session, $pid, $event, $args) = @_; 394 395 my $sid = $session->ID; 396 397 $kr_pids_to_events{$pid}{$sid} = [ 398 $session, # PID_SESSION 399 $event, # PID_EVENT 400 $args, # PID_ARGS 401 ]; 402 403 $self->_data_sig_signal_watch($sid, "CHLD"); 404 405 $kr_sessions_to_pids{$sid}{$pid} = 1; 406 $self->_data_ses_refcount_inc($sid); 407 408 # Assume there's a child process. This will be corrected on the 409 # next polling interval. 410 $kr_has_child_procs++ unless USE_SIGCHLD; 411} 412 413sub _data_sig_pid_ignore { 414 my ($self, $sid, $pid) = @_; 415 416 # Remove PID to event mapping. 417 418 delete $kr_pids_to_events{$pid}{$sid}; 419 delete $kr_pids_to_events{$pid} unless ( 420 keys %{$kr_pids_to_events{$pid}} 421 ); 422 423 # Remove session to PID mapping. 424 425 delete $kr_sessions_to_pids{$sid}{$pid}; 426 unless (keys %{$kr_sessions_to_pids{$sid}}) { 427 delete $kr_sessions_to_pids{$sid}; 428 $self->_data_sig_signal_ignore($sid, "CHLD"); 429 } 430 431 $self->_data_ses_refcount_dec($sid); 432} 433 434sub _data_sig_session_awaits_pids { 435 my ($self, $sid) = @_; 436 437 # There must be child processes or pending signals. 438 # Watching PIDs doesn't matter if there are none to be reaped. 439 return 0 unless $kr_has_child_procs or $self->_data_sig_pipe_has_signals(); 440 441 # This session is watching at least one PID with sig_child(). 442 # TODO - Watching a non-existent PID is legal but ill-advised. 443 return 1 if exists $kr_sessions_to_pids{$sid}; 444 445 # Is the session waiting for a blanket sig(CHLD)? 446 return( 447 (exists $kr_sessions_to_signals{$sid}) && 448 (exists $kr_sessions_to_signals{$sid}{CHLD}) 449 ); 450} 451 452sub _data_sig_pids_is_ses_watching { 453 my ($self, $sid, $pid) = @_; 454 return( 455 exists($kr_sessions_to_pids{$sid}) && 456 exists($kr_sessions_to_pids{$sid}{$pid}) 457 ); 458} 459 460### Return a signal's type, or SIGTYPE_BENIGN if it's not special. 461 462sub _data_sig_type { 463 my ($self, $signal) = @_; 464 return $_signal_types{$signal} || SIGTYPE_BENIGN; 465} 466 467### Flag a signal as being handled by some session. 468 469sub _data_sig_handled { 470 my $self = shift; 471 $kr_signal_total_handled++; 472} 473 474### Clear the structures associated with a signal's "handled" status. 475 476sub _data_sig_reset_handled { 477 my ($self, $signal) = @_; 478 undef $kr_signal_total_handled; 479 $kr_signal_type = $self->_data_sig_type($signal); 480 undef @kr_signaled_sessions; 481} 482 483### Is the signal explicitly watched? 484 485sub _data_sig_explicitly_watched { 486 my ($self, $signal) = @_; 487 return exists $kr_signals{$signal}; 488} 489 490### Return the signals watched by a session and the events they 491### generate. TODO Used mainly for testing, but may also be useful 492### for introspection. 493 494sub _data_sig_watched_by_session { 495 my ($self, $sid) = @_; 496 return unless exists $kr_sessions_to_signals{$sid}; 497 return %{$kr_sessions_to_signals{$sid}}; 498} 499 500### Which sessions are watching a signal? 501 502sub _data_sig_watchers { 503 my ($self, $signal) = @_; 504 return %{$kr_signals{$signal}}; 505} 506 507### Return the current signal's handled status. 508### TODO Used for testing. 509 510sub _data_sig_handled_status { 511 return( 512 $kr_signal_total_handled, 513 $kr_signal_type, 514 \@kr_signaled_sessions, 515 ); 516} 517 518### Determine if a given session is watching a signal. This uses a 519### two-step exists so that the longer one does not autovivify keys in 520### the shorter one. 521 522sub _data_sig_is_watched_by_session { 523 my ($self, $signal, $sid) = @_; 524 return( 525 exists($kr_signals{$signal}) && 526 exists($kr_signals{$signal}->{$sid}) 527 ); 528} 529 530### Destroy sessions touched by a nonmaskable signal or by an 531### unhandled terminal signal. Check for garbage-collection on 532### sessions which aren't to be terminated. 533 534sub _data_sig_free_terminated_sessions { 535 my $self = shift; 536 537 if ( 538 ($kr_signal_type & SIGTYPE_NONMASKABLE) or 539 ($kr_signal_type & SIGTYPE_TERMINAL and !$kr_signal_total_handled) 540 ) { 541 foreach my $dead_session (@kr_signaled_sessions) { 542 next unless $self->_data_ses_exists($dead_session->ID); 543 544 if (TRACE_SIGNALS) { 545 _warn( 546 "<sg> stopping signaled session ", 547 $self->_data_alias_loggable($dead_session->ID) 548 ); 549 } 550 551 $self->_data_ses_stop($dead_session->ID); 552 } 553 } 554 555 # Erase @kr_signaled_sessions, or they will leak until the next 556 # signal. 557 @kr_signaled_sessions = (); 558} 559 560### A signal has touched a session. Record this fact for later 561### destruction tests. 562 563sub _data_sig_touched_session { 564 my ($self, $session) = @_; 565 push @kr_signaled_sessions, $session; 566} 567 568# only used under !USE_SIGCHLD 569sub _data_sig_begin_polling { 570 my ($self, $signal) = @_; 571 572 return if $polling_for_signals; 573 $polling_for_signals = 1; 574 575 $self->_data_sig_enqueue_poll_event($signal); 576 $self->_idle_queue_grow(); 577} 578 579# only used under !USE_SIGCHLD 580sub _data_sig_cease_polling { 581 $polling_for_signals = 0; 582} 583 584sub _data_sig_enqueue_poll_event { 585 my ($self, $signal) = @_; 586 587 if ( USE_SIGCHLD ) { 588 return if $polling_for_signals; 589 $polling_for_signals = 1; 590 591 $self->_data_ev_enqueue( 592 $self, $self, EN_SCPOLL, ET_SCPOLL, [ $signal ], 593 __FILE__, __LINE__, undef 594 ); 595 } else { 596 return if $self->_data_ses_count() < 1; 597 return unless $polling_for_signals; 598 599 $self->_data_ev_enqueue( 600 $self, $self, EN_SCPOLL, ET_SCPOLL, [ $signal ], 601 __FILE__, __LINE__, undef, walltime(), POE::Kernel::CHILD_POLLING_INTERVAL(), 602 ); 603 } 604} 605 606sub _data_sig_handle_poll_event { 607 my ($self, $signal) = @_; 608 609 if ( USE_SIGCHLD ) { 610 $polling_for_signals = undef; 611 } 612 613 if (TRACE_SIGNALS) { 614 _warn( 615 "<sg> POE::Kernel is polling for signals at " . monotime() . 616 (USE_SIGCHLD ? " due to SIGCHLD" : "") 617 ); 618 } 619 620 $self->_data_sig_reap_pids(); 621 622 # The poll loop is over. Resume slowly polling for signals. 623 624 if (USE_SIGCHLD) { 625 if (TRACE_SIGNALS) { 626 _warn("<sg> POE::Kernel has reset the SIG$signal handler"); 627 } 628 # Per https://rt.cpan.org/Ticket/Display.html?id=45109 setting the 629 # signal handler must be done after reaping the outstanding child 630 # processes, at least on SysV systems like HP-UX. 631 $SIG{$signal} = \&_loop_signal_handler_chld; 632 } 633 else { 634 # The poll loop is over. Resume slowly polling for signals. 635 636 if ($polling_for_signals) { 637 if (TRACE_SIGNALS) { 638 _warn("<sg> POE::Kernel will poll again after a delay"); 639 } 640 $self->_data_sig_enqueue_poll_event($signal); 641 } 642 else { 643 if (TRACE_SIGNALS) { 644 _warn("<sg> POE::Kernel SIGCHLD poll loop paused"); 645 } 646 $self->_idle_queue_shrink(); 647 } 648 } 649} 650 651sub _data_sig_reap_pids { 652 my $self = shift(); 653 654 # Reap children for as long as waitpid(2) says something 655 # interesting has happened. 656 # TODO This has a possibility of an infinite loop, but so far it 657 # hasn't hasn't happened. 658 659 my $pid; 660 while ($pid = waitpid(-1, WNOHANG)) { 661 # waitpid(2) returned a process ID. Emit an appropriate SIGCHLD 662 # event and loop around again. 663 664 if (($pid > 0) or (RUNNING_IN_HELL and $pid < -1)) { 665 if (RUNNING_IN_HELL or WIFEXITED($?) or WIFSIGNALED($?)) { 666 667 if (TRACE_SIGNALS) { 668 _warn("<sg> POE::Kernel detected SIGCHLD (pid=$pid; exit=$?)"); 669 } 670 671 # Check for explicit SIGCHLD watchers, and enqueue explicit 672 # events for them. 673 674 if (exists $kr_pids_to_events{$pid}) { 675 my @sessions_to_clear; 676 while (my ($sid, $ses_rec) = each %{$kr_pids_to_events{$pid}}) { 677 $self->_data_ev_enqueue( 678 $ses_rec->[PID_SESSION], $self, $ses_rec->[PID_EVENT], ET_SIGCLD, 679 [ 'CHLD', $pid, $?, @{$ses_rec->[PID_ARGS]} ], 680 __FILE__, __LINE__, undef 681 ); 682 push @sessions_to_clear, $sid; 683 } 684 $self->_data_sig_pid_ignore($_, $pid) foreach @sessions_to_clear; 685 } 686 687 # Kick off a SIGCHLD cascade. 688 $self->_data_ev_enqueue( 689 $self, $self, EN_SIGNAL, ET_SIGNAL, [ 'CHLD', $pid, $? ], 690 __FILE__, __LINE__, undef 691 ); 692 } 693 elsif (TRACE_SIGNALS) { 694 _warn("<sg> POE::Kernel detected strange exit (pid=$pid; exit=$?"); 695 } 696 697 if (TRACE_SIGNALS) { 698 _warn("<sg> POE::Kernel will poll again immediately"); 699 } 700 701 next; 702 } 703 704 # The only other negative value waitpid(2) should return is -1. 705 # This is highly unlikely, but it's necessary to catch 706 # portability problems. 707 # 708 # TODO - Find a way to test this. 709 710 _trap "internal consistency error: waitpid returned $pid" if $pid != -1; 711 712 # If the error is an interrupted syscall, poll again right away. 713 714 if ($! == EINTR) { 715 if (TRACE_SIGNALS) { 716 _warn( 717 "<sg> POE::Kernel's waitpid(2) was interrupted.\n", 718 "POE::Kernel will poll again immediately.\n" 719 ); 720 } 721 next; 722 } 723 724 # No child processes exist. TODO This is different than 725 # children being present but running. Maybe this condition 726 # could halt polling entirely, and some UNIVERSAL::fork wrapper 727 # could restart polling when processes are forked. 728 729 if ($! == ECHILD) { 730 if (TRACE_SIGNALS) { 731 _warn("<sg> POE::Kernel has no child processes"); 732 } 733 last; 734 } 735 736 # Some other error occurred. 737 738 if (TRACE_SIGNALS) { 739 _warn("<sg> POE::Kernel's waitpid(2) got error: $!"); 740 } 741 last; 742 } 743 744 # Remember whether there are more processes to reap. 745 746 $kr_has_child_procs = !$pid; 747} 748 749# Are there child processes worth waiting for? 750# We don't really care if we're not polling for signals. 751 752sub _data_sig_kernel_awaits_pids { 753 my $self = shift(); 754 755 return 0 if !USE_SIGCHLD and !$polling_for_signals; 756 757 # There must be child processes or pending signals. 758 return 0 unless $kr_has_child_procs or $self->_data_sig_pipe_has_signals(); 759 760 # At least one session is watching an explicit PID. 761 # TODO - Watching a non-existent PID is legal but ill-advised. 762 return 1 if scalar keys %kr_pids_to_events; 763 764 # Is the session waiting for a blanket sig(CHLD)? 765 return exists $kr_signals{CHLD}; 766} 767 768###################### 769## Safe signals, the final solution: 770## Semantically, signal handlers and the main loop are in different threads. 771## To avoid all possible deadlock and race conditions once and for all we 772## implement them as shared-nothing threads. 773## 774## The signal handlers are split in 2 : 775## - a top handler, which sends the signal number over a one-way pipe. 776## - a bottom handler, which is called when this number is received in the 777## main loop. 778## The top handler will send a packet of PID and number. We need the PID 779## because of the race condition with signals in perl; signals meant for the 780## parent end up in both the parent and child. So we check the PID to make 781## sure it was intended for the child. We use 'ii' (2 ints, aka 8 bytes) 782## and not 'iC' (int+byte, aka 5 bytes) because we want a small factor of 783## the buffer size in the hopes of never getting a short read. Ever. 784 785use vars qw( $signal_pipe_read_fd ); 786my( 787 $signal_pipe_write, 788 $signal_pipe_read, 789 $signal_pipe_pid, 790 $signal_mask_none, 791 $signal_mask_all, 792 793 @pending_signals, 794); 795 796sub SIGINFO_NAME () { 0 } 797sub SIGINFO_SRC_PID () { 1 } 798 799 800sub _data_sig_pipe_has_signals { 801 my $self = shift(); 802 return unless $signal_pipe_read; 803 my $vec = ''; 804 vec($vec, fileno($signal_pipe_read), 1) = 1; 805 806 # Ambiguous call resolved as CORE::select(), qualify as such or use & 807 return(CORE::select($vec, undef, undef, 0) > 0); 808} 809 810 811sub _data_sig_pipe_build { 812 my( $self ) = @_; 813 return unless USE_SIGNAL_PIPE; 814 my $fake = 128; 815 816 # Associate the pipe with this PID 817 $signal_pipe_pid = $$; 818 819 # Mess with the signal mask 820 $self->_data_sig_mask_all; 821 822 # Open the signal pipe. 823 # TODO - Normally POE::Pipe::OneWay will do the right thing. Why 824 # are we overriding its per-platform autodetection? 825 if (RUNNING_IN_HELL) { 826 ( $signal_pipe_read, $signal_pipe_write ) = POE::Pipe::OneWay->new('inet'); 827 } 828 else { 829 ( $signal_pipe_read, $signal_pipe_write ) = POE::Pipe::OneWay->new('pipe'); 830 } 831 832 unless ($signal_pipe_write) { 833 _trap "<sg> Error " . ($!+0) . " trying to create the signal pipe: $!"; 834 } 835 836 # Allows Resource::FileHandles to by-pass the queue 837 $signal_pipe_read_fd = fileno $signal_pipe_read; 838 if( TRACE_SIGNALS ) { 839 _warn "<sg> signal_pipe_write=$signal_pipe_write"; 840 _warn "<sg> signal_pipe_read=$signal_pipe_read"; 841 _warn "<sg> signal_pipe_read_fd=$signal_pipe_read_fd"; 842 } 843 844 # Add to the select list 845 $self->_data_handle_condition( $signal_pipe_read ); 846 $self->loop_watch_filehandle( $signal_pipe_read, MODE_RD ); 847 $self->_data_sig_unmask_all; 848} 849 850sub _data_sig_mask_build { 851 return if RUNNING_IN_HELL; 852 $signal_mask_none = POSIX::SigSet->new(); 853 $signal_mask_none->emptyset(); 854 $signal_mask_all = POSIX::SigSet->new(); 855 $signal_mask_all->fillset(); 856} 857 858### Mask all signals 859sub _data_sig_mask_all { 860 return if RUNNING_IN_HELL; 861 my $self = $poe_kernel; 862 unless( $signal_mask_all ) { 863 $self->_data_sig_mask_build; 864 } 865 my $mask_temp = POSIX::SigSet->new(); 866 sigprocmask( SIG_SETMASK, $signal_mask_all, $mask_temp ) 867 or _trap "<sg> Unable to mask all signals: $!"; 868} 869 870### Unmask all signals 871sub _data_sig_unmask_all { 872 return if RUNNING_IN_HELL; 873 my $self = $poe_kernel; 874 unless( $signal_mask_none ) { 875 $self->_data_sig_mask_build; 876 } 877 my $mask_temp = POSIX::SigSet->new(); 878 sigprocmask( SIG_SETMASK, $signal_mask_none, $mask_temp ) 879 or _trap "<sg> Unable to unmask all signals: $!"; 880} 881 882 883 884sub _data_sig_pipe_finalize { 885 my( $self ) = @_; 886 if( $signal_pipe_read ) { 887 $self->loop_ignore_filehandle( $signal_pipe_read, MODE_RD ); 888 close $signal_pipe_read; undef $signal_pipe_read; 889 } 890 if( $signal_pipe_write ) { 891 close $signal_pipe_write; undef $signal_pipe_write; 892 } 893 # Don't send anything more! 894 undef( $signal_pipe_pid ); 895} 896 897### Send a signal "message" to the main thread 898### Called from the top signal handlers 899sub _data_sig_pipe_send { 900 local $!; 901 902 my $signal_name = $_[1]; 903 904 if( TRACE_SIGNALS ) { 905 _warn "<sg> Caught SIG$signal_name"; 906 } 907 908 return if $finalizing; 909 910 if( not defined $signal_pipe_pid ) { 911 _trap "<sg> _data_sig_pipe_send called before signal pipe was initialized."; 912 } 913 914 # ugh- has_forked() can't be called fast enough. This warning might 915 # show up before it is called. Should we just detect forking and do it 916 # for the user? Probably not... 917 918 if( $$ != $signal_pipe_pid ) { 919 _warn( 920 "<sg> Signal caught in different process than POE::Kernel initialized " . 921 "(newPID=$$ oldPID=$signal_pipe_pid sig=$signal_name).\n" 922 ); 923 _warn( 924 "Call POE::Kernel->has_forked() in the child process " . 925 "to relocate the signal handler.\n" 926 ); 927 } 928 929 # We're registering signals in a list. Pipes have more finite 930 # capacity, so we'll just write a single-byte semaphore-like token. 931 # It's up to the reader to process the list. Duplicates are 932 # permitted, and their ordering may be significant. Precedent: 933 # http://search.cpan.org/perldoc?IPC%3A%3AMorseSignals 934 935 push @pending_signals, [ 936 $signal_name, # SIGINFO_NAME 937 $$, # SIGINFO_SRC_PID 938 ]; 939 940 if (TRACE_SIGNALS) { 941 _warn "<sg> Attempting signal pipe write"; 942 } 943 944 my $count = syswrite( $signal_pipe_write, '!' ); 945 946 # TODO - We need to crash gracefully if the write fails, but not if 947 # it's due to the pipe being full. We might solve this by only 948 # writing on the edge of @pending_signals == 1 after the push(). 949 # We assume @pending_signals > 1 means there's a byte in the pipe, 950 # so the reader will wake up to catch 'em all. 951 952 if ( ASSERT_DATA ) { 953 unless (defined $count and $count == 1) { 954 _trap "<sg> Signal pipe write failed: $!"; 955 } 956 } 957} 958 959### Read all signal numbers. 960### Call the related bottom handler. That is, inside the kernel loop. 961sub _data_sig_pipe_read { 962 my( $self, $fileno, $mode ) = @_; 963 964 if( ASSERT_DATA ) { 965 _trap "Illegal mode=$mode on fileno=$fileno" unless 966 $fileno == $signal_pipe_read_fd 967 and $mode eq MODE_RD; 968 } 969 970 # Read all data from the signal pipe. 971 # The data itself doesn't matter. 972 # TODO - If writes can happen on the edge of @pending_signals (from 973 # 0 to 1 element), then we oughtn't need to loop here. 974 975 while (1) { 976 my $octets_count = sysread( $signal_pipe_read, (my $data), 65536 ); 977 978 next if $octets_count; 979 last if defined $octets_count; 980 981 last if $! == EAGAIN or $! == EWOULDBLOCK; 982 983 if (ASSERT_DATA) { 984 _trap "<sg> Error " . ($!+0) . " reading from signal pipe: $!"; 985 } 986 elsif(TRACE_SIGNALS) { 987 _warn "<sg> Error " . ($!+0) . " reading from signal pipe: $!"; 988 } 989 990 last; 991 } 992 993 # Double buffer signals. 994 # The intent is to avoid a race condition by processing the same 995 # buffer that new signals go into. 996 997 return unless @pending_signals; 998 my @signals = @pending_signals; 999 @pending_signals = (); 1000 1001 if (TRACE_SIGNALS) { 1002 _warn "<sg> Read " . scalar(@signals) . " signals from the list"; 1003 } 1004 1005 foreach my $signal (@signals) { 1006 my $signal_name = $signal->[SIGINFO_NAME]; 1007 my $signal_src_pid = $signal->[SIGINFO_SRC_PID]; 1008 1009 # Ignore signals from other processes. 1010 # This can happen if we've fork()ed without calling has_forked() 1011 # to reset the signals subsystem. 1012 # 1013 # TODO - We might be able to get rid of has_forked() if PID 1014 # mismatches are detected. 1015 1016 next if $signal_src_pid != $$; 1017 1018 if( $signal_name eq 'CHLD' ) { 1019 _loop_signal_handler_chld_bottom( $signal_name ); 1020 } 1021 elsif( $signal_name eq 'PIPE' ) { 1022 _loop_signal_handler_pipe_bottom( $signal_name ); 1023 } 1024 else { 1025 _loop_signal_handler_generic_bottom( $signal_name ); 1026 } 1027 } 1028} 1029 10301; 1031 1032__END__ 1033 1034=head1 NAME 1035 1036POE::Resource::Signals - internal signal manager for POE::Kernel 1037 1038=head1 SYNOPSIS 1039 1040There is no public API. 1041 1042=head1 DESCRIPTION 1043 1044POE::Resource::Signals is a mix-in class for POE::Kernel. It provides 1045the features needed to manage signals. It is used internally by 1046POE::Kernel, so it has no public interface. 1047 1048=head1 SEE ALSO 1049 1050See L<POE::Kernel/Signals> for a deeper discussion about POE's signal 1051handling. 1052 1053See L<POE::Kernel/Signal Watcher Methods> for POE's public signals 1054API. 1055 1056See L<POE::Kernel/Resources> for public information about POE 1057resources. 1058 1059See L<POE::Resource> for general discussion about resources and the 1060classes that manage them. 1061 1062=head1 BUGS 1063 1064None known. 1065 1066=head1 AUTHORS & COPYRIGHTS 1067 1068Please see L<POE> for more information about authors and contributors. 1069 1070=cut 1071 1072# rocco // vim: ts=2 sw=2 expandtab 1073# TODO - Edit. 1074