view release on metacpan or  search on metacpan

lib/POE/Resource/Signals.pm  view on Meta::CPAN

use vars qw($VERSION);
$VERSION = '1.370'; # NOTE - Should be #.### (three decimal places)

# These methods are folded into POE::Kernel;
package POE::Kernel;

use strict;

use POE::Pipe::OneWay;
use POE::Resource::FileHandles;
use POSIX qw(:sys_wait_h sigprocmask SIG_SETMASK);

### Map watched signal names to the sessions that are watching them
### and the events that must be delivered when they occur.

sub SEV_EVENT   () { 0 }
sub SEV_ARGS    () { 1 }
sub SEV_SESSION () { 2 }

my %kr_signals;
#  ( $signal_name =>
#    { $session_id =>
#     [ $event_name,    SEV_EVENT
#       $event_args,    SEV_ARGS
#       $session_ref,   SEV_SESSION
#     ],
#      ...,
#    },
#    ...,
#  );

my %kr_sessions_to_signals;
#  ( $session_id =>
#    { $signal_name =>
#      [ $event_name,   SEV_EVENT
#        $event_args,   SEV_ARGS
#        $session_ref,  SEV_SESSION
#      ],
#      ...,
#    },
#    ...,
#  );

my %kr_pids_to_events;
# { $pid =>
#   { $session_id =>
#     [ $blessed_session,   # PID_SESSION
#       $event_name,        # PID_EVENT
#       $args,              # PID_ARGS
#     ]
#   }
# }

my %kr_sessions_to_pids;
# { $session_id => { $pid => 1 } }

sub PID_SESSION () { 0 }
sub PID_EVENT   () { 1 }
sub PID_ARGS    () { 2 }

sub _data_sig_relocate_kernel_id {
  my ($self, $old_id, $new_id) = @_;

  while (my ($signal, $sig_rec) = each %kr_signals) {
    next unless exists $sig_rec->{$old_id};
    $sig_rec->{$new_id} = delete $sig_rec->{$old_id};
  }

  $kr_sessions_to_signals{$new_id} = delete $kr_sessions_to_signals{$old_id}
    if exists $kr_sessions_to_signals{$old_id};

  while (my ($pid, $pid_rec) = each %kr_pids_to_events) {
    next unless exists $pid_rec->{$old_id};
    $pid_rec->{$new_id} = delete $pid_rec->{$old_id};
  }

  $kr_sessions_to_pids{$new_id} = delete $kr_sessions_to_pids{$old_id}
    if exists $kr_sessions_to_pids{$old_id};
}

# Bookkeeping per dispatched signal.

# TODO - Why not lexicals?
use vars (
 '@kr_signaled_sessions',            # The sessions touched by a signal.
 '$kr_signal_total_handled',         # How many sessions handled a signal.
 '$kr_signal_type',                  # The type of signal being dispatched.
);

#my @kr_signaled_sessions;           # The sessions touched by a signal.
#my $kr_signal_total_handled;        # How many sessions handled a signal.
#my $kr_signal_type;                 # The type of signal being dispatched.

# A flag to tell whether we're currently polling for signals.
# Under USE_SIGCHLD, determines whether a SIGCHLD polling event has
# already been queued.
my $polling_for_signals = 0;

# There may be latent subprocesses in some environments.
# Or we may need to "always loop once" if we're polling for SIGCHLD.
# This constant lets us define those exceptional cases.
# We had some in the past, but as of 2013-10-06 we seem to have
# eliminated those special cases.
use constant BASE_SIGCHLD_COUNT => 0;

my $kr_has_child_procs = BASE_SIGCHLD_COUNT;

# A list of special signal types.  Signals that aren't listed here are
# benign (they do not kill sessions at all).  "Terminal" signals are
# the ones that UNIX defaults to killing processes with.  Thus STOP is
# not terminal.

sub SIGTYPE_BENIGN      () { 0x00 }
sub SIGTYPE_TERMINAL    () { 0x01 }
sub SIGTYPE_NONMASKABLE () { 0x02 }

