Carp: Avoid run-time mods; StrVal workarounds

Carp needs to avoid loading modules while reporting errors, because it may be invoked via $SIG{__DIE__} after a syntax error, when BEGIN blocks are forbidden. Before this commit (as of v5.27.8-360-gc99363a) it was doing just that for reference arguments within stack traces. That means we either need to load overload.pm at start-up so that overload::StrVal is already available, or avoid overload::StrVal altogether. It turns out that various versions of overload::StrVal have their own problems that prevent Carp from using them (out- lined in the comments added to Carp.pm and also described at <https://rt.perl.org/Ticket/Display.html?id=132902#txn-1535564>). So we now follow two approaches: If overloading.pm is available, use that; otherwise, use a hideous workaround inspired by ancient imple- entations of overload::StrVal and Scalar::Util::blessed, while avoid- ing the bugs in those old versions.
Perl · Feb 27, 2018 · 5c8d107 · 5c8d107
1 parent f88ca57
commit 5c8d107
Show file tree

Hide file tree

Showing 4 changed files with 148 additions and 29 deletions.
diff --git a/MANIFEST b/MANIFEST
@@ -2975,6 +2975,7 @@ dist/Carp/t/errno.t		See if Carp preserves $! and $^E
 dist/Carp/t/heavy.t		See if Carp::Heavy works
 dist/Carp/t/heavy_mismatch.t		See if Carp::Heavy catches version mismatch
 dist/Carp/t/rt52610_crash.t		Test that we can gracefully handle serializing the stack with stack-refcounting bugs
+dist/Carp/t/stack_after_err.t	Test stack traces after syntax errors
 dist/Carp/t/stash_deletion.t		See if Carp handles stash deletion
 dist/Carp/t/swash.t		See if Carp avoids breaking swash loading
 dist/Carp/t/vivify_gv.t		See if Carp leaves utf8:: stuff alone

diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
@@ -130,12 +130,71 @@ sub _univ_mod_loaded {
     }
 }
 
-# _mycan is either UNIVERSAL::can, or, in the presence of an override,
-# overload::mycan.
+# We need an overload::StrVal or equivalent function, but we must avoid
+# loading any modules on demand, as Carp is used from __DIE__ handlers and
+# may be invoked after a syntax error.
+# We can copy recent implementations of overload::StrVal and use
+# overloading.pm, which is the fastest implementation, so long as
+# overloading is available.  If it is not available, we use our own pure-
+# Perl StrVal.  We never actually use overload::StrVal, for various rea-
+# sons described below.
+# overload versions are as follows:
+#     undef-1.00 (up to perl 5.8.0)   uses bless (avoid!)
+#     1.01-1.17  (perl 5.8.1 to 5.14) uses Scalar::Util
+#     1.18+      (perl 5.16+)         uses overloading
+# The ancient 'bless' implementation (that inspires our pure-Perl version)
+# blesses unblessed references and must be avoided.  Those using
+# Scalar::Util use refaddr, possibly the pure-Perl implementation, which
+# has the same blessing bug, and must be avoided.  Also, Scalar::Util is
+# loaded on demand.  Since we avoid the Scalar::Util implementations, we
+# end up having to implement our own overloading.pm-based version for perl
+# 5.10.1 to 5.14.  Since it also works just as well in more recent ver-
+# sions, we use it there, too.
 BEGIN {
-    *_mycan = _univ_mod_loaded('can')
-        ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
-        : \&UNIVERSAL::can
+    if (eval { require "overloading.pm" }) {
+        *_StrVal = eval 'sub { no overloading; "$_[0]" }'
+    }
+    else {
+        # Work around the UNIVERSAL::can/isa modules to avoid recursion.
+
+        # _mycan is either UNIVERSAL::can, or, in the presence of an
+        # override, overload::mycan.
+        *_mycan = _univ_mod_loaded('can')
+            ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
+            : \&UNIVERSAL::can;
+
+        # _blessed is either UNIVERAL::isa(...), or, in the presence of an
+        # override, a hideous, but fairly reliable, workaround.
+        *_blessed = _univ_mod_loaded('isa')
+            ? sub {
+                my $probe = "UNIVERSAL::Carp_probe_" . rand;
+                no strict 'refs';
+                local *$probe = sub { "unlikely string" };
+                local $@;
+                local $SIG{__DIE__} = sub{};
+                (eval { $_[0]->$probe } || '') eq 'unlikely string'
+              }
+            : do {
+                my $isa = _fetch_sub(qw/UNIVERSAL isa/);
+                sub { &$isa($_[0], "UNIVERSAL") }
+              };
+
+        *_StrVal = sub {
+            my $pack = ref $_[0];
+            # Perl's overload mechanism uses the presence of a special
+            # "method" named "((" or "()" to signal it is in effect.
+            # This test seeks to see if it has been set up.  "((" post-
+            # dates overloading.pm, so we can skip it.
+            return "$_[0]" unless _mycan($pack, "()");
+            # Even at this point, the invocant may not be blessed, so
+            # check for that.
+            return "$_[0]" if not _blessed($_[0]);
+            bless $_[0], "Carp";
+            my $str = "$_[0]";
+            bless $_[0], $pack;
+            $pack . substr $str, index $str, "=";
+        }
+    }
 }
 
 
