This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.003_01: lib/perl5db.pl
[perl5.git] / lib / sigtrap.pm
CommitLineData
a0d0e21e
LW
1package sigtrap;
2
f06db76b
AD
3=head1 NAME
4
5sigtrap - 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
14The C<sigtrap> pragma initializes some default signal handlers that print
15a stack dump of your Perl program, then sends itself a SIGABRT. This
16provides a nice starting point if something horrible goes wrong.
17
18By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE,
19QUIT, SEGV, SYS, TERM, and TRAP signals.
20
21See L<perlmod/Pragmatic Modules>.
22
23=cut
24
a0d0e21e
LW
25require Carp;
26
27sub 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
36sub 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
LW
52 for $arg (@args) {
53 $_ = "$arg";
d338d6fe 54 s/([\'\\])/\\$1/g;
a0d0e21e 55 s/([^\0]*)/'$1'/
d338d6fe 56 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
a0d0e21e
LW
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
LW
73 $mess = "$w$s$a called from $f line $l\n";
74 syswrite(STDERR, $mess, length($mess));
75 }
76 kill 'ABRT', $$;
77}
78
791;