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.04; 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 $SIG{'ABRT'} = DEFAULT; 85 kill 'ABRT', $$ if $panic++; 86 syswrite(STDERR, 'Caught a SIG', 12); 87 syswrite(STDERR, $_[0], length($_[0])); 88 syswrite(STDERR, ' at ', 4); 89 ($pack,$file,$line) = caller; 90 syswrite(STDERR, $file, length($file)); 91 syswrite(STDERR, ' line ', 6); 92 syswrite(STDERR, $line, length($line)); 93 syswrite(STDERR, "\n", 1); 94 95 # Now go for broke. 96 for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { 97 @a = (); 98 for (@args) { 99 s/([\'\\])/\\$1/g; 100 s/([^\0]*)/'$1'/ 101 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; 102 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; 103 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; 104 push(@a, $_); 105 } 106 $w = $w ? '@ = ' : '$ = '; 107 $a = $h ? '(' . join(', ', @a) . ')' : ''; 108 $e =~ s/\n\s*\;\s*\Z// if $e; 109 $e =~ s/[\\\']/\\$1/g if $e; 110 if ($r) { 111 $s = "require '$e'"; 112 } elsif (defined $r) { 113 $s = "eval '$e'"; 114 } elsif ($s eq '(eval)') { 115 $s = "eval {...}"; 116 } 117 $f = "file `$f'" unless $f eq '-e'; 118 $mess = "$w$s$a called from $f line $l\n"; 119 syswrite(STDERR, $mess, length($mess)); 120 } 121 kill 'ABRT', $$; 122} 123 1241; 125 126__END__ 127 128=head1 SYNOPSIS 129 130 use sigtrap; 131 use sigtrap qw(stack-trace old-interface-signals); # equivalent 132 use sigtrap qw(BUS SEGV PIPE ABRT); 133 use sigtrap qw(die INT QUIT); 134 use sigtrap qw(die normal-signals); 135 use sigtrap qw(die untrapped normal-signals); 136 use sigtrap qw(die untrapped normal-signals 137 stack-trace any error-signals); 138 use sigtrap 'handler' => \&my_handler, 'normal-signals'; 139 use sigtrap qw(handler my_handler normal-signals 140 stack-trace error-signals); 141 142=head1 DESCRIPTION 143 144The B<sigtrap> pragma is a simple interface to installing signal 145handlers. You can have it install one of two handlers supplied by 146B<sigtrap> itself (one which provides a Perl stack trace and one which 147simply C<die()>s), or alternately you can supply your own handler for it 148to install. It can be told only to install a handler for signals which 149are either untrapped or ignored. It has a couple of lists of signals to 150trap, plus you can supply your own list of signals. 151 152The arguments passed to the C<use> statement which invokes B<sigtrap> 153are processed in order. When a signal name or the name of one of 154B<sigtrap>'s signal lists is encountered a handler is immediately 155installed, when an option is encountered it affects subsequently 156installed handlers. 157 158=head1 OPTIONS 159 160=head2 SIGNAL HANDLERS 161 162These options affect which handler will be used for subsequently 163installed signals. 164 165=over 4 166 167=item B<stack-trace> 168 169The handler used for subsequently installed signals outputs a Perl stack 170trace to STDERR and then tries to dump core. This is the default signal 171handler. 172 173=item B<die> 174 175The handler used for subsequently installed signals calls C<die> 176(actually C<croak>) with a message indicating which signal was caught. 177 178=item B<handler> I<your-handler> 179 180I<your-handler> will be used as the handler for subsequently installed 181signals. I<your-handler> can be any value which is valid as an 182assignment to an element of C<%SIG>. See L<perlvar> for examples of 183handler functions. 184 185=back 186 187=head2 SIGNAL LISTS 188 189B<sigtrap> has a few built-in lists of signals to trap. They are: 190 191=over 4 192 193=item B<normal-signals> 194 195These are the signals which a program might normally expect to encounter 196and which by default cause it to terminate. They are HUP, INT, PIPE and 197TERM. 198 199=item B<error-signals> 200 201These signals usually indicate a serious problem with the Perl 202interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, 203QUIT, SEGV, SYS and TRAP. 204 205=item B<old-interface-signals> 206 207These are the signals which were trapped by default by the old 208B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, 209SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to 210B<sigtrap>, this list is used. 211 212=back 213 214For each of these three lists, the collection of signals set to be 215trapped is checked before trapping; if your architecture does not 216implement a particular signal, it will not be trapped but rather 217silently ignored. 218 219=head2 OTHER 220 221=over 4 222 223=item B<untrapped> 224 225This token tells B<sigtrap> to install handlers only for subsequently 226listed signals which aren't already trapped or ignored. 227 228=item B<any> 229 230This token tells B<sigtrap> to install handlers for all subsequently 231listed signals. This is the default behavior. 232 233=item I<signal> 234 235Any argument which looks like a signal name (that is, 236C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a 237handler for that name. 238 239=item I<number> 240 241Require that at least version I<number> of B<sigtrap> is being used. 242 243=back 244 245=head1 EXAMPLES 246 247Provide a stack trace for the old-interface-signals: 248 249 use sigtrap; 250 251Ditto: 252 253 use sigtrap qw(stack-trace old-interface-signals); 254 255Provide a stack trace on the 4 listed signals only: 256 257 use sigtrap qw(BUS SEGV PIPE ABRT); 258 259Die on INT or QUIT: 260 261 use sigtrap qw(die INT QUIT); 262 263Die on HUP, INT, PIPE or TERM: 264 265 use sigtrap qw(die normal-signals); 266 267Die on HUP, INT, PIPE or TERM, except don't change the behavior for 268signals which are already trapped or ignored: 269 270 use sigtrap qw(die untrapped normal-signals); 271 272Die on receipt one of an of the B<normal-signals> which is currently 273B<untrapped>, provide a stack trace on receipt of B<any> of the 274B<error-signals>: 275 276 use sigtrap qw(die untrapped normal-signals 277 stack-trace any error-signals); 278 279Install my_handler() as the handler for the B<normal-signals>: 280 281 use sigtrap 'handler', \&my_handler, 'normal-signals'; 282 283Install my_handler() as the handler for the normal-signals, provide a 284Perl stack trace on receipt of one of the error-signals: 285 286 use sigtrap qw(handler my_handler normal-signals 287 stack-trace error-signals); 288 289=cut 290