Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package sigtrap; |
2 | ||
f06db76b AD |
3 | =head1 NAME |
4 | ||
1ae80e7e | 5 | sigtrap - Perl pragma to enable simple signal handling |
f06db76b AD |
6 | |
7 | =cut | |
8 | ||
1ae80e7e | 9 | use Carp; |
10 | ||
5c0551aa | 11 | $VERSION = 1.09; |
1ae80e7e | 12 | $Verbose ||= 0; |
a0d0e21e LW |
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') { | |
55497cff | 32 | unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); |
1ae80e7e | 33 | } |
34 | elsif ($_ eq 'error-signals') { | |
55497cff | 35 | unshift @_, grep(exists $SIG{$_}, |
36 | qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); | |
1ae80e7e | 37 | } |
38 | elsif ($_ eq 'old-interface-signals') { | |
55497cff | 39 | unshift @_, |
40 | grep(exists $SIG{$_}, | |
41 | qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); | |
1ae80e7e | 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 | } | |
a0d0e21e | 71 | } |
1ae80e7e | 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]"; | |
a0d0e21e LW |
80 | } |
81 | ||
1ae80e7e | 82 | sub handler_traceback { |
a0d0e21e | 83 | package DB; # To get subroutine args. |
5c0551aa | 84 | my $use_print; |
a0d0e21e LW |
85 | $SIG{'ABRT'} = DEFAULT; |
86 | kill 'ABRT', $$ if $panic++; | |
5c0551aa TC |
87 | |
88 | # This function might be called as an unsafe signal handler, so it | |
89 | # tries to delay any memory allocations as long as possible. | |
90 | # | |
91 | # Unfortunately with PerlIO layers, using syswrite() here has always | |
92 | # been broken. | |
93 | # | |
94 | # Calling PerlIO::get_layers() here is tempting, but that does | |
95 | # allocations, which we're trying to avoid for this early code. | |
96 | if (eval { syswrite(STDERR, 'Caught a SIG', 12); 1 }) { | |
97 | syswrite(STDERR, $_[0], length($_[0])); | |
98 | syswrite(STDERR, ' at ', 4); | |
99 | } | |
100 | else { | |
101 | print STDERR 'Caught a SIG', $_[0], ' at '; | |
102 | ++$use_print; | |
103 | } | |
104 | ||
a0d0e21e | 105 | ($pack,$file,$line) = caller; |
5c0551aa TC |
106 | unless ($use_print) { |
107 | syswrite(STDERR, $file, length($file)); | |
108 | syswrite(STDERR, ' line ', 6); | |
109 | syswrite(STDERR, $line, length($line)); | |
110 | syswrite(STDERR, "\n", 1); | |
111 | } | |
112 | else { | |
113 | print STDERR $file, ' line ', $line, "\n"; | |
114 | } | |
115 | ||
116 | # we've got our basic output done, from now on we can be freer with allocations | |
117 | # find out whether we have any layers we need to worry about | |
118 | unless ($use_print) { | |
119 | my @layers = PerlIO::get_layers(*STDERR); | |
120 | for my $name (@layers) { | |
121 | unless ($name =~ /^(unix|perlio)$/) { | |
122 | ++$use_print; | |
123 | last; | |
124 | } | |
125 | } | |
126 | } | |
a0d0e21e LW |
127 | |
128 | # Now go for broke. | |
d338d6fe | 129 | for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { |
130 | @a = (); | |
a8e6f76f | 131 | for (@{[@args]}) { |
d338d6fe | 132 | s/([\'\\])/\\$1/g; |
a0d0e21e | 133 | s/([^\0]*)/'$1'/ |
d338d6fe | 134 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; |
4b6af431 KW |
135 | require 'meta_notation.pm'; |
136 | $_ = _meta_notation($_) if /[[:^print:]]/a; | |
a0d0e21e LW |
137 | push(@a, $_); |
138 | } | |
139 | $w = $w ? '@ = ' : '$ = '; | |
140 | $a = $h ? '(' . join(', ', @a) . ')' : ''; | |
d338d6fe | 141 | $e =~ s/\n\s*\;\s*\Z// if $e; |
142 | $e =~ s/[\\\']/\\$1/g if $e; | |
143 | if ($r) { | |
144 | $s = "require '$e'"; | |
145 | } elsif (defined $r) { | |
146 | $s = "eval '$e'"; | |
147 | } elsif ($s eq '(eval)') { | |
148 | $s = "eval {...}"; | |
149 | } | |
9404893f | 150 | $f = "file '$f'" unless $f eq '-e'; |
a0d0e21e | 151 | $mess = "$w$s$a called from $f line $l\n"; |
5c0551aa TC |
152 | if ($use_print) { |
153 | print STDERR $mess; | |
154 | } | |
155 | else { | |
156 | syswrite(STDERR, $mess, length($mess)); | |
157 | } | |
a0d0e21e LW |
158 | } |
159 | kill 'ABRT', $$; | |
160 | } | |
161 | ||
162 | 1; | |
1ae80e7e | 163 | |
164 | __END__ | |
165 | ||
166 | =head1 SYNOPSIS | |
167 | ||
168 | use sigtrap; | |
169 | use sigtrap qw(stack-trace old-interface-signals); # equivalent | |
170 | use sigtrap qw(BUS SEGV PIPE ABRT); | |
171 | use sigtrap qw(die INT QUIT); | |
172 | use sigtrap qw(die normal-signals); | |
173 | use sigtrap qw(die untrapped normal-signals); | |
174 | use sigtrap qw(die untrapped normal-signals | |
175 | stack-trace any error-signals); | |
176 | use sigtrap 'handler' => \&my_handler, 'normal-signals'; | |
177 | use sigtrap qw(handler my_handler normal-signals | |
178 | stack-trace error-signals); | |
179 | ||
180 | =head1 DESCRIPTION | |
181 | ||
182 | The B<sigtrap> pragma is a simple interface to installing signal | |
183 | handlers. You can have it install one of two handlers supplied by | |
184 | B<sigtrap> itself (one which provides a Perl stack trace and one which | |
185 | simply C<die()>s), or alternately you can supply your own handler for it | |
186 | to install. It can be told only to install a handler for signals which | |
187 | are either untrapped or ignored. It has a couple of lists of signals to | |
188 | trap, plus you can supply your own list of signals. | |
189 | ||
190 | The arguments passed to the C<use> statement which invokes B<sigtrap> | |
191 | are processed in order. When a signal name or the name of one of | |
192 | B<sigtrap>'s signal lists is encountered a handler is immediately | |
193 | installed, when an option is encountered it affects subsequently | |
194 | installed handlers. | |
195 | ||
196 | =head1 OPTIONS | |
197 | ||
198 | =head2 SIGNAL HANDLERS | |
199 | ||
200 | These options affect which handler will be used for subsequently | |
201 | installed signals. | |
202 | ||
84dc3c4d | 203 | =over 4 |
1ae80e7e | 204 | |
205 | =item B<stack-trace> | |
206 | ||
36477c24 | 207 | The handler used for subsequently installed signals outputs a Perl stack |
208 | trace to STDERR and then tries to dump core. This is the default signal | |
209 | handler. | |
1ae80e7e | 210 | |
211 | =item B<die> | |
212 | ||
213 | The handler used for subsequently installed signals calls C<die> | |
214 | (actually C<croak>) with a message indicating which signal was caught. | |
215 | ||
216 | =item B<handler> I<your-handler> | |
217 | ||
218 | I<your-handler> will be used as the handler for subsequently installed | |
219 | signals. I<your-handler> can be any value which is valid as an | |
e2e369db DN |
220 | assignment to an element of C<%SIG>. See L<perlvar> for examples of |
221 | handler functions. | |
1ae80e7e | 222 | |
223 | =back | |
224 | ||
225 | =head2 SIGNAL LISTS | |
226 | ||
36477c24 | 227 | B<sigtrap> has a few built-in lists of signals to trap. They are: |
1ae80e7e | 228 | |
84dc3c4d | 229 | =over 4 |
1ae80e7e | 230 | |
231 | =item B<normal-signals> | |
232 | ||
233 | These are the signals which a program might normally expect to encounter | |
234 | and which by default cause it to terminate. They are HUP, INT, PIPE and | |
235 | TERM. | |
236 | ||
237 | =item B<error-signals> | |
238 | ||
239 | These signals usually indicate a serious problem with the Perl | |
240 | interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, | |
241 | QUIT, SEGV, SYS and TRAP. | |
242 | ||
243 | =item B<old-interface-signals> | |
244 | ||
245 | These are the signals which were trapped by default by the old | |
246 | B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, | |
247 | SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to | |
55497cff | 248 | B<sigtrap>, this list is used. |
1ae80e7e | 249 | |
250 | =back | |
251 | ||
55497cff | 252 | For each of these three lists, the collection of signals set to be |
253 | trapped is checked before trapping; if your architecture does not | |
254 | implement a particular signal, it will not be trapped but rather | |
255 | silently ignored. | |
256 | ||
1ae80e7e | 257 | =head2 OTHER |
258 | ||
84dc3c4d | 259 | =over 4 |
260 | ||
1ae80e7e | 261 | =item B<untrapped> |
262 | ||
36477c24 | 263 | This token tells B<sigtrap> to install handlers only for subsequently |
1ae80e7e | 264 | listed signals which aren't already trapped or ignored. |
265 | ||
266 | =item B<any> | |
267 | ||
268 | This token tells B<sigtrap> to install handlers for all subsequently | |
269 | listed signals. This is the default behavior. | |
270 | ||
271 | =item I<signal> | |
272 | ||
36477c24 | 273 | Any argument which looks like a signal name (that is, |
274 | C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a | |
275 | handler for that name. | |
1ae80e7e | 276 | |
277 | =item I<number> | |
278 | ||
279 | Require that at least version I<number> of B<sigtrap> is being used. | |
280 | ||
281 | =back | |
282 | ||
283 | =head1 EXAMPLES | |
284 | ||
285 | Provide a stack trace for the old-interface-signals: | |
286 | ||
287 | use sigtrap; | |
288 | ||
289 | Ditto: | |
290 | ||
291 | use sigtrap qw(stack-trace old-interface-signals); | |
292 | ||
293 | Provide a stack trace on the 4 listed signals only: | |
294 | ||
295 | use sigtrap qw(BUS SEGV PIPE ABRT); | |
296 | ||
297 | Die on INT or QUIT: | |
298 | ||
299 | use sigtrap qw(die INT QUIT); | |
300 | ||
301 | Die on HUP, INT, PIPE or TERM: | |
302 | ||
303 | use sigtrap qw(die normal-signals); | |
304 | ||
305 | Die on HUP, INT, PIPE or TERM, except don't change the behavior for | |
306 | signals which are already trapped or ignored: | |
307 | ||
308 | use sigtrap qw(die untrapped normal-signals); | |
309 | ||
310 | Die on receipt one of an of the B<normal-signals> which is currently | |
311 | B<untrapped>, provide a stack trace on receipt of B<any> of the | |
312 | B<error-signals>: | |
313 | ||
314 | use sigtrap qw(die untrapped normal-signals | |
315 | stack-trace any error-signals); | |
316 | ||
317 | Install my_handler() as the handler for the B<normal-signals>: | |
318 | ||
319 | use sigtrap 'handler', \&my_handler, 'normal-signals'; | |
320 | ||
321 | Install my_handler() as the handler for the normal-signals, provide a | |
322 | Perl stack trace on receipt of one of the error-signals: | |
323 | ||
324 | use sigtrap qw(handler my_handler normal-signals | |
325 | stack-trace error-signals); | |
326 | ||
327 | =cut |