@@ -358,23 +417,11 @@ sub format_arg {
         }
         else
         {
-            # overload uses the presence of a special
-            # "method" named "((" or "()" to signal
-            # it is in effect.  This test seeks to see if it has been set up.
-            if (_mycan($pack, "((") || _mycan($pack, "()")) {
-                # Argument is blessed into a class with overloading, and
-                # so might have an overloaded stringification.  We don't
-                # want to risk getting the overloaded stringification,
-                # so we need to use overload::StrVal() below.  But it's
-                # possible that the overload module hasn't been loaded:
-                # overload methods can be installed without it.  So load
-                # the module here.  The bareword form of require is here
-                # eschewed to avoid this compile-time effect of vivifying
-                # the target module's stash.
-                require "overload.pm";
-            }
-            my $sub = _fetch_sub(overload => 'StrVal');
-            return $sub ? &$sub($arg) : "$arg";
+            # Argument may be blessed into a class with overloading, and so
+            # might have an overloaded stringification.  We don't want to
+            # risk getting the overloaded stringification, so we need to
+            # use _StrVal, our overload::StrVal()-equivalent.
+            return _StrVal $arg;
         }
     }
     return "undef" if !defined($arg);

diff --git a/dist/Carp/t/stack_after_err.t b/dist/Carp/t/stack_after_err.t
@@ -0,0 +1,73 @@
+use Config;
+use IPC::Open3 1.0103 qw(open3);
+use Test::More tests => 4;
+
+sub runperl {
+    my(%args) = @_;
+    my($w, $r);
+
+    local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+
+    my $pid = open3($w, $r, undef, $^X, "-e", $args{prog});
+    close $w;
+    my $output = "";
+    while(<$r>) { $output .= $_; }
+    waitpid($pid, 0);
+    return $output;
+}
+
+
+# Make sure we don’t try to load modules on demand in the presence of over-
+# loaded args.  If there has been a syntax error, they won’t load.
+like(
+    runperl(
+        prog => q<
+          use Carp;
+          sub foom {
+              Carp::confess("Looks lark we got a error: $_[0]")
+          }
+          BEGIN {
+              *{"o::()"} = sub {};
+              *{'o::(""'} = sub {"hay"};
+              $o::OVERLOAD{dummy}++; # perls before 5.18 need this
+              *{"CODE::()"} = sub {};
+              $SIG{__DIE__} = sub { foom (@_, bless([], o), sub {}) }
+          }
+        $a +
+        >,
+    ),
+    qr 'Looks lark.*o=ARRAY.* CODE's,
+   'Carp does not try to load modules on demand for overloaded args',
+);
+
+# Run the test also in the presence of
+#  a) A UNIVERSAL::can module
+#  b) A UNIVERSAL::isa module
+#  c) Both
+# since they follow slightly different code paths on old pre-5.10.1 perls.
+my $prog = q<
+          use Carp;
+          sub foom {
+              Carp::confess("Looks lark we got a error: $_[0]")
+          }
+          BEGIN {
+              *{"o::()"} = sub {};
+              *{'o::(""'} = sub {"hay"};
+              $o::OVERLOAD{dummy}++; # perls before 5.18 need this
+              *{"CODE::()"} = sub {};
+              $SIG{__DIE__} = sub { foom (@_, bless([], o), sub{}) }
+          }
+        $a +
+>;
+for (
+ ["UNIVERSAL::isa", 'BEGIN { $UNIVERSAL::isa::VERSION = 1 }'],
+ ["UNIVERSAL::can", 'BEGIN { $UNIVERSAL::can::VERSION = 1 }'],
+ ["UNIVERSAL::can/isa", 'BEGIN { $UNIVERSAL::can::VERSION =
+                                 $UNIVERSAL::isa::VERSION = 1 }'],
+) {
+    my ($tn, $preamble) = @$_;
+    like(runperl( prog => "$preamble$prog" ),
+         qr 'Looks lark.*o=ARRAY.* CODE's,
+        "StrVal fallback in the presence of $tn",
+    )
+}
diff --git a/dist/Carp/t/vivify_stash.t b/dist/Carp/t/vivify_stash.t
@@ -1,27 +1,25 @@
-BEGIN { print "1..6\n"; }
+BEGIN { print "1..5\n"; }
 
 our $has_utf8; BEGIN { $has_utf8 = exists($::{"utf8::"}); }
-our $has_overload; BEGIN { $has_overload = exists($::{"overload::"}); }
 our $has_B; BEGIN { $has_B = exists($::{"B::"}); }
 our $has_UNIVERSAL_isa; BEGIN { $has_UNIVERSAL_isa = exists($UNIVERSAL::{"isa::"}); }
 
 use Carp;
 sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/);
 
 print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1 # used utf8\n";
-print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2 # used overload\n";
-print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 3 # used B\n";
-print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ", "ok 4 # used UNIVERSAL::isa\n";
+print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 2 # used B\n";
+print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ", "ok 3 # used UNIVERSAL::isa\n";
 
 # Autovivify $::{"overload::"}
 () = \$::{"overload::"};
 () = \$::{"utf8::"};
 eval { sub { Carp::longmess() }->(\1) };
-print $@ eq '' ? "ok 5 # longmess check1\n" : "not ok 5 # longmess check1\n# $@";
+print $@ eq '' ? "ok 4 # longmess check1\n" : "not ok 4 # longmess check1\n# $@";
 
 # overload:: glob without hash
 undef *{"overload::"};
 eval { sub { Carp::longmess() }->(\1) };
-print $@ eq '' ? "ok 6 # longmess check2\n" : "not ok 6 # longmess check2\n# $@";
+print $@ eq '' ? "ok 5 # longmess check2\n" : "not ok 5 # longmess check2\n# $@";
 
 1;