lib/sigtrap.pm

   1 package sigtrap;
   2
   3 =head1 NAME
   4
   5 sigtrap - Perl pragma to enable simple signal handling
   6
   7 =cut
   8
   9 use Carp;
  10
  11 $VERSION = '1.10';
  12 $Verbose ||= 0;
  13
  14 sub 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
  78 sub handler_die {
  79     croak "Caught a SIG$_[0]";
  80 }
  81
  82 sub 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
 162 1;
 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
 182 The B<sigtrap> pragma is a simple interface to installing signal
 183 handlers.  You can have it install one of two handlers supplied by
 184 B<sigtrap> itself (one which provides a Perl stack trace and one which
 185 simply C<die()>s), or alternately you can supply your own handler for it
 186 to install.  It can be told only to install a handler for signals which
 187 are either untrapped or ignored.  It has three lists of signals to
 188 trap, plus you can supply your own list of signals.
 189
 190 The arguments passed to the C<use> statement which invokes B<sigtrap>
 191 are processed in order.  When a signal name or the name of one of
 192 B<sigtrap>'s signal lists is encountered a handler is immediately
 193 installed, when an option is encountered it affects subsequently
 194 installed handlers.
 195
 196 =head1 OPTIONS
 197
 198 =head2 SIGNAL HANDLERS
 199
 200 These options affect which handler will be used for subsequently
 201 installed signals.
 202
 203 =over 4
 204
 205 =item B<stack-trace>
 206
 207 The handler used for subsequently installed signals outputs a Perl stack
 208 trace to STDERR and then tries to dump core.  This is the default signal
 209 handler.
 210
 211 =item B<die>
 212
 213 The 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
 218 I<your-handler> will be used as the handler for subsequently installed
 219 signals.  I<your-handler> can be any value which is valid as an
 220 assignment to an element of C<%SIG>. See L<perlvar> for examples of
 221 handler functions.
 222
 223 =back
 224
 225 =head2 SIGNAL LISTS
 226
 227 B<sigtrap> has a few built-in lists of signals to trap.  They are:
 228
 229 =over 4
 230
 231 =item B<normal-signals>
 232
 233 These are the signals which a program might normally expect to encounter
 234 and which by default cause it to terminate.  They are HUP, INT, PIPE and
 235 TERM.
 236
 237 =item B<error-signals>
 238
 239 These signals usually indicate a serious problem with the Perl
 240 interpreter or with your script.  They are ABRT, BUS, EMT, FPE, ILL,
 241 QUIT, SEGV, SYS and TRAP.
 242
 243 =item B<old-interface-signals>
 244
 245 These are the signals which were trapped by default by the old
 246 B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
 247 SEGV, SYS, TERM, and TRAP.  If no signals or signals lists are passed to
 248 B<sigtrap>, this list is used.
 249
 250 =back
 251
 252 For each of these three lists, the collection of signals set to be
 253 trapped is checked before trapping; if your architecture does not
 254 implement a particular signal, it will not be trapped but rather
 255 silently ignored.
 256
 257 =head2 OTHER
 258
 259 =over 4
 260
 261 =item B<untrapped>
 262
 263 This token tells B<sigtrap> to install handlers only for subsequently
 264 listed signals which aren't already trapped or ignored.
 265
 266 =item B<any>
 267
 268 This token tells B<sigtrap> to install handlers for all subsequently
 269 listed signals.  This is the default behavior.
 270
 271 =item I<signal>
 272
 273 Any argument which looks like a signal name (that is,
 274 C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
 275 handler for that name.
 276
 277 =item I<number>
 278
 279 Require that at least version I<number> of B<sigtrap> is being used.
 280
 281 =back
 282
 283 =head1 EXAMPLES
 284
 285 Provide a stack trace for the old-interface-signals:
 286
 287     use sigtrap;
 288
 289 Ditto:
 290
 291     use sigtrap qw(stack-trace old-interface-signals);
 292
 293 Provide a stack trace on the 4 listed signals only:
 294
 295     use sigtrap qw(BUS SEGV PIPE ABRT);
 296
 297 Die on INT or QUIT:
 298
 299     use sigtrap qw(die INT QUIT);
 300
 301 Die on HUP, INT, PIPE or TERM:
 302
 303     use sigtrap qw(die normal-signals);
 304
 305 Die on HUP, INT, PIPE or TERM, except don't change the behavior for
 306 signals which are already trapped or ignored:
 307
 308     use sigtrap qw(die untrapped normal-signals);
 309
 310 Die on receipt one of any of the B<normal-signals> which is currently
 311 B<untrapped>, provide a stack trace on receipt of B<any> of the
 312 B<error-signals>:
 313
 314     use sigtrap qw(die untrapped normal-signals
 315                     stack-trace any error-signals);
 316
 317 Install my_handler() as the handler for the B<normal-signals>:
 318
 319     use sigtrap 'handler', \&my_handler, 'normal-signals';
 320
 321 Install my_handler() as the handler for the normal-signals, provide a
 322 Perl 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