Rework mod loading for %- and %!; fix mem leak

There are many built-in variables that perl creates on demand for
efficiency’s sake.  gv_fetchpvn_flags (which is responsible for sym-
bol lookup) will fill in those variables automatically when add-
ing a symbol.

The special GV_ADDMG flag passed to this function by a few code paths
(such as defined *{"..."}) tells gv_fetchpvn_flags to add the symbol,
but only if it is one of the ‘magical’ built-in variables that we pre-
tend already exist.

To accomplish this, when the GV_ADDMG flag is passed,
gv_fetchpvn_flags, if the symbol does not already exist, creates a new
GV that is not attached to the stash.  It then runs it through its
magicalization code and checks afterward to see whether the GV
changed.  If it did, then it gets added to the stash.  Otherwise, it
is discarded.

Three of the variables, %-, %!, and $], are problematic, in that they
are implemented by external modules.  gv_fetchpvn_flags loads those
modules, which tie the variable in question, and then control is
returned to gv_fetchpvn_flags.  If it has a GV that has not been
installed in the symbol table yet, then the module will vivify that GV
on its own by a recursive call to gv_fetchpvn_flags (with the GV_ADD
flag, which does none of this temporary-dangling-GV stuff), and
gv_fetchpvn_flags will have a separate one which, when installed,
would clobber the one with the tied variable.

We solved that by having the GV installed right before calling the
module, for those three variables (in perl 5.16).

The implementation changed in commit v5.19.3-437-g930867a, which was
supposed to clean up the code and make it easier to follow.  Unfortun-
ately there was a bug in the implementation.  It tries to install the
GV for those cases *before* the magicalization code, but the logic is
wrong.  It checks to see whether we are adding only magical symbols
(addmg) and whether the GV has anything in it, but before anything has
been added to the GV.  So the symbol never gets installed.  Instead,
it just leaks, and the one that the implementing module vivifies
gets used.

This leak can be observed with XS::APItest::sv_count:

$ ./perl -Ilib -MXS::APItest -e 'for (1..10){ defined *{"!"}; delete $::{"!"}; warn sv_count  }'
3833 at -e line 1.
4496 at -e line 1.
4500 at -e line 1.
4504 at -e line 1.
4508 at -e line 1.
4512 at -e line 1.
4516 at -e line 1.
4520 at -e line 1.
4524 at -e line 1.
4528 at -e line 1.

Perl 5.18 does not exhibit the leak.

So in this commit I am finally implementing something that was dis-
cussed about the time that v5.19.3-437-g930867a was introduced.  To
avoid the whole problem of recursive calls to gv_fetchpvn_flags vying
over whose GV counts, I have stopped the implementing modules from
tying the variables themselves.  Instead, whichever gv_fetchpvn_flags
call is trying to create the glob is now responsible for seeing that
the variable is tied after the module is loaded.  Each module now pro-
vides a _tie_it function that gv_fetchpvn_flags can call.

One remaining infelicity is that Errno mentions $! in its source, so
*! will be vivified when it is loading, only to be clobbered by the
GV subsequently installed by gv_fetch_pvn_flags.  But at least it
will not leak.

One test that failed as a result of this (in t/op/magic.t) was try-
ing to undo the loading of Errno.pm in order to test it afresh with
*{"!"}.  But it did not remove *! before the test.  The new logic in
the code happens to work in such a way that the tiedness of the vari-
able determines whether the module needs to be loaded (which is neces-
sary, now that the module does not tie the variable).  Since the test
is by no means normal code, it seems reasonable to change it.

1 files changed, 46 insertions, 39 deletions

diff --git a/gv.c b/gv.c
index 4ea0917f50..cd1c32de77 100644
--- a/gv.c
+++ b/gv.c
@@ -1294,34 +1294,46 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 
 /* require_tie_mod() internal routine for requiring a module
  * that implements the logic of automatic ties like %! and %-
+ * It loads the module and then calls the _tie_it subroutine
+ * with the passed gv as an argument.
  *
  * The "gv" parameter should be the glob.
  * "varpv" holds the name of the var, used for error messages.
  * "namesv" holds the module name. Its refcount will be decremented.
- * "methpv" holds the method name to test for to check that things
- *   are working reasonably close to as expected.
  * "flags": if flag & 1 then save the scalar before loading.
  * For the protection of $! to work (it is set by this routine)
  * the sv slot must already be magicalized.
  */
