This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rework mod loading for %- and %!; fix mem leak
authorFather Chrysostomos <sprout@cpan.org>
Thu, 4 Aug 2016 20:00:18 +0000 (13:00 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 4 Aug 2016 20:12:19 +0000 (13:12 -0700)
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.

embed.fnc
embed.h
ext/Errno/Errno_pm.PL
ext/Tie-Hash-NamedCapture/NamedCapture.xs
ext/arybase/arybase.xs
gv.c
proto.h
t/op/magic.t
t/op/svleak.t

index 5f2c580..61c9296 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1938,8 +1938,8 @@ s  |bool|gv_magicalize|NN GV *gv|NN HV *stash|NN const char *name \
 s  |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type
 s  |bool|gv_is_in_main|NN const char *name|STRLEN len \
                       |const U32 is_utf8
-s      |HV*    |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
-                               |NN const char *methpv|const U32 flags
+s      |void   |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
+                               |const U32 flags
 #endif
 
 #if defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)
diff --git a/embed.h b/embed.h
index 930ea91..3e43529 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define gv_stashsvpvn_cached(a,b,c,d)  S_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
 #define maybe_multimagic_gv(a,b,c)     S_maybe_multimagic_gv(aTHX_ a,b,c)
 #define parse_gv_stash_name(a,b,c,d,e,f,g,h)   S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h)
-#define require_tie_mod(a,b,c,d,e)     S_require_tie_mod(aTHX_ a,b,c,d,e)
+#define require_tie_mod(a,b,c,d)       S_require_tie_mod(aTHX_ a,b,c,d)
 #  endif
 #  if defined(PERL_IN_HV_C)
 #define clear_placeholders(a,b)        S_clear_placeholders(aTHX_ a,b)
index 6251a3c..37806eb 100644 (file)
@@ -391,6 +391,7 @@ sub STORE {
     Carp::confess("ERRNO hash is read only!");
 }
 
+# This is the true return value
 *CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
 
 sub NEXTKEY {
@@ -407,7 +408,9 @@ sub EXISTS {
     exists $err{$errname};
 }
 
-tie %!, __PACKAGE__; # Returns an object, objects are true.
+sub _tie_it {
+    tie %{$_[0]}, __PACKAGE__;
+}
 
 __END__
 
index 04cc463..7eaae56 100644 (file)
 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
 
-static void
-tie_it(pTHX_ const char name, UV flag, HV *const stash)
-{
-    GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
-    HV *const hv = GvHV(gv);
-    SV *rv = newSV_type(SVt_RV);
+MODULE = Tie::Hash::NamedCapture       PACKAGE = Tie::Hash::NamedCapture
+PROTOTYPES: DISABLE
 
-    SvRV_set(rv, newSVuv(flag));
+void
+_tie_it(SV *sv)
+  INIT:
+    GV * const gv = (GV *)sv;
+    HV * const hv = GvHVn(gv);
+    SV *rv = newSV_type(SVt_RV);
+  CODE:
+    SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
     SvROK_on(rv);
-    sv_bless(rv, stash);
+    sv_bless(rv, GvSTASH(CvGV(cv)));
 
     sv_unmagic((SV *)hv, PERL_MAGIC_tied);
     sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
-}
-
-MODULE = Tie::Hash::NamedCapture       PACKAGE = Tie::Hash::NamedCapture
-PROTOTYPES: DISABLE
-
-BOOT:
-       {
-           HV *const stash = GvSTASH(CvGV(cv));
-           tie_it(aTHX_ '-', RXapif_ALL, stash);
-           tie_it(aTHX_ '+', RXapif_ONE, stash);
-       }
 
 SV *
 TIEHASH(package, ...)
index 4ff6cbd..880bbe3 100644 (file)
@@ -410,10 +410,6 @@ PROTOTYPES: DISABLE
 
 BOOT:
 {
-    GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
-    sv_unmagic(GvSV(gv), PERL_MAGIC_sv); /* This is *our* scalar now! */
-    tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
-
     if (!ab_initialized++) {
        ab_op_map = ptable_new();
 #ifdef USE_ITHREADS
@@ -438,6 +434,16 @@ BOOT:
 }
 
 void
+_tie_it(SV *sv)
+    INIT:
+       GV * const gv = (GV *)sv;
+    CODE:
+       if (GvSV(gv))
+           /* This is *our* scalar now!  */
+           sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
+       tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));
+
+void
 FETCH(...)
     PREINIT:
        SV *ret = FEATURE_ARYBASE_IS_ENABLED
diff --git a/gv.c b/gv.c
index 4ea0917..cd1c32d 100644 (file)
--- 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);
diff --git a/proto.h b/proto.h
index fa72319..d3918b1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4324,9 +4324,9 @@ STATIC void       S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype s
 STATIC bool    S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, STRLEN *len, const char *nambeg, STRLEN full_len, const U32 is_utf8, const I32 add);
 #define PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME   \
        assert(stash); assert(gv); assert(name); assert(len); assert(nambeg)
-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);
 #define PERL_ARGS_ASSERT_REQUIRE_TIE_MOD       \
-       assert(gv); assert(varpv); assert(namesv); assert(methpv)
+       assert(gv); assert(varpv); assert(namesv)
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 PERL_CALLCONV void     Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv);
index ad90749..536b225 100644 (file)
@@ -466,6 +466,7 @@ SKIP:  {
 
     undef %Errno::;
     delete $INC{"Errno.pm"};
+    delete $::{"!"};
 
     open(FOO, "nonesuch"); # Generate ENOENT
     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
index c18f498..77ff9ae 100644 (file)
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 132;
+plan tests => 138;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -78,6 +78,19 @@ leak(5, 1, sub {push @a,1;},       "basic check 3 of leak test infrastructure");
        'delete local on nonexistent env var');
 }
 
+# defined
+leak(2, 0, sub { defined *{"!"} }, 'defined *{"!"}');
+leak(2, 0, sub { defined *{"["} }, 'defined *{"["}');
+leak(2, 0, sub { defined *{"-"} }, 'defined *{"-"}');
+sub def_bang { defined *{"!"}; delete $::{"!"} }
+def_bang;
+leak(2, 0, \&def_bang,'defined *{"!"} vivifying GV');
+leak(2, 0, sub { defined *{"["}; delete $::{"["} },
+    'defined *{"["} vivifying GV');
+sub def_neg { defined *{"-"}; delete $::{"-"} }
+def_neg;
+leak(2, 0, \&def_neg, 'defined *{"-"} vivifying GV');
+
 # Fatal warnings
 my $f = "use warnings FATAL =>";
 my $all = "$f 'all';";