From: Zefram Date: Sun, 6 Sep 2009 15:29:43 +0000 (+0200) Subject: Fix [perl #66970] Incorrect coderef in MODIFY_CODE_ATTRIBUTES X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09330df80caf214f375fcf0c04857347e3b17c69;p=p5sagit%2Fp5-mst-13.2.git Fix [perl #66970] Incorrect coderef in MODIFY_CODE_ATTRIBUTES Attribute handlers being applied to a temporary CV has actually been reported as a bug, #66970. The attached patch fixes the bug, by changing the order in which things happen: attributes are now applied after the temporary CV has been merged into the existing CV or has otherwise been added to the appropriate GV. The change breaks part of Attribute::Handlers. Part of A:H searches the package to find the name of the sub to which a :ATTR attribute is being applied, and the correct time at which to launch that search depends crucially on the order in which the CV construction events occur. So this patch also includes a change to A:H, to make it detect which way things happen. The resulting A:H works either way, which is essential for its dual-life nature. --- diff --git a/ext/Attribute-Handlers/lib/Attribute/Handlers.pm b/ext/Attribute-Handlers/lib/Attribute/Handlers.pm index 930a1a6..b8625ae 100644 --- a/ext/Attribute-Handlers/lib/Attribute/Handlers.pm +++ b/ext/Attribute-Handlers/lib/Attribute/Handlers.pm @@ -90,6 +90,29 @@ sub import { } } } + +# On older perls, code attribute handlers run before the sub gets placed +# in its package. Since the :ATTR handlers need to know the name of the +# sub they're applied to, the name lookup (via findsym) needs to be +# delayed: we do it immediately before we might need to find attribute +# handlers from their name. However, on newer perls (which fix some +# problems relating to attribute application), a sub gets placed in its +# package before its attributes are processed. In this case, the +# delayed name lookup might be too late, because the sub we're looking +# for might have already been replaced. So we need to detect which way +# round this perl does things, and time the name lookup accordingly. +BEGIN { + my $delayed; + sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES { + $delayed = \&Attribute::Handlers::_TEST_::t != $_[1]; + return (); + } + sub Attribute::Handlers::_TEST_::t :T { } + *_delayed_name_resolution = sub() { $delayed }; + undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES; + undef &Attribute::Handlers::_TEST_::t; +} + sub _resolve_lastattr { return unless $lastattr{ref}; my $sym = findsym @lastattr{'pkg','ref'} @@ -116,7 +139,7 @@ my $builtin = qr/lvalue|method|locked|unique|shared/; sub _gen_handler_AH_() { return sub { - _resolve_lastattr; + _resolve_lastattr if _delayed_name_resolution; my ($pkg, $ref, @attrs) = @_; my (undef, $filename, $linenum) = caller 2; foreach (@attrs) { @@ -141,6 +164,7 @@ sub _gen_handler_AH_() { croak "Bad attribute type: ATTR($data)" unless $validtype{$data}; %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data); + _resolve_lastattr unless _delayed_name_resolution; } else { my $type = ref $ref; @@ -212,7 +236,7 @@ sub _apply_handler_AH_ { no warnings 'void'; CHECK { $global_phase++; - _resolve_lastattr; + _resolve_lastattr if _delayed_name_resolution; _apply_handler_AH_($_,'CHECK') foreach @declarations; } diff --git a/op.c b/op.c index db5dea8..c6f38fa 100644 --- a/op.c +++ b/op.c @@ -5692,69 +5692,34 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_compcv = NULL; goto done; } - if (attrs) { - HV *stash; - SV *rcv; - - /* Need to do a C - * before we clobber PL_compcv. - */ - if (cv && (!block + if (cv) { /* must reuse cv if autoloaded */ + /* transfer PL_compcv to cv */ + if (block #ifdef PERL_MAD - || block->op_type == OP_NULL + && block->op_type != OP_NULL #endif - )) { - rcv = MUTABLE_SV(cv); - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); - if (CvGV(cv) && GvSTASH(CvGV(cv))) - stash = GvSTASH(CvGV(cv)); - else if (CvSTASH(cv)) - stash = CvSTASH(cv); - else - stash = PL_curstash; + ) { + cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(PL_compcv); + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvOUTSIDE(PL_compcv) = 0; + CvPADLIST(cv) = CvPADLIST(PL_compcv); + CvPADLIST(PL_compcv) = 0; + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; } else { - /* possibly about to re-define existing subr -- ignore old cv */ - rcv = MUTABLE_SV(PL_compcv); - if (name && GvSTASH(gv)) - stash = GvSTASH(gv); - else - stash = PL_curstash; - } - apply_attrs(stash, rcv, attrs, FALSE); - } - if (cv) { /* must reuse cv if autoloaded */ - if ( -#ifdef PERL_MAD - ( -#endif - !block -#ifdef PERL_MAD - || block->op_type == OP_NULL) && !PL_madskills -#endif - ) { - /* got here with just attrs -- work done, so bug out */ - SAVEFREESV(PL_compcv); - goto done; + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } - /* transfer PL_compcv to cv */ - cv_undef(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv); - if (!CvWEAKOUTSIDE(cv)) - SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvOUTSIDE(PL_compcv) = 0; - CvPADLIST(cv) = CvPADLIST(PL_compcv); - CvPADLIST(PL_compcv) = 0; - /* inner references to PL_compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); PL_compcv = cv; - if (PERLDB_INTER)/* Advice debugger on the new sub. */ - ++PL_sub_generation; } else { cv = PL_compcv; @@ -5770,9 +5735,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } - CvGV(cv) = gv; - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH(cv) = PL_curstash; + if (!CvGV(cv)) { + CvGV(cv) = gv; + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH(cv) = PL_curstash; + } + if (attrs) { + /* Need to do a C. */ + 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); diff --git a/t/op/attrs.t b/t/op/attrs.t index 92b5b9e..ef6867d 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -14,7 +14,7 @@ BEGIN { use warnings; -plan 84; +plan 90; $SIG{__WARN__} = sub { die @_ }; @@ -196,3 +196,33 @@ sub PVBM () { 'foo' } ok !defined(attributes::get(\PVBM)), 'PVBMs don\'t segfault attributes::get'; + +# Test that code attributes always get applied to the same CV that +# we're left with at the end (bug#66970). +{ + package bug66970; + our $c; + sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } + $c=undef; eval 'sub t0 :Foo'; + main::ok $c == \&{"t0"}; + $c=undef; eval 'sub t1 :Foo { }'; + main::ok $c == \&{"t1"}; + $c=undef; eval 'sub t2'; + our $t2a = \&{"t2"}; + $c=undef; eval 'sub t2 :Foo'; + main::ok $c == \&{"t2"} && $c == $t2a; + $c=undef; eval 'sub t3'; + our $t3a = \&{"t3"}; + $c=undef; eval 'sub t3 :Foo { }'; + main::ok $c == \&{"t3"} && $c == $t3a; + $c=undef; eval 'sub t4 :Foo'; + our $t4a = \&{"t4"}; + our $t4b = $c; + $c=undef; eval 'sub t4 :Foo'; + main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; + $c=undef; eval 'sub t5 :Foo'; + our $t5a = \&{"t5"}; + our $t5b = $c; + $c=undef; eval 'sub t5 :Foo { }'; + main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; +}