(perl #126760) adapt sigtrap for layers on STDERR.

sigtrap defines a signal handler apparently intended to be called
under unsafe signals, since a) the code was written before safe
signals were implemented and b) it uses syswrite() for output and
avoid creating new SVs where it can.

Unfortunately syswrite() doesn't handle PerlIO layers, *and* with
syswrite() being disallowed for :utf8 handlers, throws an exception.

This causes the sigtrap tests to fail if PERL_UNICODE is set and the
current locale is a UTF-8 locale.

I want to avoid allocating new SVs until the point where the code
originally did so, so the code now attempts a syswrite() under
eval, falling back to print, and then at the point where the original
code started allocating SVs uses PerlIO::get_layers() to check if
any layers might make a difference to the output.

1 files changed, 47 insertions, 9 deletions

diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm
index 7d801461d4..11d670942b 100644
--- a/lib/sigtrap.pm
+++ b/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', $$;
 }