summaryrefslogtreecommitdiff
path: root/op.c
diff options
context:
space:
mode:
authorFather Chrysostomos <sprout@cpan.org>2011-10-10 22:30:18 -0700
committerFather Chrysostomos <sprout@cpan.org>2011-10-10 22:31:38 -0700
commitfb834abdeb17d8cf13dd7590edf8842a8be6e8d7 (patch)
treecd35b9e9da6782503560245540e56921ef623488 /op.c
parent7a776c5a2a628b85aa74437f49111c0a28ff2ff1 (diff)
downloadperl-fb834abdeb17d8cf13dd7590edf8842a8be6e8d7.tar.gz
Stop attribute errors from leaking op trees
This commit moves attribute handling in newATTRSUB so that it happens after the op tree is attached to the sub. So when the sub is freed, the op tree goes with it, instead af leaking when an attribute han- dler dies. Witness what happens without that: $ PERL_DESTRUCT_LEVEL=2 ./perl -Ilib -le 'BEGIN {$^H{a}="b"}; sub foo:bar{1}' Invalid CODE attribute: bar at -e line 1 BEGIN failed--compilation aborted at -e line 1. Unbalanced string table refcount: (1) for "a" at (null) line 1 during global destruction. It was the ‘Unbalanced string table’ warnings that alerted me to the problem. The fairly new t/uni/attrs.t happens to trigger this bug. Not that this told me anything, but I did a binary search which lead me to this commit: commit b3ca2e834c3607fd8aa8736a51aa3a2b8bba1044 Author: Nicholas Clark <nick@ccl4.org> Date: Fri Mar 31 13:45:57 2006 +0000 Serialise changes to %^H onto the current COP. Return the compile time state of %^H as an eleventh value from caller. This allows users to write pragmas. That commit started indirectly storing HEKs in cops (in the hints hash), which means we have an easy way to tell when ops are leaking.
Diffstat (limited to 'op.c')
-rw-r--r--op.c17
1 files changed, 9 insertions, 8 deletions
diff --git a/op.c b/op.c
index 40053e5766..f54a105496 100644
--- a/op.c
+++ b/op.c
@@ -6670,12 +6670,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
- attrs:
- if (attrs) {
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
- }
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
@@ -6703,7 +6697,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
}
install_block:
if (!block)
- goto done;
+ goto attrs;
/* If we assign an optree to a PVCV, then we've defined a subroutine that
the debugger could be able to set a breakpoint in, so signal to
@@ -6743,7 +6737,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
CvCONST_on(cv);
}
- if (has_name) {
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
+
+ if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",