[Summary view] [Print] [Text view]

   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.04;
  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      $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  
 124  1;
 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  
 144  The B<sigtrap> pragma is a simple interface to installing signal
 145  handlers.  You can have it install one of two handlers supplied by
 146  B<sigtrap> itself (one which provides a Perl stack trace and one which
 147  simply C<die()>s), or alternately you can supply your own handler for it
 148  to install.  It can be told only to install a handler for signals which
 149  are either untrapped or ignored.  It has a couple of lists of signals to
 150  trap, plus you can supply your own list of signals.
 151  
 152  The arguments passed to the C<use> statement which invokes B<sigtrap>
 153  are processed in order.  When a signal name or the name of one of
 154  B<sigtrap>'s signal lists is encountered a handler is immediately
 155  installed, when an option is encountered it affects subsequently
 156  installed handlers.
 157  
 158  =head1 OPTIONS
 159  
 160  =head2 SIGNAL HANDLERS
 161  
 162  These options affect which handler will be used for subsequently
 163  installed signals.
 164  
 165  =over 4
 166  
 167  =item B<stack-trace>
 168  
 169  The handler used for subsequently installed signals outputs a Perl stack
 170  trace to STDERR and then tries to dump core.  This is the default signal
 171  handler.
 172  
 173  =item B<die>
 174  
 175  The 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  
 180  I<your-handler> will be used as the handler for subsequently installed
 181  signals.  I<your-handler> can be any value which is valid as an
 182  assignment to an element of C<%SIG>. See L<perlvar> for examples of
 183  handler functions.
 184  
 185  =back
 186  
 187  =head2 SIGNAL LISTS
 188  
 189  B<sigtrap> has a few built-in lists of signals to trap.  They are:
 190  
 191  =over 4
 192  
 193  =item B<normal-signals>
 194  
 195  These are the signals which a program might normally expect to encounter
 196  and which by default cause it to terminate.  They are HUP, INT, PIPE and
 197  TERM.
 198  
 199  =item B<error-signals>
 200  
 201  These signals usually indicate a serious problem with the Perl
 202  interpreter or with your script.  They are ABRT, BUS, EMT, FPE, ILL,
 203  QUIT, SEGV, SYS and TRAP.
 204  
 205  =item B<old-interface-signals>
 206  
 207  These are the signals which were trapped by default by the old
 208  B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
 209  SEGV, SYS, TERM, and TRAP.  If no signals or signals lists are passed to
 210  B<sigtrap>, this list is used.
 211  
 212  =back
 213  
 214  For each of these three lists, the collection of signals set to be
 215  trapped is checked before trapping; if your architecture does not
 216  implement a particular signal, it will not be trapped but rather
 217  silently ignored.
 218  
 219  =head2 OTHER
 220  
 221  =over 4
 222  
 223  =item B<untrapped>
 224  
 225  This token tells B<sigtrap> to install handlers only for subsequently
 226  listed signals which aren't already trapped or ignored.
 227  
 228  =item B<any>
 229  
 230  This token tells B<sigtrap> to install handlers for all subsequently
 231  listed signals.  This is the default behavior.
 232  
 233  =item I<signal>
 234  
 235  Any argument which looks like a signal name (that is,
 236  C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
 237  handler for that name.
 238  
 239  =item I<number>
 240  
 241  Require that at least version I<number> of B<sigtrap> is being used.
 242  
 243  =back
 244  
 245  =head1 EXAMPLES
 246  
 247  Provide a stack trace for the old-interface-signals:
 248  
 249      use sigtrap;
 250  
 251  Ditto:
 252  
 253      use sigtrap qw(stack-trace old-interface-signals);
 254  
 255  Provide a stack trace on the 4 listed signals only:
 256  
 257      use sigtrap qw(BUS SEGV PIPE ABRT);
 258  
 259  Die on INT or QUIT:
 260  
 261      use sigtrap qw(die INT QUIT);
 262  
 263  Die on HUP, INT, PIPE or TERM:
 264  
 265      use sigtrap qw(die normal-signals);
 266  
 267  Die on HUP, INT, PIPE or TERM, except don't change the behavior for
 268  signals which are already trapped or ignored:
 269  
 270      use sigtrap qw(die untrapped normal-signals);
 271  
 272  Die on receipt one of an of the B<normal-signals> which is currently
 273  B<untrapped>, provide a stack trace on receipt of B<any> of the
 274  B<error-signals>:
 275  
 276      use sigtrap qw(die untrapped normal-signals
 277              stack-trace any error-signals);
 278  
 279  Install my_handler() as the handler for the B<normal-signals>:
 280  
 281      use sigtrap 'handler', \&my_handler, 'normal-signals';
 282  
 283  Install my_handler() as the handler for the normal-signals, provide a
 284  Perl 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