File Coverage

blib/lib/MCE/Signal.pm

Criterion	Covered	Total	%
statement	89	173	51.4
branch	43	146	29.4
condition	27	122	22.1
subroutine	17	25	68.0
pod	3	3	100.0
total	179	469	38.1

###############################################################################
## ----------------------------------------------------------------------------
## Temporary directory creation/cleanup and signal handling.
##
###############################################################################

package MCE::Signal;

use strict;
use warnings;

no warnings qw( threads recursion uninitialized once );

our $VERSION = '1.889';

## no critic (BuiltinFunctions::ProhibitStringyEval)

our ($display_die_with_localtime, $display_warn_with_localtime);
our ($main_proc_id, $prog_name, $tmp_dir);

tie $tmp_dir, 'MCE::Signal::_tmpdir';

use Carp ();

BEGIN {
   $main_proc_id =  $$;
   $prog_name    =  $0;
   $prog_name    =~ s{^.*[\\/]}{}g;
   $prog_name    =  'perl' if ($prog_name eq '-e' || $prog_name eq '-');

   return;
}

use base qw( Exporter );
use Time::HiRes ();

our @EXPORT_OK = qw( $tmp_dir sys_cmd stop_and_exit );
our %EXPORT_TAGS = (
   all     => \@EXPORT_OK,
   tmp_dir => [ qw( $tmp_dir ) ]
);

END {
   MCE::Signal->stop_and_exit($?)
      if ($$ == $main_proc_id && !$MCE::Signal::KILLED && !$MCE::Signal::STOPPED);
}

###############################################################################
## ----------------------------------------------------------------------------
## Process import, export, & module arguments.
##
###############################################################################

sub _croak { $\ = undef; goto &Carp::croak }
sub _usage { _croak "MCE::Signal error: ($_[0]) is not a valid option" }
sub _flag  { 1 }

my $_is_MSWin32   = ($^O eq 'MSWin32') ? 1 : 0;
my $_keep_tmp_dir = 0;
my $_use_dev_shm  = 0;
my $_no_kill9     = 0;
my $_imported;

sub import {
   my $_class = shift;
   return if $_imported++;

   my ($_no_setpgrp, $_no_sigmsg, $_setpgrp, @_export_args) = (0, 0, 0);

   while (my $_arg = shift) {
      $_setpgrp      = _flag() and next if ($_arg eq '-setpgrp');
      $_keep_tmp_dir = _flag() and next if ($_arg eq '-keep_tmp_dir');
      $_use_dev_shm  = _flag() and next if ($_arg eq '-use_dev_shm');
      $_no_kill9     = _flag() and next if ($_arg eq '-no_kill9');

      # deprecated options for backwards compatibility
      $_no_setpgrp   = _flag() and next if ($_arg eq '-no_setpgrp');
      $_no_sigmsg    = _flag() and next if ($_arg eq '-no_sigmsg');

      _usage($_arg) if ($_arg =~ /^-/);

      push @_export_args, $_arg;
   }

   local $Exporter::ExportLevel = 1;
   Exporter::import($_class, @_export_args);

   ## Sets the current process group for the current process.
   setpgrp(0,0) if ($_setpgrp == 1 && !$_is_MSWin32);

   ## Make tmp_dir if caller requested it.
   _make_tmpdir() if ($_use_dev_shm || grep /tmp_dir/, @_export_args);

   return;
}

###############################################################################
## ----------------------------------------------------------------------------
## Configure signal handling.
##
###############################################################################

## Set traps to catch signals.
if ( !$_is_MSWin32 ) {
   $SIG{ABRT} = \&stop_and_exit;  # UNIX SIG  6
   $SIG{HUP}  = \&stop_and_exit;  # UNIX SIG  1
   $SIG{INT}  = \&stop_and_exit;  # UNIX SIG  2
   $SIG{PIPE} = \&stop_and_exit;  # UNIX SIG 13
   $SIG{QUIT} = \&stop_and_exit;  # UNIX SIG  3
   $SIG{TERM} = \&stop_and_exit;  # UNIX SIG 15

   ## MCE handles the reaping of its children.
   $SIG{CHLD} = 'DEFAULT';
}

my $_safe_clean = 0;

sub _make_tmpdir {
   my ($_count, $_tmp_base_dir) = (0);

   return $tmp_dir if (defined $tmp_dir && -d $tmp_dir && -w _);

   if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) {
      if ($^O =~ /mswin|mingw|msys|cygwin/i) {
         $_tmp_base_dir = $ENV{TEMP} . '/Perl-MCE';
         mkdir $_tmp_base_dir unless -d $_tmp_base_dir;
      } else {
         $_tmp_base_dir = $ENV{TEMP};
      }
   }
   elsif (! -w '/tmp' && -e $ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) {
      $_tmp_base_dir = $ENV{TMPDIR};
   }
   else {
      $_tmp_base_dir = ($_use_dev_shm && -d '/dev/shm' && -w _)
         ? '/dev/shm' : '/tmp';
   }

   _croak("Error: MCE::Signal: ($_tmp_base_dir) is not writeable")
      if (! exists $ENV{'MOBASTARTUPDIR'} && ! -w $_tmp_base_dir);

   ## Remove tainted'ness from $tmp_dir.
   ($tmp_dir) = "$_tmp_base_dir/$prog_name.$$.$_count" =~ /(.*)/;

   while ( !(mkdir $tmp_dir, 0770) ) {
      ($tmp_dir) = ("$_tmp_base_dir/$prog_name.$$.".(++$_count)) =~ /(.*)/;
   }

   $_safe_clean = 1;

   return $tmp_dir;
}

sub _remove_tmpdir {
   return if (!defined $tmp_dir || $tmp_dir eq '' || ! -d $tmp_dir);

   if ($_keep_tmp_dir == 1) {
      print {*STDERR} "$prog_name: saved tmp_dir = $tmp_dir\n";
   }
   elsif ($_safe_clean) {
      if ($ENV{'TEMP'} && $^O =~ /mswin|mingw|msys|cygwin/i) {
         ## remove tainted'ness
         my ($_dir) = $ENV{'TEMP'} =~ /(.*)/;
         chdir $_dir if -d $_dir;
      }
      rmdir $tmp_dir;
      if (-d $tmp_dir) {
         local $@; local $SIG{__DIE__};
         eval 'require File::Path; File::Path::rmtree($tmp_dir)';
      }
   }

   $tmp_dir = undef;
}

###############################################################################
## ----------------------------------------------------------------------------
## Stops execution, removes temp directory and exits cleanly.
##
## Provides safe reentrant logic for parent and child processes.
## The $main_proc_id variable is defined above.
##
###############################################################################

BEGIN {
   $MCE::Signal::IPC = 0;   # 1 = defer signal_handling until completed IPC
   $MCE::Signal::SIG = '';  # signal received during IPC in MCE::Shared 1.863
}

sub defer {
   $MCE::Signal::SIG = $_[0] if $_[0];
   return;
}

my %_sig_name_lkup = map { $_ => 1 } qw(
   __DIE__ ABRT HUP INT PIPE QUIT TERM __WARN__
);

my $_count = 0;

my $_handler_count = $INC{'threads/shared.pm'}
   ? threads::shared::share($_count)
   : \$_count;

sub stop_and_exit {
   shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal');
   return MCE::Signal::defer($_[0]) if $MCE::Signal::IPC;

   my ($_exit_status, $_is_sig, $_sig_name) = ($?, 0, $_[0] || 0);
   $SIG{__DIE__} = $SIG{__WARN__} = sub {};

   if (exists $_sig_name_lkup{$_sig_name}) {
      $_exit_status = $MCE::Signal::KILLED = $_is_sig = 1;
      $_exit_status = 255, $_sig_name = 'TERM' if ($_sig_name eq '__DIE__');
      $_exit_status = 0 if ($_sig_name eq 'PIPE');
      $SIG{INT} = $SIG{$_sig_name} = sub {};
   }
   else {
      $_exit_status = $_sig_name if ($_sig_name =~ /^\d+$/);
      $MCE::Signal::STOPPED = 1;
   }

   ## Main process.
   if ($$ == $main_proc_id) {

      if (++${ $_handler_count } == 1) {
         ## Kill process group if signaled.
         if ($_is_sig == 1) {
            ($_sig_name eq 'PIPE')
               ? CORE::kill('PIPE', $_is_MSWin32 ? -$$ : -getpgrp)
               : CORE::kill('INT' , $_is_MSWin32 ? -$$ : -getpgrp);

            if ($_sig_name eq 'PIPE') {
               for my $_i (1..2) { Time::HiRes::sleep(0.015); }
            } else {
               for my $_i (1..3) { Time::HiRes::sleep(0.060); }
            }
         }

         ## Remove temp directory.
         _remove_tmpdir() if defined($tmp_dir);

         ## Signal process group to die.
         if ($_is_sig == 1) {
            if ($_sig_name eq 'INT' && -t STDIN) { ## no critic
               print {*STDERR} "\n";
            }
            if ($INC{'threads.pm'} && ($] lt '5.012000' || threads->tid())) {
               ($_no_kill9 == 1 || $_sig_name eq 'PIPE')
                  ? CORE::kill('INT', $_is_MSWin32 ? -$$ : -getpgrp)
                  : CORE::kill('KILL', -$$);
            }
            else {
               CORE::kill('INT', $_is_MSWin32 ? -$$ : -getpgrp);
            }
         }
      }
   }

   ## Child processes.
   elsif ($_is_sig) {

      ## Windows support, from nested workers.
      if ($_is_MSWin32) {
         _remove_tmpdir() if defined($tmp_dir);
         CORE::kill('KILL', $main_proc_id, -$$);
      }

      ## Real child processes.
      else {
         CORE::kill($_sig_name, $main_proc_id, -$$);
         CORE::kill('KILL', -$$, $$);
      }
   }

   ## Exit with status.
   CORE::exit($_exit_status);
}

