This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #36347] Object destruction incomplete
authorFather Chrysostomos <sprout@cpan.org>
Sun, 2 Jan 2011 22:51:21 +0000 (14:51 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 3 Jan 2011 02:33:05 +0000 (18:33 -0800)
do_clean_objs only looks for objects referenced by RVs, so blessed
array references and lexical variables (and probably other SVs, too)
are not DESTROYed.

This commit adds a new visit() call to sv_clean_objs, which curses
(DESTROYs and un-blesses, leaving the reference count as it is) any
objects that are still left after do_clean_named_io_objs. The new
do_curse routine (a pointer to which is passeds to visit()) follows
do_clean_named_io_objs’ example and explicitly skips the STDOUT and
STDERR handles, in case destructors need to use them.

The cursing code, which is now called from two places, is moved out of
sv_clear and put in its own routine. The check that the reference
count is zero does not apply when called from sv_clean_objs, so the
new S_curse routine takes a boolean argument that determines whether
that check should take place.

embed.fnc
embed.h
proto.h
sv.c

index ab95766..57d71d6 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1169,6 +1169,9 @@ pd        |I32    |sv_clean_all
 : Used only in perl.c
 pd     |void   |sv_clean_objs
 Apd    |void   |sv_clear       |NN SV *const orig_sv
+#if defined(PERL_IN_SV_C)
+s      |bool   |curse          |NN SV * const sv|const bool check_refcnt
+#endif
 Aopd   |I32    |sv_cmp         |NULLOK SV *const sv1|NULLOK SV *const sv2
 Apd    |I32    |sv_cmp_flags   |NULLOK SV *const sv1|NULLOK SV *const sv2 \
                                |const U32 flags
diff --git a/embed.h b/embed.h
index 083588e..e393a01 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define F0convert              S_F0convert
 #define anonymise_cv_maybe(a,b)        S_anonymise_cv_maybe(aTHX_ a,b)
 #define assert_uft8_cache_coherent(a,b,c,d)    S_assert_uft8_cache_coherent(aTHX_ a,b,c,d)
+#define curse(a,b)             S_curse(aTHX_ a,b)
 #define expect_number(a)       S_expect_number(aTHX_ a)
 #define find_array_subscript(a,b)      S_find_array_subscript(aTHX_ a,b)
 #define find_hash_subscript(a,b)       S_find_hash_subscript(aTHX_ a,b)
diff --git a/proto.h b/proto.h
index 769d3bd..74c4138 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6575,6 +6575,11 @@ STATIC void      S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN fr
 #define PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT    \
        assert(func); assert(sv)
 
+STATIC bool    S_curse(pTHX_ SV * const sv, const bool check_refcnt)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CURSE \
+       assert(sv)
+
 STATIC I32     S_expect_number(pTHX_ char **const pattern)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
diff --git a/sv.c b/sv.c
index 071ec45..160b132 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -551,6 +551,15 @@ do_clean_named_io_objs(pTHX_ SV *const sv)
     SvREFCNT_dec(sv); /* undo the inc above */
 }
 
+/* Void wrapper to pass to visit() */
+static void
+do_curse(pTHX_ SV * const sv) {
+    if ((PL_stderrgv && GvGP(PL_stderrgv) && GvIO(PL_stderrgv) == sv)
+     || (PL_defoutgv && GvGP(PL_defoutgv) && GvIO(PL_defoutgv) == sv))
+       return;
+    (void)curse(sv, 0);
+}
+
 /*
 =for apidoc sv_clean_objs
 
@@ -571,6 +580,9 @@ Perl_sv_clean_objs(pTHX)
      * error messages, close files etc */
     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+    /* And if there are some very tenacious barnacles clinging to arrays,
+       closures, or what have you.... */
+    visit(do_curse, SVs_OBJECT, SVs_OBJECT);
     olddef = PL_defoutgv;
     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
     if (olddef && isGV_with_GP(olddef))
