}
}
}
+
+# 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'}
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) {
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;
no warnings 'void';
CHECK {
$global_phase++;
- _resolve_lastattr;
+ _resolve_lastattr if _delayed_name_resolution;
_apply_handler_AH_($_,'CHECK') foreach @declarations;
}
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;
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);
use warnings;
-plan 84;
+plan 90;
$SIG{__WARN__} = sub { die @_ };
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;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff