# analyze_default_signal_behavior.pl: see what each signal does
# to a Perl program when the "DEFAULT" signal handler is set on
# that program. The results can be appended to the
# lib/Signals/XSIG/Default.pm file.
use IO::Handle;
use POSIX ':sys_wait_h';
use Config;
use strict;
use warnings;
$| = 1;
if (@ARGV < 2) {
print STDERR qq[
This program will experimentally determine the default behavior
of each signal on your system. The data collected will be
helpful in creating an appropriate Signals/XSIG/Default.pm
file.
];
}
my (@IGNORE, @SUSPEND, @TERMINATE, @UNKNOWN);
my $num_simultaneous = shift @ARGV || 10;
@IGNORE = ('__WARN__','__DIE__');
my @sigs = (sort keys %SIG, 'ZERO');
@sigs = @ARGV if @ARGV > 0;
my $abort_status;
if (@ARGV < 2) {
printf STDERR "There are %d signals to analyze.\n", scalar @sigs;
print STDERR "This may take a few minutes.\n\n";
}
# figure out the exit status of a program that calls POSIX::abort()
sub abort_status {
use POSIX ();
if (!defined $abort_status) {
if (fork() == 0) {
POSIX::abort();
exit 0;
}
wait;
$abort_status = $? || -9E9;
}
return $abort_status;
}
sub analysis_file {
my ($signal) = @_;
"siganal$signal.txt";
}
sub analyze_default_behavior_for_signal {
my ($sig, $i, $analysis_file, $analysis_script) = @_;
$analysis_file ||= analysis_file($sig);
$analysis_script ||= "siganal$i.pl";
unlink $analysis_file, $analysis_script;
open my $cfh, '>', $analysis_script;
print $cfh qq[
\$SIG{'$sig'} = 'DEFAULT';
my \$n = sleep 2;
my \$msg = "CHILD \$n / 4\n";
open(F, '>>', '$analysis_file');
print F \$msg;
close F;
exit 0;
];
close $cfh;
my $status = 'unknown';
my ($pid, $win32ProcObj);
if ($^O eq 'MSWin32') {
require Win32::Process;
require Win32;
Win32::Process::Create( $win32ProcObj,
$^X,
"$^X $analysis_script",
0,
&Win32::Process::NORMAL_PRIORITY_CLASS,
"." ) || die Win32::GetLastError();
$pid = $win32ProcObj->GetProcessID();
} else {
$pid = fork();
if ($pid == 0) {
%SIG = ();
exec $^X, $analysis_script;
die;
}
}
sleep 2;
my $nk = kill $sig, $pid;
sleep 1;
my $r = waitpid $pid, &WNOHANG;
$status = $? if $r == $pid;
sleep 5;
$nk = kill 'CONT', $pid;
sleep 1;
$r = waitpid $pid, &WNOHANG;
$status = $? if $r == $pid;
$nk = kill 'KILL', $pid;
$r = waitpid $pid, 0;
$status = $? if $r == $pid;
if (defined $win32ProcObj) {
$win32ProcObj->Wait(&Win32::Process::INFINITE);
}
my $msg = "Status: $status\n";
open my $fh, '>>', $analysis_file;
print $fh $msg;
close $fh;
unlink $analysis_script;
return $analysis_file;
}
$::j=0;
print "[$^O]\n";
while (@sigs) {
my @sigz = splice @sigs, 0, $num_simultaneous;
my $i = 0;
foreach my $sig (@sigz) {
if (fork() == 0) {
analyze_default_behavior_for_signal($sig,$i);
exit 0;
}
$i++;
}
wait foreach @sigz;
foreach my $sig (@sigz) {
parse_analysis_file($sig,analysis_file($sig));
}
}
sub parse_analysis_file {
my ($sig,$file) = @_;
open G, '<', $file;
my @g = <G>;
close G;
my $i = ++$::j;
my @sig_name = split ' ', $Config{sig_name};
my @sig_num = split ' ', $Config{sig_num};
my ($sig_no) = grep { $sig_name[$_] eq $sig } 0..$#sig_num;
$sig_no ||= 9999;
$sig_no = $sig_num[$sig_no];
$sig_no ||= '';
my ($sleep_result, $sleep_benchmark) = $g[0] =~ /CHILD (\d+) \/ (\d+)/;
if (defined($sleep_benchmark) && $sleep_result > $sleep_benchmark) {
# the program completed but took longer than ~4 seconds.
# This means it was suspended and then resumed several seconds later.
push @SUSPEND, $sig;
printf STDERR "%d. SIG", $i;
printf "%-7s [%s] => %s\n", $sig, $sig_no, "SUSPEND";
} else {
my ($status) = $g[-1] =~ /Status: (\d+)/;
if ($status eq "0") {
# The program completed normally in a regular amount of time.
# The signal was ignored or not received.
push @IGNORE, $sig;
printf STDERR "%d. SIG", $i;
printf "%-7s [%s] => %s\n", $sig, $sig_no, "IGNORE";
} elsif ($status > 0) {
# The program did not complete normally.
# The signal terminated the program.
push @TERMINATE, $sig;
printf STDERR "%d. SIG", $i;
if ($status == $sig_no << 8) {
# exit status is divisible by 256. Like quitting with exit()
printf "%-7s [%s] => %s\n", $sig, $sig_no, "EXIT $sig_no";
} elsif (0 && $status == abort_status()) {
# exit status same as abort status (see &abort_status).
printf "%-7s [%s] => %s\n", $sig, $sig_no, "ABORT";
} else {
# exit status not divisible by 256. Only way to do this
# reliably is to actually raise the signal
printf "%-7s [%s] => %s\n", $sig, $sig_no, "TERMINATE $status";
}
} else {
push @UNKNOWN, $sig;
printf STDERR "%d. SIG", $i;
printf "%-7s [%s] => %d %s\n", $sig, $sig_no, $status, "UNKNOWN";
}
}
unlink $file;
}