xref: /openbsd/gnu/usr.bin/perl/lib/sigtrap.pm (revision 76d0caae) 
1package sigtrap;
2
3=head1 NAME
4
5sigtrap - Perl pragma to enable simple signal handling
6
7=cut
8
9use Carp;
10
11$VERSION = 1.09;
12$Verbose ||= 0;
13
14sub import {
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 @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
33	}
34	elsif ($_ eq 'error-signals') {
35	    unshift @_, grep(exists $SIG{$_},
36			     qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
37	}
38	elsif ($_ eq 'old-interface-signals') {
39	    unshift @_,
40	    grep(exists $SIG{$_},
41		 qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
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	}
71    }
72    unless ($saw_sig) {
73	@_ = qw(old-interface-signals);
74	goto Arg_loop;
75    }
76}
77
78sub handler_die {
79    croak "Caught a SIG$_[0]";
80}
81
82sub handler_traceback {
83    package DB;		# To get subroutine args.
84    my $use_print;
85    $SIG{'ABRT'} = DEFAULT;
86    kill 'ABRT', $$ if $panic++;
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
105    ($pack,$file,$line) = caller;
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    }
127
128    # Now go for broke.
129    for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
130        @a = ();
131	for (@{[@args]}) {
132	    s/([\'\\])/\\$1/g;
133	    s/([^\0]*)/'$1'/
134	      unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
135            require 'meta_notation.pm';
136            $_ = _meta_notation($_) if /[[:^print:]]/a;
137	    push(@a, $_);
138	}
139	$w = $w ? '@ = ' : '$ = ';
140	$a = $h ? '(' . join(', ', @a) . ')' : '';
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	}
150	$f = "file '$f'" unless $f eq '-e';
151	$mess = "$w$s$a called from $f line $l\n";
152        if ($use_print) {
153            print STDERR $mess;
154        }
155        else {
156            syswrite(STDERR, $mess, length($mess));
157        }
158    }
159    kill 'ABRT', $$;
160}
161
1621;
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
182The B<sigtrap> pragma is a simple interface to installing signal
183handlers.  You can have it install one of two handlers supplied by
184B<sigtrap> itself (one which provides a Perl stack trace and one which
185simply C<die()>s), or alternately you can supply your own handler for it
186to install.  It can be told only to install a handler for signals which
187are either untrapped or ignored.  It has a couple of lists of signals to
188trap, plus you can supply your own list of signals.
189
190The arguments passed to the C<use> statement which invokes B<sigtrap>
191are processed in order.  When a signal name or the name of one of
192B<sigtrap>'s signal lists is encountered a handler is immediately
193installed, when an option is encountered it affects subsequently
194installed handlers.
195
196=head1 OPTIONS
197
198=head2 SIGNAL HANDLERS
199
200These options affect which handler will be used for subsequently
201installed signals.
202
203=over 4
204
205=item B<stack-trace>
206
207The handler used for subsequently installed signals outputs a Perl stack
208trace to STDERR and then tries to dump core.  This is the default signal
209handler.
210
211=item B<die>
212
213The 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
218I<your-handler> will be used as the handler for subsequently installed
219signals.  I<your-handler> can be any value which is valid as an
220assignment to an element of C<%SIG>. See L<perlvar> for examples of
221handler functions.
222
223=back
224
225=head2 SIGNAL LISTS
226
227B<sigtrap> has a few built-in lists of signals to trap.  They are:
228
229=over 4
230
231=item B<normal-signals>
232
233These are the signals which a program might normally expect to encounter
234and which by default cause it to terminate.  They are HUP, INT, PIPE and
235TERM.
236
237=item B<error-signals>
238
239These signals usually indicate a serious problem with the Perl
240interpreter or with your script.  They are ABRT, BUS, EMT, FPE, ILL,
241QUIT, SEGV, SYS and TRAP.
242
243=item B<old-interface-signals>
244
245These are the signals which were trapped by default by the old
246B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
247SEGV, SYS, TERM, and TRAP.  If no signals or signals lists are passed to
248B<sigtrap>, this list is used.
249
250=back
251
252For each of these three lists, the collection of signals set to be
253trapped is checked before trapping; if your architecture does not
254implement a particular signal, it will not be trapped but rather
255silently ignored.
256
257=head2 OTHER
258
259=over 4
260
261=item B<untrapped>
262
263This token tells B<sigtrap> to install handlers only for subsequently
264listed signals which aren't already trapped or ignored.
265
266=item B<any>
267
268This token tells B<sigtrap> to install handlers for all subsequently
269listed signals.  This is the default behavior.
270
271=item I<signal>
272
273Any argument which looks like a signal name (that is,
274C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
275handler for that name.
276
277=item I<number>
278
279Require that at least version I<number> of B<sigtrap> is being used.
280
281=back
282
283=head1 EXAMPLES
284
285Provide a stack trace for the old-interface-signals:
286
287    use sigtrap;
288
289Ditto:
290
291    use sigtrap qw(stack-trace old-interface-signals);
292
293Provide a stack trace on the 4 listed signals only:
294
295    use sigtrap qw(BUS SEGV PIPE ABRT);
296
297Die on INT or QUIT:
298
299    use sigtrap qw(die INT QUIT);
300
301Die on HUP, INT, PIPE or TERM:
302
303    use sigtrap qw(die normal-signals);
304
305Die on HUP, INT, PIPE or TERM, except don't change the behavior for
306signals which are already trapped or ignored:
307
308    use sigtrap qw(die untrapped normal-signals);
309
310Die on receipt one of an of the B<normal-signals> which is currently
311B<untrapped>, provide a stack trace on receipt of B<any> of the
312B<error-signals>:
313
314    use sigtrap qw(die untrapped normal-signals
315		    stack-trace any error-signals);
316
317Install my_handler() as the handler for the B<normal-signals>:
318
319    use sigtrap 'handler', \&my_handler, 'normal-signals';
320
321Install my_handler() as the handler for the normal-signals, provide a
322Perl 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
328