diff options
| -rw-r--r-- | ext/Attribute-Handlers/lib/Attribute/Handlers.pm | 28 | ||||
| -rw-r--r-- | op.c | 88 | ||||
| -rw-r--r-- | t/op/attrs.t | 32 |
3 files changed, 87 insertions, 61 deletions
diff --git a/ext/Attribute-Handlers/lib/Attribute/Handlers.pm b/ext/Attribute-Handlers/lib/Attribute/Handlers.pm index 930a1a6750..b8625ae0f4 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; } @@ -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<use attributes $stash_of_cv,\&cv,@attrs> - * 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<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); diff --git a/t/op/attrs.t b/t/op/attrs.t index 92b5b9ec18..ef6867dabc 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; +} |