Commit | Line | Data |
a0d0e21e |
1 | package sigtrap; |
2 | |
f06db76b |
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 | |
a0d0e21e |
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. |
d338d6fe |
50 | for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { |
51 | @a = (); |
a0d0e21e |
52 | for $arg (@args) { |
53 | $_ = "$arg"; |
d338d6fe |
54 | s/([\'\\])/\\$1/g; |
a0d0e21e |
55 | s/([^\0]*)/'$1'/ |
d338d6fe |
56 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; |
a0d0e21e |
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) . ')' : ''; |
d338d6fe |
63 | $e =~ s/\n\s*\;\s*\Z// if $e; |
64 | $e =~ s/[\\\']/\\$1/g if $e; |
65 | if ($r) { |
66 | $s = "require '$e'"; |
67 | } elsif (defined $r) { |
68 | $s = "eval '$e'"; |
69 | } elsif ($s eq '(eval)') { |
70 | $s = "eval {...}"; |
71 | } |
72 | $f = "file `$f'" unless $f eq '-e'; |
a0d0e21e |
73 | $mess = "$w$s$a called from $f line $l\n"; |
74 | syswrite(STDERR, $mess, length($mess)); |
75 | } |
76 | kill 'ABRT', $$; |
77 | } |
78 | |
79 | 1; |