/snap/gh/640/usr/share/perl/5.38.2
Edit: /snap/gh/640/usr/share/perl/5.38.2/sigtrap.pm (8733B)
package sigtrap;
=head1 NAME
sigtrap - Perl pragma to enable simple signal handling
=cut
use Carp;
$VERSION = '1.10';
$Verbose ||= 0;
sub import {
my $pkg = shift;
my $handler = \&handler_traceback;
my $saw_sig = 0;
my $untrapped = 0;
local $_;
Arg_loop:
while (@_) {
$_ = shift;
if (/^[A-Z][A-Z0-9]*$/) {
$saw_sig++;
unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
print "Installing handler $handler for $_\n" if $Verbose;
$SIG{$_} = $handler;
}
}
elsif ($_ eq 'normal-signals') {
unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
}
elsif ($_ eq 'error-signals') {
unshift @_, grep(exists $SIG{$_},
qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
}
elsif ($_ eq 'old-interface-signals') {
unshift @_,
grep(exists $SIG{$_},
qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
}
elsif ($_ eq 'stack-trace') {
$handler = \&handler_traceback;
}
elsif ($_ eq 'die') {
$handler = \&handler_die;
}
elsif ($_ eq 'handler') {
@_ or croak "No argument specified after 'handler'";
$handler = shift;
unless (ref $handler or $handler eq 'IGNORE'
or $handler eq 'DEFAULT') {
require Symbol;
$handler = Symbol::qualify($handler, (caller)[0]);
}
}
elsif ($_ eq 'untrapped') {
$untrapped = 1;
}
elsif ($_ eq 'any') {
$untrapped = 0;
}
elsif ($_ =~ /^\d/) {
$VERSION >= $_ or croak "sigtrap.pm version $_ required,"
. " but this is only version $VERSION";
}
else {
croak "Unrecognized argument $_";
}
}
unless ($saw_sig) {
@_ = qw(old-interface-signals);
goto Arg_loop;
}
}
sub handler_die {
croak "Caught a SIG$_[0]";
}
sub handler_traceback {
package DB; # To get subroutine args.
my $use_print;
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
# This function might be called as an unsafe signal handler, so it
# tries to delay any memory allocations as long as possible.
#
# Unfortunately with PerlIO layers, using syswrite() here has always
# been broken.
#
# Calling PerlIO::get_layers() here is tempting, but that does
# allocations, which we're trying to avoid for this early code.
if (eval { syswrite(STDERR, 'Caught a SIG', 12); 1 }) {
syswrite(STDERR, $_[0], length($_[0]));
syswrite(STDERR, ' at ', 4);
}
else {
print STDERR 'Caught a SIG', $_[0], ' at ';
++$use_print;
}
($pack,$file,$line) = caller;
unless ($use_print) {
syswrite(STDERR, $file, length($file));
syswrite(STDERR, ' line ', 6);
syswrite(STDERR, $line, length($line));
syswrite(STDERR, "\n", 1);
}
else {
print STDERR $file, ' line ', $line, "\n";
}
# we've got our basic output done, from now on we can be freer with allocations
# find out whether we have any layers we need to worry about
unless ($use_print) {
my @layers = PerlIO::get_layers(*STDERR);
for my $name (@layers) {
unless ($name =~ /^(unix|perlio)$/) {
++$use_print;
last;
}
}
}
# Now go for broke.
for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
@a = ();
for (@{[@args]}) {
s/([\'\\])/\\$1/g;
s/([^\0]*)/'$1'/
unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
require 'meta_notation.pm';
$_ = _meta_notation($_) if /[[:^print:]]/a;
push(@a, $_);
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
$e =~ s/\n\s*\;\s*\Z// if $e;
$e =~ s/[\\\']/\\$1/g if $e;
if ($r) {
$s = "require '$e'";
} elsif (defined $r) {
$s = "eval '$e'";
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
$f = "file '$f'" unless $f eq '-e';
$mess = "$w$s$a called from $f line $l\n";
if ($use_print) {
print STDERR $mess;
}
else {
syswrite(STDERR, $mess, length($mess));
}
}
kill 'ABRT', $$;
}
1;
__END__
=head1 SYNOPSIS
use sigtrap;
use sigtrap qw(stack-trace old-interface-signals); # equivalent
use sigtrap qw(BUS SEGV PIPE ABRT);
use sigtrap qw(die INT QUIT);
use sigtrap qw(die normal-signals);
use sigtrap qw(die untrapped normal-signals);
use sigtrap qw(die untrapped normal-signals
stack-trace any error-signals);
use sigtrap 'handler' => \&my_handler, 'normal-signals';
use sigtrap qw(handler my_handler normal-signals
stack-trace error-signals);
=head1 DESCRIPTION
The B
pragma is a simple interface to installing signal
handlers. You can have it install one of two handlers supplied by
B itself (one which provides a Perl stack trace and one which
simply Cs), or alternately you can supply your own handler for it
to install. It can be told only to install a handler for signals which
are either untrapped or ignored. It has three lists of signals to
trap, plus you can supply your own list of signals.
The arguments passed to the C