Commit | Line | Data |
a0d0e21e |
1 | package sigtrap; |
2 | |
f06db76b |
3 | =head1 NAME |
4 | |
1ae80e7e |
5 | sigtrap - Perl pragma to enable simple signal handling |
f06db76b |
6 | |
7 | =cut |
8 | |
1ae80e7e |
9 | use Carp; |
10 | |
11 | $VERSION = 1.01; |
12 | $Verbose ||= 0; |
a0d0e21e |
13 | |
14 | sub import { |
1ae80e7e |
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 @_, qw(HUP INT PIPE TERM); |
33 | } |
34 | elsif ($_ eq 'error-signals') { |
35 | unshift @_, qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP); |
36 | } |
37 | elsif ($_ eq 'old-interface-signals') { |
38 | unshift @_, qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP); |
39 | } |
40 | elsif ($_ eq 'stack-trace') { |
41 | $handler = \&handler_traceback; |
42 | } |
43 | elsif ($_ eq 'die') { |
44 | $handler = \&handler_die; |
45 | } |
46 | elsif ($_ eq 'handler') { |
47 | @_ or croak "No argument specified after 'handler'"; |
48 | $handler = shift; |
49 | unless (ref $handler or $handler eq 'IGNORE' |
50 | or $handler eq 'DEFAULT') { |
51 | require Symbol; |
52 | $handler = Symbol::qualify($handler, (caller)[0]); |
53 | } |
54 | } |
55 | elsif ($_ eq 'untrapped') { |
56 | $untrapped = 1; |
57 | } |
58 | elsif ($_ eq 'any') { |
59 | $untrapped = 0; |
60 | } |
61 | elsif ($_ =~ /^\d/) { |
62 | $VERSION >= $_ or croak "sigtrap.pm version $_ required," |
63 | . " but this is only version $VERSION"; |
64 | } |
65 | else { |
66 | croak "Unrecognized argument $_"; |
67 | } |
a0d0e21e |
68 | } |
1ae80e7e |
69 | unless ($saw_sig) { |
70 | @_ = qw(old-interface-signals); |
71 | goto Arg_loop; |
72 | } |
73 | } |
74 | |
75 | sub handler_die { |
76 | croak "Caught a SIG$_[0]"; |
a0d0e21e |
77 | } |
78 | |
1ae80e7e |
79 | sub handler_traceback { |
a0d0e21e |
80 | package DB; # To get subroutine args. |
81 | $SIG{'ABRT'} = DEFAULT; |
82 | kill 'ABRT', $$ if $panic++; |
83 | syswrite(STDERR, 'Caught a SIG', 12); |
84 | syswrite(STDERR, $_[0], length($_[0])); |
85 | syswrite(STDERR, ' at ', 4); |
86 | ($pack,$file,$line) = caller; |
87 | syswrite(STDERR, $file, length($file)); |
88 | syswrite(STDERR, ' line ', 6); |
89 | syswrite(STDERR, $line, length($line)); |
90 | syswrite(STDERR, "\n", 1); |
91 | |
92 | # Now go for broke. |
d338d6fe |
93 | for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { |
94 | @a = (); |
a0d0e21e |
95 | for $arg (@args) { |
96 | $_ = "$arg"; |
d338d6fe |
97 | s/([\'\\])/\\$1/g; |
a0d0e21e |
98 | s/([^\0]*)/'$1'/ |
d338d6fe |
99 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; |
a0d0e21e |
100 | s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; |
101 | s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; |
102 | push(@a, $_); |
103 | } |
104 | $w = $w ? '@ = ' : '$ = '; |
105 | $a = $h ? '(' . join(', ', @a) . ')' : ''; |
d338d6fe |
106 | $e =~ s/\n\s*\;\s*\Z// if $e; |
107 | $e =~ s/[\\\']/\\$1/g if $e; |
108 | if ($r) { |
109 | $s = "require '$e'"; |
110 | } elsif (defined $r) { |
111 | $s = "eval '$e'"; |
112 | } elsif ($s eq '(eval)') { |
113 | $s = "eval {...}"; |
114 | } |
115 | $f = "file `$f'" unless $f eq '-e'; |
a0d0e21e |
116 | $mess = "$w$s$a called from $f line $l\n"; |
117 | syswrite(STDERR, $mess, length($mess)); |
118 | } |
119 | kill 'ABRT', $$; |
120 | } |
121 | |
122 | 1; |
1ae80e7e |
123 | |
124 | __END__ |
125 | |
126 | =head1 SYNOPSIS |
127 | |
128 | use sigtrap; |
129 | use sigtrap qw(stack-trace old-interface-signals); # equivalent |
130 | use sigtrap qw(BUS SEGV PIPE ABRT); |
131 | use sigtrap qw(die INT QUIT); |
132 | use sigtrap qw(die normal-signals); |
133 | use sigtrap qw(die untrapped normal-signals); |
134 | use sigtrap qw(die untrapped normal-signals |
135 | stack-trace any error-signals); |
136 | use sigtrap 'handler' => \&my_handler, 'normal-signals'; |
137 | use sigtrap qw(handler my_handler normal-signals |
138 | stack-trace error-signals); |
139 | |
140 | =head1 DESCRIPTION |
141 | |
142 | The B<sigtrap> pragma is a simple interface to installing signal |
143 | handlers. You can have it install one of two handlers supplied by |
144 | B<sigtrap> itself (one which provides a Perl stack trace and one which |
145 | simply C<die()>s), or alternately you can supply your own handler for it |
146 | to install. It can be told only to install a handler for signals which |
147 | are either untrapped or ignored. It has a couple of lists of signals to |
148 | trap, plus you can supply your own list of signals. |
149 | |
150 | The arguments passed to the C<use> statement which invokes B<sigtrap> |
151 | are processed in order. When a signal name or the name of one of |
152 | B<sigtrap>'s signal lists is encountered a handler is immediately |
153 | installed, when an option is encountered it affects subsequently |
154 | installed handlers. |
155 | |
156 | =head1 OPTIONS |
157 | |
158 | =head2 SIGNAL HANDLERS |
159 | |
160 | These options affect which handler will be used for subsequently |
161 | installed signals. |
162 | |
84dc3c4d |
163 | =over 4 |
1ae80e7e |
164 | |
165 | =item B<stack-trace> |
166 | |
167 | The handler used for subsequently installed signals will output a Perl |
168 | stack trace to STDERR and then tries to dump core. This is the default |
169 | signal handler. |
170 | |
171 | =item B<die> |
172 | |
173 | The handler used for subsequently installed signals calls C<die> |
174 | (actually C<croak>) with a message indicating which signal was caught. |
175 | |
176 | =item B<handler> I<your-handler> |
177 | |
178 | I<your-handler> will be used as the handler for subsequently installed |
179 | signals. I<your-handler> can be any value which is valid as an |
180 | assignment to an element of C<%SIG>. |
181 | |
182 | =back |
183 | |
184 | =head2 SIGNAL LISTS |
185 | |
186 | B<sigtrap> has two built-in lists of signals to trap. They are: |
187 | |
84dc3c4d |
188 | =over 4 |
1ae80e7e |
189 | |
190 | =item B<normal-signals> |
191 | |
192 | These are the signals which a program might normally expect to encounter |
193 | and which by default cause it to terminate. They are HUP, INT, PIPE and |
194 | TERM. |
195 | |
196 | =item B<error-signals> |
197 | |
198 | These signals usually indicate a serious problem with the Perl |
199 | interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, |
200 | QUIT, SEGV, SYS and TRAP. |
201 | |
202 | =item B<old-interface-signals> |
203 | |
204 | These are the signals which were trapped by default by the old |
205 | B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, |
206 | SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to |
207 | B<sigtrap> this list is used. |
208 | |
209 | =back |
210 | |
211 | =head2 OTHER |
212 | |
84dc3c4d |
213 | =over 4 |
214 | |
1ae80e7e |
215 | =item B<untrapped> |
216 | |
217 | This token tells B<sigtrap> only to install handlers for subsequently |
218 | listed signals which aren't already trapped or ignored. |
219 | |
220 | =item B<any> |
221 | |
222 | This token tells B<sigtrap> to install handlers for all subsequently |
223 | listed signals. This is the default behavior. |
224 | |
225 | =item I<signal> |
226 | |
227 | Any argument which looks like a signals name (that is, |
228 | C</^[A-Z][A-Z0-9]*$/>) is taken as a signal name and indicates that |
229 | B<sigtrap> should install a handler for it. |
230 | |
231 | =item I<number> |
232 | |
233 | Require that at least version I<number> of B<sigtrap> is being used. |
234 | |
235 | =back |
236 | |
237 | =head1 EXAMPLES |
238 | |
239 | Provide a stack trace for the old-interface-signals: |
240 | |
241 | use sigtrap; |
242 | |
243 | Ditto: |
244 | |
245 | use sigtrap qw(stack-trace old-interface-signals); |
246 | |
247 | Provide a stack trace on the 4 listed signals only: |
248 | |
249 | use sigtrap qw(BUS SEGV PIPE ABRT); |
250 | |
251 | Die on INT or QUIT: |
252 | |
253 | use sigtrap qw(die INT QUIT); |
254 | |
255 | Die on HUP, INT, PIPE or TERM: |
256 | |
257 | use sigtrap qw(die normal-signals); |
258 | |
259 | Die on HUP, INT, PIPE or TERM, except don't change the behavior for |
260 | signals which are already trapped or ignored: |
261 | |
262 | use sigtrap qw(die untrapped normal-signals); |
263 | |
264 | Die on receipt one of an of the B<normal-signals> which is currently |
265 | B<untrapped>, provide a stack trace on receipt of B<any> of the |
266 | B<error-signals>: |
267 | |
268 | use sigtrap qw(die untrapped normal-signals |
269 | stack-trace any error-signals); |
270 | |
271 | Install my_handler() as the handler for the B<normal-signals>: |
272 | |
273 | use sigtrap 'handler', \&my_handler, 'normal-signals'; |
274 | |
275 | Install my_handler() as the handler for the normal-signals, provide a |
276 | Perl stack trace on receipt of one of the error-signals: |
277 | |
278 | use sigtrap qw(handler my_handler normal-signals |
279 | stack-trace error-signals); |
280 | |
281 | =cut |