my %_signal_types = (
  QUIT => SIGTYPE_TERMINAL,
  INT  => SIGTYPE_TERMINAL,
  KILL => SIGTYPE_TERMINAL,
  TERM => SIGTYPE_TERMINAL,

lib/POE/Resource/Signals.pm  view on Meta::CPAN

  my $mask_temp = POSIX::SigSet->new();
  sigprocmask( SIG_SETMASK, $signal_mask_all, $mask_temp )
            or _trap "<sg> Unable to mask all signals: $!";
}

### Unmask all signals
sub _data_sig_unmask_all {
  return if RUNNING_IN_HELL;
  my $self = $poe_kernel;
  unless( $signal_mask_none ) {
    $self->_data_sig_mask_build;
  }
  my $mask_temp = POSIX::SigSet->new();
  sigprocmask( SIG_SETMASK, $signal_mask_none, $mask_temp )
        or _trap "<sg> Unable to unmask all signals: $!";
}



sub _data_sig_pipe_finalize {
  my( $self ) = @_;
  if( $signal_pipe_read ) {
    $self->loop_ignore_filehandle( $signal_pipe_read, MODE_RD );
    close $signal_pipe_read; undef $signal_pipe_read;
  }
  if( $signal_pipe_write ) {
    close $signal_pipe_write; undef $signal_pipe_write;
  }
  # Don't send anything more!
  undef( $signal_pipe_pid );
}

### Send a signal "message" to the main thread
### Called from the top signal handlers
sub _data_sig_pipe_send {
  local $!;

  my $signal_name = $_[1];

  if( TRACE_SIGNALS ) {
    _warn "<sg> Caught SIG$signal_name";
  }

  return if $finalizing;

  if( not defined $signal_pipe_pid ) {
    _trap "<sg> _data_sig_pipe_send called before signal pipe was initialized.";
  }

  # ugh- has_forked() can't be called fast enough.  This warning might
  # show up before it is called.  Should we just detect forking and do it
  # for the user?  Probably not...

  if( $$ != $signal_pipe_pid ) {
    _warn(
      "<sg> Signal caught in different process than POE::Kernel initialized " .
      "(newPID=$$ oldPID=$signal_pipe_pid sig=$signal_name).\n"
    );
    _warn(
      "Call POE::Kernel->has_forked() in the child process " .
      "to relocate the signal handler.\n"
    );
  }

  # We're registering signals in a list.  Pipes have more finite
  # capacity, so we'll just write a single-byte semaphore-like token.
  # It's up to the reader to process the list.  Duplicates are
  # permitted, and their ordering may be significant.  Precedent:
  # http://search.cpan.org/perldoc?IPC%3A%3AMorseSignals

  push @pending_signals, [
    $signal_name, # SIGINFO_NAME
    $$,           # SIGINFO_SRC_PID
  ];

  if (TRACE_SIGNALS) {
    _warn "<sg> Attempting signal pipe write";
  }

  my $count = syswrite( $signal_pipe_write, '!' );

  # TODO - We need to crash gracefully if the write fails, but not if
  # it's due to the pipe being full.  We might solve this by only
  # writing on the edge of @pending_signals == 1 after the push().
  # We assume @pending_signals > 1 means there's a byte in the pipe,
  # so the reader will wake up to catch 'em all.

  if ( ASSERT_DATA ) {
    unless (defined $count and $count == 1) {
      _trap "<sg> Signal pipe write failed: $!";
    }
  }
}

### Read all signal numbers.
### Call the related bottom handler.  That is, inside the kernel loop.
sub _data_sig_pipe_read {
  my( $self, $fileno, $mode ) = @_;

  if( ASSERT_DATA ) {
    _trap "Illegal mode=$mode on fileno=$fileno" unless
                                    $fileno == $signal_pipe_read_fd
                                and $mode eq MODE_RD;
  }

  # Read all data from the signal pipe.
  # The data itself doesn't matter.
  # TODO - If writes can happen on the edge of @pending_signals (from
  # 0 to 1 element), then we oughtn't need to loop here.

  while (1) {
    my $octets_count = sysread( $signal_pipe_read, (my $data), 65536 );

    next if $octets_count;
    last if defined $octets_count;

    last if $! == EAGAIN or $! == EWOULDBLOCK;

    if (ASSERT_DATA) {
      _trap "<sg> Error " . ($!+0) . " reading from signal pipe: $!";
    }