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.

diff --git a/op.c b/op.c
index 40053e5..f54a105 100644 (file)
--- 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",

diff --git a/t/op/attrs.t b/t/op/attrs.t
index 339e5da..f3d1165 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -366,4 +366,11 @@ foreach my $test (@tests) {
   is $w, "", 'no -lvalue warnings under no warnings misc';
 }
 
+unlike runperl(
+         prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}',
+         stderr => 1,
+       ),
+       qr/Unbalanced/,
+      'attribute errors do not cause op trees to leak';
+
 done_testing();