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.02; 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 $arg (@args) { 99 $_ = "$arg"; 100 s/([\'\\])/\\$1/g; 101 s/([^\0]*)/'$1'/ 102 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; 103 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; 104 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; 105 push(@a, $_); 106 } 107 $w = $w ? '@ = ' : '$ = '; 108 $a = $h ? '(' . join(', ', @a) . ')' : ''; 109 $e =~ s/\n\s*\;\s*\Z// if $e; 110 $e =~ s/[\\\']/\\$1/g if $e; 111 if ($r) { 112 $s = "require '$e'"; 113 } elsif (defined $r) { 114 $s = "eval '$e'"; 115 } elsif ($s eq '(eval)') { 116 $s = "eval {...}"; 117 } 118 $f = "file `$f'" unless $f eq '-e'; 119 $mess = "$w$s$a called from $f line $l\n"; 120 syswrite(STDERR, $mess, length($mess)); 121 } 122 kill 'ABRT', $$; 123} 124 1251; 126 127__END__ 128 129=head1 SYNOPSIS 130 131 use sigtrap; 132 use sigtrap qw(stack-trace old-interface-signals); # equivalent 133 use sigtrap qw(BUS SEGV PIPE ABRT); 134 use sigtrap qw(die INT QUIT); 135 use sigtrap qw(die normal-signals); 136 use sigtrap qw(die untrapped normal-signals); 137 use sigtrap qw(die untrapped normal-signals 138 stack-trace any error-signals); 139 use sigtrap 'handler' => \&my_handler, 'normal-signals'; 140 use sigtrap qw(handler my_handler normal-signals 141 stack-trace error-signals); 142 143=head1 DESCRIPTION 144 145The B<sigtrap> pragma is a simple interface to installing signal 146handlers. You can have it install one of two handlers supplied by 147B<sigtrap> itself (one which provides a Perl stack trace and one which 148simply C<die()>s), or alternately you can supply your own handler for it 149to install. It can be told only to install a handler for signals which 150are either untrapped or ignored. It has a couple of lists of signals to 151trap, plus you can supply your own list of signals. 152 153The arguments passed to the C<use> statement which invokes B<sigtrap> 154are processed in order. When a signal name or the name of one of 155B<sigtrap>'s signal lists is encountered a handler is immediately 156installed, when an option is encountered it affects subsequently 157installed handlers. 158 159=head1 OPTIONS 160 161=head2 SIGNAL HANDLERS 162 163These options affect which handler will be used for subsequently 164installed signals. 165 166=over 4 167 168=item B<stack-trace> 169 170The handler used for subsequently installed signals outputs a Perl stack 171trace to STDERR and then tries to dump core. This is the default signal 172handler. 173 174=item B<die> 175 176The handler used for subsequently installed signals calls C<die> 177(actually C<croak>) with a message indicating which signal was caught. 178 179=item B<handler> I<your-handler> 180 181I<your-handler> will be used as the handler for subsequently installed 182signals. I<your-handler> can be any value which is valid as an 183assignment to an element of C<%SIG>. 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