lib/sigtrap.pm

   1 package sigtrap;
   2
   3 =head1 NAME
   4
   5 sigtrap - Perl pragma to enable stack backtrace on unexpected signals
   6
   7 =head1 SYNOPSIS
   8
   9     use sigtrap;
  10     use sigtrap qw(BUS SEGV PIPE SYS ABRT TRAP);
  11
  12 =head1 DESCRIPTION
  13
  14 The C<sigtrap> pragma initializes some default signal handlers that print
  15 a stack dump of your Perl program, then sends itself a SIGABRT.  This
  16 provides a nice starting point if something horrible goes wrong.
  17
  18 By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE,
  19 QUIT, SEGV, SYS, TERM, and TRAP signals.
  20
  21 See L<perlmod/Pragmatic Modules>.
  22
  23 =cut
  24
  25 require Carp;
  26
  27 sub import {
  28     my $pack = shift;
  29     my @sigs = @_;
  30     @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM);
  31     foreach $sig (@sigs) {
  32         $SIG{$sig} = 'sigtrap::trap';
  33     }
  34 }
  35
  36 sub trap {
  37     package DB;         # To get subroutine args.
  38     $SIG{'ABRT'} = DEFAULT;
  39     kill 'ABRT', $$ if $panic++;
  40     syswrite(STDERR, 'Caught a SIG', 12);
  41     syswrite(STDERR, $_[0], length($_[0]));
  42     syswrite(STDERR, ' at ', 4);
  43     ($pack,$file,$line) = caller;
  44     syswrite(STDERR, $file, length($file));
  45     syswrite(STDERR, ' line ', 6);
  46     syswrite(STDERR, $line, length($line));
  47     syswrite(STDERR, "\n", 1);
  48
  49     # Now go for broke.
  50     for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  51         @a = ();
  52         for $arg (@args) {
  53             $_ = "$arg";
  54             s/'/\\'/g;
  55             s/([^\0]*)/'$1'/
  56                 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  57             s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  58             s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  59             push(@a, $_);
  60         }
  61         $w = $w ? '@ = ' : '$ = ';
  62         $a = $h ? '(' . join(', ', @a) . ')' : '';
  63         $mess = "$w$s$a called from $f line $l\n";
  64         syswrite(STDERR, $mess, length($mess));
  65     }
  66     kill 'ABRT', $$;
  67 }
  68
  69 1;