Carp: paranoid sub lookup

Carp avoids autovivifying stashes when seeing whether a sub like
utf8::is_utf8 or overload::StrVal exists.

Its logic was slightly faulty, in that it did not take into account
that the existence of $::{"utf8::"} does not indicate the presence
of a typeglob in that element.  It could have been created due to
autovivification.  It also failed to take into account that $utf8::’s
HASH slot might be empty.  This would result in death.

In fixing this, I moved the common logic into a single function
and also took the opportunity to avoid multiple hash lookups in
a row.

2 files changed, 31 insertions, 17 deletions

diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index 60df58ff1b..96478fb822 100644
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -25,20 +25,29 @@ BEGIN {
     }
 }
 
+sub _fetch_sub { # fetch sub without autovivifying
+    my($pack, $sub) = @_;
+    $pack .= '::';
+    # only works with top-level packages
+    return unless exists($::{$pack});
+    for ($::{$pack}) {
+	return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
+	for ($$_{$sub}) {
+	    return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
+	}
+    }
+}
+
 BEGIN {
-    no strict "refs";
-    if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) &&
-	    defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) {
-	*is_utf8 = \&{"utf8::is_utf8"};
+    if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
+	*is_utf8 = $sub;
     } else {
 	*is_utf8 = sub { 0 };
     }
 }
 
 BEGIN {
-    no strict "refs";
-    if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) &&
-	    defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) {
+    if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
 	*downgrade = \&{"utf8::downgrade"};
     } else {
 	*downgrade = sub {};
@@ -167,10 +176,7 @@ sub caller_info {
             my $where = eval {
                 my $func    = $cgc or return '';
                 my $gv      =
-                    *{
-                        ( $::{"B::"} || return '')       # B stash
-                          ->{svref_2object} || return '' # entry in stash
-                     }{CODE}                             # coderef in entry
+                    (_fetch_sub B => 'svref_2object' or return '')
                         ->($func)->GV;
                 my $package = $gv->STASH->NAME;
                 my $subname = $gv->NAME;
@@ -236,11 +242,8 @@ sub format_arg {
         }
         else
         {
-	    no strict "refs";
-	    $arg = exists($::{"overload::"}) &&
-		    exists(*{$::{"overload::"}}{HASH}->{"StrVal"}) &&
-		    defined(*{*{$::{"overload::"}}{HASH}->{"StrVal"}}{CODE}) ?
-		&{"overload::StrVal"}($arg) : "$arg";
+	    my $sub = _fetch_sub(overload => 'StrVal');
+	    $arg = $sub ? &$sub($arg) : "$arg";
         }
     }
     if ( defined($arg) ) {
diff --git a/dist/Carp/t/vivify_stash.t b/dist/Carp/t/vivify_stash.t
index 226f960446..68dc9a7258 100644
--- a/dist/Carp/t/vivify_stash.t
+++ b/dist/Carp/t/vivify_stash.t
@@ -1,4 +1,4 @@
-BEGIN { print "1..2\n"; }
+BEGIN { print "1..4\n"; }
 
 our $has_utf8; BEGIN { $has_utf8 = exists($::{"utf8::"}); }
 our $has_overload; BEGIN { $has_overload = exists($::{"overload::"}); }
@@ -9,4 +9,15 @@ sub { Carp::longmess() }->(\1);
 print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1\n";
 print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2\n";
 
+# Autovivify $::{"overload::"}
+() = \$::{"overload::"};
+() = \$::{"utf8::"};
+eval { sub { Carp::longmess() }->(\1) };
+print $@ eq '' ? "ok 3\n" : "not ok 3\n# $@";
+
+# overload:: glob without hash
+undef *{"overload::"};
+eval { sub { Carp::longmess() }->(\1) };
+print $@ eq '' ? "ok 4\n" : "not ok 4\n# $@";
+
 1;