diff options
author | Father Chrysostomos <sprout@cpan.org> | 2011-10-10 22:30:18 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2011-10-10 22:31:38 -0700 |
commit | fb834abdeb17d8cf13dd7590edf8842a8be6e8d7 (patch) | |
tree | cd35b9e9da6782503560245540e56921ef623488 /op.c | |
parent | 7a776c5a2a628b85aa74437f49111c0a28ff2ff1 (diff) | |
download | perl-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.c | 17 |
1 files changed, 9 insertions, 8 deletions
@@ -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", |