summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm
blob: 11d670942bb52eb54d797f7ae63cdeaf8f52ebf1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
package sigtrap;

=head1 NAME

sigtrap - Perl pragma to enable simple signal handling

=cut

use Carp;

$VERSION = 1.09;
$Verbose ||= 0;

sub import {
    my $pkg = shift;
    my $handler = \&handler_traceback;
    my $saw_sig = 0;
    my $untrapped = 0;
    local $_;

  Arg_loop:
    while (@_) {
	$_ = shift;
	if (/^[A-Z][A-Z0-9]*$/) {
	    $saw_sig++;
	    unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
		print "Installing handler $handler for $_\n" if $Verbose;
		$SIG{$_} = $handler;
	    }
	}
	elsif ($_ eq 'normal-signals') {
	    unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
	}
	elsif ($_ eq 'error-signals') {
	    unshift @_, grep(exists $SIG{$_},
			     qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
	}
	elsif ($_ eq 'old-interface-signals') {
	    unshift @_,
	    grep(exists $SIG{$_},
		 qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
	}
    	elsif ($_ eq 'stack-trace') {
	    $handler = \&handler_traceback;
	}
	elsif ($_ eq 'die') {
	    $handler = \&handler_die;
	}
	elsif ($_ eq 'handler') {
	    @_ or croak "No argument specified after 'handler'";
	    $handler = shift;
	    unless (ref $handler or $handler eq 'IGNORE'
			or $handler eq 'DEFAULT') {
    	    	require Symbol;
		$handler = Symbol::qualify($handler, (caller)[0]);
	    }
	}
	elsif ($_ eq 'untrapped') {
	    $untrapped = 1;
	}
	elsif ($_ eq 'any') {
	    $untrapped = 0;
	}
	elsif ($_ =~ /^\d/) {
	    $VERSION >= $_ or croak "sigtrap.pm version $_ required,"
		    	    	    	. " but this is only version $VERSION";
	}
	else {
	    croak "Unrecognized argument $_";
	}
    }
    unless ($saw_sig) {
	@_ = qw(old-interface-signals);
	goto Arg_loop;
    }
}

sub handler_die {
    croak "Caught a SIG$_[0]";
}

sub handler_traceback {
    package DB;		# To get subroutine args.
    my $use_print;
    $SIG{'ABRT'} = DEFAULT;
    kill 'ABRT', $$ if $panic++;

    # This function might be called as an unsafe signal handler, so it
    # tries to delay any memory allocations as long as possible.
    #
    # Unfortunately with PerlIO layers, using syswrite() here has always
    # been broken.
    #
    # Calling PerlIO::get_layers() here is tempting, but that does
    # allocations, which we're trying to avoid for this early code.
    if (eval { syswrite(STDERR, 'Caught a SIG', 12); 1 }) {
        syswrite(STDERR, $_[0], length($_[0]));
        syswrite(STDERR, ' at ', 4);
    }
    else {
        print STDERR 'Caught a SIG', $_[0], ' at ';
        ++$use_print;
    }

    ($pack,$file,$line) = caller;
    unless ($use_print) {
        syswrite(STDERR, $file, length($file));
        syswrite(STDERR, ' line ', 6);
        syswrite(STDERR, $line, length($line));
        syswrite(STDERR, "\n", 1);
    }
    else {
        print STDERR $file, ' line ', $line, "\n";
    }

    # we've got our basic output done, from now on we can be freer with allocations
    # find out whether we have any layers we need to worry about
    unless ($use_print) {
        my @layers = PerlIO::get_layers(*STDERR);
        for my $name (@layers) {
            unless ($name =~ /^(unix|perlio)$/) {
                ++$use_print;
                last;
            }
        }
    }

    # Now go for broke.
    for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
        @a = ();
	for (@{[@args]}) {
	    s/([\'\\])/\\$1/g;
	    s/([^\0]*)/'$1'/
	      unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
            require 'meta_notation.pm';
            $_ = _meta_notation($_) if /[[:^print:]]/a;
	    push(@a, $_);
	}
	$w = $w ? '@ = ' : '$ = ';
	$a = $h ? '(' . join(', ', @a) . ')' : '';
	$e =~ s/\n\s*\;\s*\Z// if $e;
	$e =~ s/[\\\']/\\$1/g if $e;
	if ($r) {
	    $s = "require '$e'";
	} elsif (defined $r) {
	    $s = "eval '$e'";
	} elsif ($s eq '(eval)') {
	    $s = "eval {...}";
	}
	$f = "file '$f'" unless $f eq '-e';
	$mess = "$w$s$a called from $f line $l\n";
        if ($use_print) {
            print STDERR $mess;
        }
        else {
            syswrite(STDERR, $mess, length($mess));
        }
    }
    kill 'ABRT', $$;
}

1;

__END__

=head1 SYNOPSIS

    use sigtrap;
    use sigtrap qw(stack-trace old-interface-signals);	# equivalent
    use sigtrap qw(BUS SEGV PIPE ABRT);
    use sigtrap qw(die INT QUIT);
    use sigtrap qw(die normal-signals);
    use sigtrap qw(die untrapped normal-signals);
    use sigtrap qw(die untrapped normal-signals
		    stack-trace any error-signals);
    use sigtrap 'handler' => \&my_handler, 'normal-signals';
    use sigtrap qw(handler my_handler normal-signals
    	    	    stack-trace error-signals);

=head1 DESCRIPTION

The B<sigtrap> pragma is a simple interface to installing signal
handlers.  You can have it install one of two handlers supplied by
B<sigtrap> itself (one which provides a Perl stack trace and one which
simply C<die()>s), or alternately you can supply your own handler for it
to install.  It can be told only to install a handler for signals which
are either untrapped or ignored.  It has a couple of lists of signals to
trap, plus you can supply your own list of signals.

The arguments passed to the C<use> statement which invokes B<sigtrap>
are processed in order.  When a signal name or the name of one of
B<sigtrap>'s signal lists is encountered a handler is immediately
installed, when an option is encountered it affects subsequently
installed handlers.

=head1 OPTIONS

=head2 SIGNAL HANDLERS

These options affect which handler will be used for subsequently
installed signals.

=over 4

=item B<stack-trace>

The handler used for subsequently installed signals outputs a Perl stack
trace to STDERR and then tries to dump core.  This is the default signal
handler.

=item B<die>

The handler used for subsequently installed signals calls C<die>
(actually C<croak>) with a message indicating which signal was caught.

=item B<handler> I<your-handler>

I<your-handler> will be used as the handler for subsequently installed
signals.  I<your-handler> can be any value which is valid as an
assignment to an element of C<%SIG>. See L<perlvar> for examples of
handler functions.

=back

=head2 SIGNAL LISTS

B<sigtrap> has a few built-in lists of signals to trap.  They are:

=over 4

=item B<normal-signals>

These are the signals which a program might normally expect to encounter
and which by default cause it to terminate.  They are HUP, INT, PIPE and
TERM.

=item B<error-signals>

These signals usually indicate a serious problem with the Perl
interpreter or with your script.  They are ABRT, BUS, EMT, FPE, ILL,
QUIT, SEGV, SYS and TRAP.

=item B<old-interface-signals>

These are the signals which were trapped by default by the old
B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
SEGV, SYS, TERM, and TRAP.  If no signals or signals lists are passed to
B<sigtrap>, this list is used.

=back

For each of these three lists, the collection of signals set to be
trapped is checked before trapping; if your architecture does not
implement a particular signal, it will not be trapped but rather
silently ignored.

=head2 OTHER

=over 4

=item B<untrapped>

This token tells B<sigtrap> to install handlers only for subsequently
listed signals which aren't already trapped or ignored.

=item B<any>

This token tells B<sigtrap> to install handlers for all subsequently
listed signals.  This is the default behavior.

=item I<signal>

Any argument which looks like a signal name (that is,
C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
handler for that name.

=item I<number>

Require that at least version I<number> of B<sigtrap> is being used.

=back

=head1 EXAMPLES

Provide a stack trace for the old-interface-signals:

    use sigtrap;

Ditto:

    use sigtrap qw(stack-trace old-interface-signals);

Provide a stack trace on the 4 listed signals only:

    use sigtrap qw(BUS SEGV PIPE ABRT);

Die on INT or QUIT:

    use sigtrap qw(die INT QUIT);

Die on HUP, INT, PIPE or TERM:

    use sigtrap qw(die normal-signals);

Die on HUP, INT, PIPE or TERM, except don't change the behavior for
signals which are already trapped or ignored:

    use sigtrap qw(die untrapped normal-signals);

Die on receipt one of an of the B<normal-signals> which is currently
B<untrapped>, provide a stack trace on receipt of B<any> of the
B<error-signals>:

    use sigtrap qw(die untrapped normal-signals
		    stack-trace any error-signals);

Install my_handler() as the handler for the B<normal-signals>:

    use sigtrap 'handler', \&my_handler, 'normal-signals';

Install my_handler() as the handler for the normal-signals, provide a
Perl stack trace on receipt of one of the error-signals:

    use sigtrap qw(handler my_handler normal-signals
    	    	    stack-trace error-signals);

=cut