@@ -5979,65 +5991,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
        }
 
        if (SvOBJECT(sv)) {
-           if (PL_defstash &&  /* Still have a symbol table? */
-               SvDESTROYABLE(sv))
-           {
-               dSP;
-               HV* stash;
-               do {
-                   CV* destructor;
-                   stash = SvSTASH(sv);
-                   destructor = StashHANDLER(stash,DESTROY);
-                   if (destructor
-                       /* A constant subroutine can have no side effects, so
-                          don't bother calling it.  */
-                       && !CvCONST(destructor)
-                       /* Don't bother calling an empty destructor */
-                       && (CvISXSUB(destructor)
-                       || (CvSTART(destructor)
-                           && (CvSTART(destructor)->op_next->op_type
-                                               != OP_LEAVESUB))))
-                   {
-                       SV* const tmpref = newRV(sv);
-                       SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
-                       ENTER;
-                       PUSHSTACKi(PERLSI_DESTROY);
-                       EXTEND(SP, 2);
-                       PUSHMARK(SP);
-                       PUSHs(tmpref);
-                       PUTBACK;
-                       call_sv(MUTABLE_SV(destructor),
-                                   G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-                       POPSTACK;
-                       SPAGAIN;
-                       LEAVE;
-                       if(SvREFCNT(tmpref) < 2) {
-                           /* tmpref is not kept alive! */
-                           SvREFCNT(sv)--;
-                           SvRV_set(tmpref, NULL);
-                           SvROK_off(tmpref);
-                       }
-                       SvREFCNT_dec(tmpref);
-                   }
-               } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
-
-
-               if (SvREFCNT(sv)) {
-                   if (PL_in_clean_objs)
-                       Perl_croak(aTHX_
-                           "DESTROY created new reference to dead object '%s'",
-                           HvNAME_get(stash));
-                   /* DESTROY gave object new lease on life */
-                   goto get_next_sv;
-               }
-           }
-
-           if (SvOBJECT(sv)) {
-               SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
-               SvOBJECT_off(sv);       /* Curse the object. */
-               if (type != SVt_PVIO)
-                   --PL_sv_objcount;/* XXX Might want something more general */
-           }
+           if (!curse(sv, 1)) goto get_next_sv;
        }
        if (type >= SVt_PVMG) {
            if (type == SVt_PVMG && SvPAD_OUR(sv)) {
@@ -6263,6 +6217,78 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
     } /* while sv */
 }
 
+/* This routine curses the sv itself, not the object referenced by sv. So
+   sv does not have to be ROK. */
+
+static bool
+S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
+    dVAR;
+
+    PERL_ARGS_ASSERT_CURSE;
+    assert(SvOBJECT(sv));
+
+    if (PL_defstash && /* Still have a symbol table? */
+       SvDESTROYABLE(sv))
+    {
+       dSP;
+       HV* stash;
+       do {
+           CV* destructor;
+           stash = SvSTASH(sv);
+           destructor = StashHANDLER(stash,DESTROY);
+           if (destructor
+               /* A constant subroutine can have no side effects, so
+                  don't bother calling it.  */
+               && !CvCONST(destructor)
+               /* Don't bother calling an empty destructor */
+               && (CvISXSUB(destructor)
+               || (CvSTART(destructor)
+                   && (CvSTART(destructor)->op_next->op_type
+                                       != OP_LEAVESUB))))
+           {
+               SV* const tmpref = newRV(sv);
+               SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+               ENTER;
+               PUSHSTACKi(PERLSI_DESTROY);
+               EXTEND(SP, 2);
+               PUSHMARK(SP);
+               PUSHs(tmpref);
+               PUTBACK;
+               call_sv(MUTABLE_SV(destructor),
+                           G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+               POPSTACK;
+               SPAGAIN;
+               LEAVE;
+               if(SvREFCNT(tmpref) < 2) {
+                   /* tmpref is not kept alive! */
+                   SvREFCNT(sv)--;
+                   SvRV_set(tmpref, NULL);
+                   SvROK_off(tmpref);
+               }
+               SvREFCNT_dec(tmpref);
+           }
+       } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+
+       if (check_refcnt && SvREFCNT(sv)) {
+           if (PL_in_clean_objs)
+               Perl_croak(aTHX_
+                   "DESTROY created new reference to dead object '%s'",
+                   HvNAME_get(stash));
+           /* DESTROY gave object new lease on life */
+           return FALSE;
+       }
+    }
+
+    if (SvOBJECT(sv)) {
+       SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+       SvOBJECT_off(sv);       /* Curse the object. */
+       if (SvTYPE(sv) != SVt_PVIO)
+           --PL_sv_objcount;/* XXX Might want something more general */
+    }
+    return TRUE;
+}
+
 /*
 =for apidoc sv_newref