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