[perl #97484] Make defined &{...} vivify CORE subs
authorFather Chrysostomos <sprout@cpan.org>
Thu, 1 Sep 2011 05:44:57 +0000 (22:44 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 1 Sep 2011 13:20:48 +0000 (06:20 -0700)
Magical variables usually get autovivified, even in rvalue context,
because  Perl is trying to pretend they have been there all along.
That means defined(${"."}) will autovivify $. and return true.

Until CORE subs were introduced, there were no subroutines that popped
into existence when looked at.

This commit makes rv_2cv use the GV_ADDMG flag added in commit
23496c6ea.  When this flag is passed, gv_fetchpvn_flags creates a GV
but does not add it to the stash until it finds out that it is creat-
ing a magical one.  The CORE sub code calls newATTRSUB, which expects
to add the CV to the stash itself.  So the gv has to be added there
and then.  So gv_fetchpvn_flags is also adjusted to add the gv to the
stash right before calling newATTRSUB, and to tell itself that the
GV_ADDMG flag is actually off.

It might be better to move the CV-creation code into op.c and inline
parts of newATTRSUB, to avoid fiddling with the addmg variable (and
avoid prototype checks on CORE subs), but that refactoring should
probably come in separate commits.

gv.c
pp.c
sv.c
t/op/coresubs.t

diff --git a/gv.c b/gv.c
index e4c1d21..07ff3b2 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1050,7 +1050,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
     const I32 add = flags & ~GV_NOADD_MASK;
-    const bool addmg = !!(flags & GV_ADDMG);
+    bool addmg = !!(flags & GV_ADDMG);
     const char *const name_end = nambeg + full_len;
     const char *const name_em1 = name_end - 1;
     U32 faking_it;
@@ -1402,6 +1402,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                   new ATTRSUB. */
            (void)core_prototype((SV *)cv, name, code, &opnum);
            if (ampable) {
+               if (addmg) {
+                   hv_store(stash,name,len,(SV *)gv,0);
+                   addmg = FALSE;
+               }
                CvLVALUE_on(cv);
                newATTRSUB(oldsavestack_ix,
                           newSVOP(
diff --git a/pp.c b/pp.c
index ab933c9..c732c5b 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -427,7 +427,7 @@ PP(pp_rv2cv)
     GV *gv;
     HV *stash_unused;
     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
-       ? 0
+       ? GV_ADDMG
        : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
            ? GV_ADD|GV_NOEXPAND
            : GV_ADD;
diff --git a/sv.c b/sv.c
index df0092c..2acfafc 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8884,7 +8884,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
        }
        *st = GvESTASH(gv);
     fix_gv:
-       if (lref && !GvCVu(gv)) {
+       if (lref & ~GV_ADDMG && !GvCVu(gv)) {
            SV *tmpsv;
            ENTER;
            tmpsv = newSV(0);
index e646553..f0ebe8e 100644 (file)
@@ -31,10 +31,12 @@ while(<$kh>) {
     chomp(my $word = $');
     if($& eq '+' || $unsupported{$word}) {
       $tests ++;
-      ok !defined &{\&{"CORE::$word"}}, "no CORE::$word";
+      ok !defined &{"CORE::$word"}, "no CORE::$word";
     }
     else {
-      $tests += 3;
+      $tests += 4;
+
+      ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
 
       my $proto = prototype "CORE::$word";
       *{"my$word"} = \&{"CORE::$word"};