sigtrap.pm revision 1.8
1package sigtrap; 2 3=head1 NAME 4 5sigtrap - Perl pragma to enable simple signal handling 6 7=cut 8 9use Carp; 10 11$VERSION = '1.10'; 12$Verbose ||= 0; 13 14sub import { 15 my $pkg = shift; 16 my $handler = \&handler_traceback; 17 my $saw_sig = 0; 18 my $untrapped = 0; 19 local $_; 20 21 Arg_loop: 22 while (@_) { 23 $_ = shift; 24 if (/^[A-Z][A-Z0-9]*$/) { 25 $saw_sig++; 26 unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') { 27 print "Installing handler $handler for $_\n" if $Verbose; 28 $SIG{$_} = $handler; 29 } 30 } 31 elsif ($_ eq 'normal-signals') { 32 unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); 33 } 34 elsif ($_ eq 'error-signals') { 35 unshift @_, grep(exists $SIG{$_}, 36 qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); 37 } 38 elsif ($_ eq 'old-interface-signals') { 39 unshift @_, 40 grep(exists $SIG{$_}, 41 qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); 42 } 43 elsif ($_ eq 'stack-trace') { 44 $handler = \&handler_traceback; 45 } 46 elsif ($_ eq 'die') { 47 $handler = \&handler_die; 48 } 49 elsif ($_ eq 'handler') { 50 @_ or croak "No argument specified after 'handler'"; 51 $handler = shift; 52 unless (ref $handler or $handler eq 'IGNORE' 53 or $handler eq 'DEFAULT') { 54 require Symbol; 55 $handler = Symbol::qualify($handler, (caller)[0]); 56 } 57 } 58 elsif ($_ eq 'untrapped') { 59 $untrapped = 1; 60 } 61 elsif ($_ eq 'any') { 62 $untrapped = 0; 63 } 64 elsif ($_ =~ /^\d/) { 65 $VERSION >= $_ or croak "sigtrap.pm version $_ required," 66 . " but this is only version $VERSION"; 67 } 68 else { 69 croak "Unrecognized argument $_"; 70 } 71 } 72 unless ($saw_sig) { 73 @_ = qw(old-interface-signals); 74 goto Arg_loop; 75 } 76} 77 78sub handler_die { 79 croak "Caught a SIG$_[0]"; 80} 81 82sub handler_traceback { 83 package DB; # To get subroutine args. 84 my $use_print; 85 $SIG{'ABRT'} = DEFAULT; 86 kill 'ABRT', $$ if $panic++; 87 88 # This function might be called as an unsafe signal handler, so it 89 # tries to delay any memory allocations as long as possible. 90 # 91 # Unfortunately with PerlIO layers, using syswrite() here has always 92 # been broken. 93 # 94 # Calling PerlIO::get_layers() here is tempting, but that does 95 # allocations, which we're trying to avoid for this early code. 96 if (eval { syswrite(STDERR, 'Caught a SIG', 12); 1 }) { 97 syswrite(STDERR, $_[0], length($_[0])); 98 syswrite(STDERR, ' at ', 4); 99 } 100 else { 101 print STDERR 'Caught a SIG', $_[0], ' at '; 102 ++$use_print; 103 } 104 105 ($pack,$file,$line) = caller; 106 unless ($use_print) { 107 syswrite(STDERR, $file, length($file)); 108 syswrite(STDERR, ' line ', 6); 109 syswrite(STDERR, $line, length($line)); 110 syswrite(STDERR, "\n", 1); 111 } 112 else { 113 print STDERR $file, ' line ', $line, "\n"; 114 } 115 116 # we've got our basic output done, from now on we can be freer with allocations 117 # find out whether we have any layers we need to worry about 118 unless ($use_print) { 119 my @layers = PerlIO::get_layers(*STDERR); 120 for my $name (@layers) { 121 unless ($name =~ /^(unix|perlio)$/) { 122 ++$use_print; 123 last; 124 } 125 } 126 } 127 128 # Now go for broke. 129 for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { 130 @a = (); 131 for (@{[@args]}) { 132 s/([\'\\])/\\$1/g; 133 s/([^\0]*)/'$1'/ 134 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; 135 require 'meta_notation.pm'; 136 $_ = _meta_notation($_) if /[[:^print:]]/a; 137 push(@a, $_); 138 } 139 $w = $w ? '@ = ' : '$ = '; 140 $a = $h ? '(' . join(', ', @a) . ')' : ''; 141 $e =~ s/\n\s*\;\s*\Z// if $e; 142 $e =~ s/[\\\']/\\$1/g if $e; 143 if ($r) { 144 $s = "require '$e'"; 145 } elsif (defined $r) { 146 $s = "eval '$e'"; 147 } elsif ($s eq '(eval)') { 148 $s = "eval {...}"; 149 } 150 $f = "file '$f'" unless $f eq '-e'; 151 $mess = "$w$s$a called from $f line $l\n"; 152 if ($use_print) { 153 print STDERR $mess; 154 } 155 else { 156 syswrite(STDERR, $mess, length($mess)); 157 } 158 } 159 kill 'ABRT', $$; 160} 161 1621; 163 164__END__ 165 166=head1 SYNOPSIS 167 168 use sigtrap; 169 use sigtrap qw(stack-trace old-interface-signals); # equivalent 170 use sigtrap qw(BUS SEGV PIPE ABRT); 171 use sigtrap qw(die INT QUIT); 172 use sigtrap qw(die normal-signals); 173 use sigtrap qw(die untrapped normal-signals); 174 use sigtrap qw(die untrapped normal-signals 175 stack-trace any error-signals); 176 use sigtrap 'handler' => \&my_handler, 'normal-signals'; 177 use sigtrap qw(handler my_handler normal-signals 178 stack-trace error-signals); 179 180=head1 DESCRIPTION 181 182The B<sigtrap> pragma is a simple interface to installing signal 183handlers. You can have it install one of two handlers supplied by 184B<sigtrap> itself (one which provides a Perl stack trace and one which 185simply C<die()>s), or alternately you can supply your own handler for it 186to install. It can be told only to install a handler for signals which 187are either untrapped or ignored. It has three lists of signals to 188trap, plus you can supply your own list of signals. 189 190The arguments passed to the C<use> statement which invokes B<sigtrap> 191are processed in order. When a signal name or the name of one of 192B<sigtrap>'s signal lists is encountered a handler is immediately 193installed, when an option is encountered it affects subsequently 194installed handlers. 195 196=head1 OPTIONS 197 198=head2 SIGNAL HANDLERS 199 200These options affect which handler will be used for subsequently 201installed signals. 202 203=over 4 204 205=item B<stack-trace> 206 207The handler used for subsequently installed signals outputs a Perl stack 208trace to STDERR and then tries to dump core. This is the default signal 209handler. 210 211=item B<die> 212 213The handler used for subsequently installed signals calls C<die> 214(actually C<croak>) with a message indicating which signal was caught. 215 216=item B<handler> I<your-handler> 217 218I<your-handler> will be used as the handler for subsequently installed 219signals. I<your-handler> can be any value which is valid as an 220assignment to an element of C<%SIG>. See L<perlvar> for examples of 221handler functions. 222 223=back 224 225=head2 SIGNAL LISTS 226 227B<sigtrap> has a few built-in lists of signals to trap. They are: 228 229=over 4 230 231=item B<normal-signals> 232 233These are the signals which a program might normally expect to encounter 234and which by default cause it to terminate. They are HUP, INT, PIPE and 235TERM. 236 237=item B<error-signals> 238 239These signals usually indicate a serious problem with the Perl 240interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, 241QUIT, SEGV, SYS and TRAP. 242 243=item B<old-interface-signals> 244 245These are the signals which were trapped by default by the old 246B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, 247SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to 248B<sigtrap>, this list is used. 249 250=back 251 252For each of these three lists, the collection of signals set to be 253trapped is checked before trapping; if your architecture does not 254implement a particular signal, it will not be trapped but rather 255silently ignored. 256 257=head2 OTHER 258 259=over 4 260 261=item B<untrapped> 262 263This token tells B<sigtrap> to install handlers only for subsequently 264listed signals which aren't already trapped or ignored. 265 266=item B<any> 267 268This token tells B<sigtrap> to install handlers for all subsequently 269listed signals. This is the default behavior. 270 271=item I<signal> 272 273Any argument which looks like a signal name (that is, 274C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a 275handler for that name. 276 277=item I<number> 278 279Require that at least version I<number> of B<sigtrap> is being used. 280 281=back 282 283=head1 EXAMPLES 284 285Provide a stack trace for the old-interface-signals: 286 287 use sigtrap; 288 289Ditto: 290 291 use sigtrap qw(stack-trace old-interface-signals); 292 293Provide a stack trace on the 4 listed signals only: 294 295 use sigtrap qw(BUS SEGV PIPE ABRT); 296 297Die on INT or QUIT: 298 299 use sigtrap qw(die INT QUIT); 300 301Die on HUP, INT, PIPE or TERM: 302 303 use sigtrap qw(die normal-signals); 304 305Die on HUP, INT, PIPE or TERM, except don't change the behavior for 306signals which are already trapped or ignored: 307 308 use sigtrap qw(die untrapped normal-signals); 309 310Die on receipt one of any of the B<normal-signals> which is currently 311B<untrapped>, provide a stack trace on receipt of B<any> of the 312B<error-signals>: 313 314 use sigtrap qw(die untrapped normal-signals 315 stack-trace any error-signals); 316 317Install my_handler() as the handler for the B<normal-signals>: 318 319 use sigtrap 'handler', \&my_handler, 'normal-signals'; 320 321Install my_handler() as the handler for the normal-signals, provide a 322Perl stack trace on receipt of one of the error-signals: 323 324 use sigtrap qw(handler my_handler normal-signals 325 stack-trace error-signals); 326 327=cut 328