-STATIC HV*
-S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
+STATIC void
+S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags)
 {
-    HV* stash = gv_stashsv(namesv, 0);
+    const char varname = *varpv; /* varpv might be clobbered by
+                                    load_module, so save it.  For the
+                                    moment it’s always a single char.  */
+    const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
 
     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 
-    if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
+    /* If it is not tied */
+    if (!target || !SvRMAGICAL(target)
+     || !mg_find(target,
+                 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
+    {
+      HV *stash;
+      GV **gvp;
+      dSP;
+
+      ENTER;
+      SAVEFREESV(namesv);
+
+#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0)
+
+      /* Load the module if it is not loaded.  */
+      if (!(stash = gv_stashsv(namesv, 0))
+       || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+      {
 	SV *module = newSVsv(namesv);
-	char varname = *varpv; /* varpv might be clobbered by load_module,
-				  so save it. For the moment it's always
-				  a single char. */
 	const char type = varname == '[' ? '$' : '%';
-#ifdef DEBUGGING
-	dSP;
-#endif
-	ENTER;
-	SAVEFREESV(namesv);
 	if ( flags & 1 )
 	    save_scalar(gv);
 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
@@ -1330,13 +1342,19 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp
 	if (!stash)
 	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
 		    type, varname, SVfARG(namesv));
-	else if (!gv_fetchmethod(stash, methpv))
-	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
-		    type, varname, SVfARG(namesv), methpv);
-	LEAVE;
+	else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not define _tie_it",
+		    type, varname, SVfARG(namesv));
+      }
+      /* Now call the tie function.  It should be in *gvp.  */
+      assert(gvp); assert(*gvp); assert(GvCV(*gvp));
+      PUSHMARK(SP);
+      XPUSHs((SV *)gv);
+      PUTBACK;
+      call_sv((SV *)*gvp, G_VOID|G_DISCARD);
+      LEAVE;
     }
     else SvREFCNT_dec_NN(namesv);
-    return stash;
 }
 
 /*
@@ -2064,10 +2082,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
 
             /* magicalization must be done before require_tie_mod is called */
 	    if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
-	    {
-		require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
-                addmg = FALSE;
-	    }
+		require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
 
 	    break;
 	case '-':		/* $- */
@@ -2084,10 +2099,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
-	    {
-                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
-                addmg = FALSE;
-	    }
+                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0);
 
             break;
 	}
@@ -2107,8 +2119,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
 	case '[':		/* $[ */
 	    if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
 	     && FEATURE_ARYBASE_IS_ENABLED) {
-		require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
-                addmg = FALSE;
+		require_tie_mod(gv,name,newSVpvs("arybase"),0);
 	    }
 	    else goto magicalize;
             break;
@@ -2196,9 +2207,9 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
 
     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
         if (*name == '!')
-            require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+            require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
         else if (*name == '-' || *name == '+')
-            require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+            require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0);
     } else if (sv_type == SVt_PV) {
         if (*name == '*' || *name == '#') {
             /* diag_listed_as: $* is no longer supported */
@@ -2210,7 +2221,7 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
       switch (*name) {
       case '[':
-          require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+          require_tie_mod(gv,name,newSVpvs("arybase"),0);
           break;
 #ifdef PERL_SAWAMPERSAND
       case '`':
@@ -2339,16 +2350,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
         GvMULTI_on(gv) ;
 
-    /* First, store the gv in the symtab if we're adding magic,
-     * but only for non-empty GVs
-     */
 #define GvEMPTY(gv)      !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
                         || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
     
-    if ( addmg && !GvEMPTY(gv) ) {
-        (void)hv_store(stash,name,len,(SV *)gv,0);
-    }
-
     /* set up magic where warranted */
     if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
         /* See 23496c6 */
@@ -2366,6 +2370,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                 gv = NULL;
             }
         }
+        else
+            /* Not empty; this means gv_magicalize magicalised it.  */
+            (void)hv_store(stash,name,len,(SV *)gv,0);
     }
     
     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);