summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm56
1 files changed, 47 insertions, 9 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm
index 7d801461d4..11d670942b 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/sigtrap.pm
@@ -8,7 +8,7 @@ sigtrap - Perl pragma to enable simple signal handling
use Carp;
-$VERSION = 1.08;
+$VERSION = 1.09;
$Verbose ||= 0;
sub import {
@@ -81,16 +81,49 @@ sub handler_die {
sub handler_traceback {
package DB; # To get subroutine args.
+ my $use_print;
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
- syswrite(STDERR, 'Caught a SIG', 12);
- syswrite(STDERR, $_[0], length($_[0]));
- syswrite(STDERR, ' at ', 4);
+
+ # 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;
- syswrite(STDERR, $file, length($file));
- syswrite(STDERR, ' line ', 6);
- syswrite(STDERR, $line, length($line));
- syswrite(STDERR, "\n", 1);
+ 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++) {
@@ -116,7 +149,12 @@ sub handler_traceback {
}
$f = "file '$f'" unless $f eq '-e';
$mess = "$w$s$a called from $f line $l\n";
- syswrite(STDERR, $mess, length($mess));
+ if ($use_print) {
+ print STDERR $mess;
+ }
+ else {
+ syswrite(STDERR, $mess, length($mess));
+ }
}
kill 'ABRT', $$;
}