This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Carp: paranoid sub lookup
authorFather Chrysostomos <sprout@cpan.org>
Fri, 23 Aug 2013 07:50:40 +0000 (00:50 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Fri, 23 Aug 2013 07:50:40 +0000 (00:50 -0700)
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.

dist/Carp/lib/Carp.pm
dist/Carp/t/vivify_stash.t

index 60df58f..96478fb 100644 (file)
@@ -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) ) {
index 226f960..68dc9a7 100644 (file)
@@ -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;