Call get-magic once for implicit rv2gv in close(), etc.
authorFather Chrysostomos <sprout@cpan.org>
Tue, 23 Aug 2011 21:10:49 +0000 (14:10 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 23 Aug 2011 21:20:05 +0000 (14:20 -0700)
This commit stops an implicit rv2gv from calling get-magic twice.  As
a side-effect, it also squelches the duplicate warning emitted by
‘close undef’ (bug #97482).

is_gv_magical_sv is modified not to call get-magic on the sv passed to
it.  It is not in the public API, and the only two callers (rv2gv and
softrefxv) have already called get-magic before calling it.

gv.c
pp.c
t/lib/warnings/9uninit
t/op/tie_fetch_count.t

diff --git a/gv.c b/gv.c
index 874c3dc..93f2bb7 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2673,7 +2673,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 /*
 =for apidoc is_gv_magical_sv
 
-Returns C<TRUE> if given the name of a magical GV.
+Returns C<TRUE> if given the name of a magical GV.  Any get-magic that
+C<name_sv> has is ignored.
 
 Currently only useful internally when determining if a GV should be
 created even in rvalue contexts.
@@ -2688,7 +2689,7 @@ bool
 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
 {
     STRLEN len;
-    const char *const name = SvPV_const(name_sv, len);
+    const char *const name = SvPV_nomg_const(name_sv, len);
 
     PERL_UNUSED_ARG(flags);
     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
diff --git a/pp.c b/pp.c
index 9a7c393..e60f7db 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -200,10 +200,16 @@ PP(pp_rv2gv)
            if ((PL_op->op_flags & OPf_SPECIAL) &&
                !(PL_op->op_flags & OPf_MOD))
            {
-               SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
+               STRLEN len;
+               const char * const nambeg = SvPV_nomg_const(sv, len);
+               SV * const temp = MUTABLE_SV(
+                   gv_fetchpvn_flags(nambeg, len, SvUTF8(sv), SVt_PVGV)
+               );
                if (!temp
-                   && (!is_gv_magical_sv(sv,0)
-                       || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
+                    /* !len to avoid an extra uninit warning */
+                   && (!len || !is_gv_magical_sv(sv,0)
+                       || !(sv = MUTABLE_SV(gv_fetchpvn_flags(
+                                nambeg, len, GV_ADD | SvUTF8(sv),
                                                        SVt_PVGV))))) {
                    RETSETUNDEF;
                }
index ff6736f..f13b461 100644 (file)
@@ -296,9 +296,11 @@ our ($g1);
 
 close $m1;     # exercises rv2gv
 close $g1;     # exercises rv2gv
+close undef;   # exercises rv2gv
 EXPECT
 Use of uninitialized value $m1 in ref-to-glob cast at - line 5.
 Use of uninitialized value $g1 in ref-to-glob cast at - line 6.
+Use of uninitialized value in ref-to-glob cast at - line 7.
 ########
 use warnings 'uninitialized';
 my ($m1, $m2, $v);
index b9fd275..b6c4d6a 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 215);
+    plan (tests => 216);
 }
 
 use strict;
@@ -184,6 +184,17 @@ $dummy  = &$var5        ; check_count '&{}';
     $dummy  = *$var1        ; check_count 'symbolic *{}';
     local *1 = sub{};
     $dummy  = &$var1        ; check_count 'symbolic &{}';
+
+    # This test will not be a complete test if ${^OPEN} has been created
+    # already.  If this dies, change it to use another built-in variable.
+    # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which
+    # is why we need the test this way.
+    if (exists $::{"\cOPEN"}) {
+       die "*{^OPEN} already exists. Please adjust this test"
+    }
+    tie my $var6 => main => "\cOPEN";
+    no warnings;
+    readdir $var6           ; check_count 'symbolic readdir';
 }
 
 ###############################################