New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Object destruction incomplete #7981
Comments
From @nwc10Created by @nwc10It's possible to create objects that never get destroyed. Tersest example: #!perl -w package M; bless \($a[0]), "M"; Without the undef @::a; it will never call the destructor, because Should we replace the use of do_clean_named_objs() with a routine that Nicholas Clark Perl Info
|
From @cpansproutOn Tue Jun 21 06:52:36 2005, nicholas wrote:
Doing so would allow destructors to see freed SVs. Instead, how’s this patch? It still needs tests and a commit message. Watch: $ perl -le' sub DESTROY{warn aaa}bless\$a[0]' |
From @cpansproutInline Patchdiff --git a/embed.fnc b/embed.fnc
index fe8f43c..88e179b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1167,6 +1167,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 d484a10..6a4e48e 100644
--- a/embed.h
+++ b/embed.h
@@ -1776,6 +1776,7 @@
#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 a05f2b9..92202de 100644
--- a/proto.h
+++ b/proto.h
@@ -6567,6 +6567,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 92634e1..598c29a 100644
--- a/sv.c
+++ b/sv.c
@@ -542,6 +542,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) && GvSV(PL_stderrgv) == sv)
+ || (PL_defoutgv && GvGP(PL_defoutgv) && GvSV(PL_defoutgv) == sv))
+ return;
+ (void)curse(sv, 0);
+}
+
/*
=for apidoc sv_clean_objs
@@ -562,6 +571,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))
@@ -5948,65 +5960,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)) {
@@ -6232,6 +6186,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
|
The RT System itself - Status changed from 'new' to 'open' |
From @iabynOn Sun, Dec 12, 2010 at 01:00:17PM -0800, Father Chrysostomos via RT wrote:
Looks plausible. I don't understand why you skip $STDOUT and $STDERR -- |
From @cpansproutOn Tue Dec 14 15:57:54 2010, davem wrote:
do_clean_named_io_objs does the same thing. I thought it was so that |
From @iabynOn Sun, Dec 19, 2010 at 02:31:48PM -0800, Father Chrysostomos via RT wrote:
do_clean_named_io_objs() skips the STDOUT and STDERR filehandles; your -- |
From @cpansproutOn Sun Dec 19 14:54:14 2010, davem wrote:
Oh dear. So it does. That was really, really stupid of me. :-) If I change the each instance of GvSV to GvIO in that statement, does |
From @iabynOn Sun, Dec 19, 2010 at 06:05:19PM -0800, Father Chrysostomos via RT wrote:
yes :-) -- |
From @cpansproutOn Mon Dec 20 02:30:37 2010, davem wrote:
Now tweaked and applied as 4155e4f. |
@cpansprout - Status changed from 'open' to 'resolved' |
From @cpansproutRe-opening this ticket, as the fix, which broke three CPAN modules, has |
@cpansprout - Status changed from 'resolved' to 'open' |
From @cpansproutOn Sun Jan 30 19:04:03 2011, sprout wrote:
And now it has been re-enabled by commit 640c0c3. |
@cpansprout - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#36347 (status was 'resolved')
Searchable as RT36347$
The text was updated successfully, but these errors were encountered: