sigtrap.pm revision 1.4
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.06; 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 my $fr (@args) { 99 my $_ = $fr; 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>. See L<perlvar> for examples of 184handler functions. 185 186=back 187 188=head2 SIGNAL LISTS 189 190B<sigtrap> has a few built-in lists of signals to trap. They are: 191 192=over 4 193 194=item B<normal-signals> 195 196These are the signals which a program might normally expect to encounter 197and which by default cause it to terminate. They are HUP, INT, PIPE and 198TERM. 199 200=item B<error-signals> 201 202These signals usually indicate a serious problem with the Perl 203interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, 204QUIT, SEGV, SYS and TRAP. 205 206=item B<old-interface-signals> 207 208These are the signals which were trapped by default by the old 209B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, 210SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to 211B<sigtrap>, this list is used. 212 213=back 214 215For each of these three lists, the collection of signals set to be 216trapped is checked before trapping; if your architecture does not 217implement a particular signal, it will not be trapped but rather 218silently ignored. 219 220=head2 OTHER 221 222=over 4 223 224=item B<untrapped> 225 226This token tells B<sigtrap> to install handlers only for subsequently 227listed signals which aren't already trapped or ignored. 228 229=item B<any> 230 231This token tells B<sigtrap> to install handlers for all subsequently 232listed signals. This is the default behavior. 233 234=item I<signal> 235 236Any argument which looks like a signal name (that is, 237C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a 238handler for that name. 239 240=item I<number> 241 242Require that at least version I<number> of B<sigtrap> is being used. 243 244=back 245 246=head1 EXAMPLES 247 248Provide a stack trace for the old-interface-signals: 249 250 use sigtrap; 251 252Ditto: 253 254 use sigtrap qw(stack-trace old-interface-signals); 255 256Provide a stack trace on the 4 listed signals only: 257 258 use sigtrap qw(BUS SEGV PIPE ABRT); 259 260Die on INT or QUIT: 261 262 use sigtrap qw(die INT QUIT); 263 264Die on HUP, INT, PIPE or TERM: 265 266 use sigtrap qw(die normal-signals); 267 268Die on HUP, INT, PIPE or TERM, except don't change the behavior for 269signals which are already trapped or ignored: 270 271 use sigtrap qw(die untrapped normal-signals); 272 273Die on receipt one of an of the B<normal-signals> which is currently 274B<untrapped>, provide a stack trace on receipt of B<any> of the 275B<error-signals>: 276 277 use sigtrap qw(die untrapped normal-signals 278 stack-trace any error-signals); 279 280Install my_handler() as the handler for the B<normal-signals>: 281 282 use sigtrap 'handler', \&my_handler, 'normal-signals'; 283 284Install my_handler() as the handler for the normal-signals, provide a 285Perl stack trace on receipt of one of the error-signals: 286 287 use sigtrap qw(handler my_handler normal-signals 288 stack-trace error-signals); 289 290=cut 291