###############################################################################
## ----------------------------------------------------------------------------
## Run command via the system(...) function.
##
## The system function in Perl ignores SIGINT and SIGQUIT. These 2 signals
## are sent to the command being executed via system() but not back to
## the underlying Perl script. The code below will ensure the Perl script
## receives the same signal in order to raise an exception immediately
## after the system call.
##
## Returns the actual exit status.
##
###############################################################################

sub sys_cmd {
   shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal');

   _croak('MCE::Signal::sys_cmd: no arguments were specified') if (@_ == 0);

   my $_status = system(@_);
   my $_sig_no = $_status & 127;
   my $_exit_status = $_status >> 8;

   ## Kill the process group if command caught SIGINT or SIGQUIT.

   CORE::kill('INT',  $main_proc_id, $_is_MSWin32 ? -$$ : -getpgrp)
      if $_sig_no == 2;

   CORE::kill('QUIT', $main_proc_id, $_is_MSWin32 ? -$$ : -getpgrp)
      if $_sig_no == 3;

   return $_exit_status;
}

###############################################################################
## ----------------------------------------------------------------------------
## Signal handlers for __DIE__ & __WARN__ utilized by MCE.
##
###############################################################################

sub _die_handler {
   shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal');

   if (!defined $^S || $^S) {
      if ( ($INC{'threads.pm'} && threads->tid() != 0) ||
            $ENV{'PERL_IPERL_RUNNING'}
      ) {
         # thread env or running inside IPerl, check stack trace
         my $_t = Carp::longmess(); $_t =~ s/\teval [^\n]+\n$//;
         if ( $_t =~ /^(?:[^\n]+\n){1,7}\teval / ||
              $_t =~ /\n\teval [^\n]+\n\t(?:eval|Try)/ )
         {
            CORE::die(@_);
         }
      }
      else {
         # normal env, trust $^S
         CORE::die(@_);
      }
   }

   local $\ = undef;

   ## Set $MCE::Signal::display_die_with_localtime = 1;
   ## when wanting the output to contain the localtime.

   if (defined $_[0]) {
      my $mesg = $_[0]; $mesg =~ s/, <__ANONIO__> line \d+//;
      if ($MCE::Signal::display_die_with_localtime) {
         my $_time_stamp = localtime;
         print {*STDERR} "## $_time_stamp: $prog_name: ERROR:\n", $mesg;
      }
      else {
         print {*STDERR} $mesg;
      }
   }

   MCE::Signal::stop_and_exit('__DIE__');
}

sub _warn_handler {
   shift @_ if (defined $_[0] && $_[0] eq 'MCE::Signal');

   ## Ignore thread warnings during exiting.

   return if (
      $_[0] =~ /^Finished with active (?:child|hobo) processes/  ||
      $_[0] =~ /^A thread exited while \d+ threads were running/ ||
      $_[0] =~ /^Attempt to free unreferenced scalar/            ||
      $_[0] =~ /^Perl exited with active threads/                ||
      $_[0] =~ /^Thread \d+ terminated abnormally/
   );

   local $\ = undef;

   ## Set $MCE::Signal::display_warn_with_localtime = 1;
   ## when wanting the output to contain the localtime.

   if (defined $_[0]) {
      my $mesg = $_[0]; $mesg =~ s/, <__ANONIO__> line \d+//;
      if ($MCE::Signal::display_warn_with_localtime) {
         my $_time_stamp = localtime;
         print {*STDERR} "## $_time_stamp: $prog_name: WARNING:\n", $mesg;
      }
      else {
         print {*STDERR} $mesg;
      }
   }

   return;
}

1;

###############################################################################
## ----------------------------------------------------------------------------
## TIE scalar package for making $MCE::Signal::tmp_dir on demand.
##
###############################################################################

package MCE::Signal::_tmpdir;

sub TIESCALAR {
   my $_class = shift;
   bless \do{ my $o = defined $_[0] ? shift : undef }, $_class;
}

sub STORE {
   ${ $_[0] } = $_[1];

   $_safe_clean = 0 if ( length $_[1] < 9 );
   $_safe_clean = 0 if ( $ENV{'TEMP'} && $ENV{'TEMP'} eq $_[1] );
   $_safe_clean = 0 if ( $_[1] =~ m{[\\/](?:etc|bin|lib|sbin)} );
   $_safe_clean = 0 if ( $_[1] =~ m{[\\/](?:temp|tmp)[\\/]?$}i );

   $_[1];
}

sub FETCH {
   if (!defined ${ $_[0] }) {
      my $_caller = caller();
      if ($_caller ne 'MCE' && $_caller ne 'MCE::Signal') {
         if ($INC{'MCE.pm'} && MCE->wid() > 0) {
            ${ $_[0] } = MCE->tmp_dir();
         } else {
            ${ $_[0] } = MCE::Signal::_make_tmpdir();
         }
      }
   }
   ${ $_[0] };
}

1;

__END__