In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/4ad0d3b9f11b33230f285a6e28f55f54490d90d8?hp=03a1fa1ec8c5ab3929f9d04fe91f45260062eb0e>
- Log -----------------------------------------------------------------
commit 4ad0d3b9f11b33230f285a6e28f55f54490d90d8
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 12:50:37 2016 +0100
newATTRSUB_x(): document what the cv var is for
M op.c
commit fd0ee382835b026ca650231794fffd52b6bf06f5
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 12:46:02 2016 +0100
make S_already_defined() in op.c return void
Currently it returns a boolean value, but after the removal of the MAD
code, this value is just equivalent to its 'block' arg; so instead just
make its callers test 'block' instead. This makes the calling code in
newATTRSUB_x and newMYSUB easier to follow.
Also, put the block condition on a single line (whitespace change)
M op.c
commit fc3b7ad1386606b102614ccb712d6c8c7a9fed4d
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 12:37:55 2016 +0100
reindent and reformat newMYSUB and newATTRSUB_x
This commit only contains whitespace changes.
As a follow-on from the previous commit, reindent a couple of block of
code; but also do a general re-indenting and partial refomatting of these
two similar functions, which were a bit of mess and hard to follow:
* replace weird mixtures of indents with standard 4-indents;
* split if (X) Y into two lines;
* separate out blocks with a blank line;
* outdent labels by exactly 2 spaces
M op.c
commit f6df9a2399f253aa91ac088837b425205fe9e6b7
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 12:08:56 2016 +0100
newMYSUB/Perl_newATTRSUB_x remove a goto
In both these functions there is code like:
if (!block)
goto attrs;
...
attrs:
Change them to
if (block) {
...
}
attrs:
Lets not use gotos if there's a better way.
Will re-indent in next commit.
M op.c
commit d1da3640384b1f8221ffa322a0ce6f7ff663a34c
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 11:52:23 2016 +0100
avoid using freed ops on BEGIN :attr {}
If a BEGIN sub has a code attribute applied (no idea why you would want to
do such a thing, but it's not illegal) then part of applying the attribute
is to do 'use attributes', which compiles
BEGIN { require "attributes"; attributes->import(AAA) }
so we end up compiling a BEGIN while in the middle of compiling a BEGIN.
The part of Perl_newATTRSUB_x() that under some circumstances copies
the body of the newly-compiled CV to the old CV which occupies the name
slot, kicks in here.
Since the ops that make up the AAA above were allocated from the old
BEGIN's op slabs, they get prematurely freed when the old BEGIN's
ops are discarded by the SvREFCNT_dec(PL_compcv).
The simplest fix is to just avoid the copy if we're compiling a BEGIN.
M op.c
M t/op/attrs.t
commit 27604593363c36604b7213ec7d405d21ef58f37b
Author: David Mitchell <da...@iabyn.com>
Date: Mon Sep 5 11:15:49 2016 +0100
do_sv_dump(): handle CvSTART() as slab address
If a CV is CvSLABBED(), then CvSTART() points to the op slab rather than a
start op. Make Perl_do_sv_dump() display this more informatively.
M dump.c
commit 68d1ee858a9172f8fd376b2e4aca1cf5b1ecfaeb
Author: David Mitchell <da...@iabyn.com>
Date: Sat Aug 27 14:28:24 2016 +0100
assert op not freed in finalize_op() and rpeep()
This should never happen.
M op.c
-----------------------------------------------------------------------
Summary of changes:
dump.c | 7 +-
op.c | 244 ++++++++++++++++++++++++++++++++++-------------------------
t/op/attrs.t | 21 +++++
3 files changed, 166 insertions(+), 106 deletions(-)
diff --git a/dump.c b/dump.c
index fd3d7cc..e69421b 100644
--- a/dump.c
+++ b/dump.c
@@ -1936,7 +1936,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv,
I32 nest, I32 maxnest, bo
do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
if (!CvISXSUB(sv)) {
if (CvSTART(sv)) {
- Perl_dump_indent(aTHX_ level, file,
+ if (CvSLABBED(sv))
+ Perl_dump_indent(aTHX_ level, file,
+ " SLAB = 0x%"UVxf"\n",
+ PTR2UV(CvSTART(sv)));
+ else
+ Perl_dump_indent(aTHX_ level, file,
" START = 0x%"UVxf" ===> %"IVdf"\n",
PTR2UV(CvSTART(sv)),
(IV)sequence_num(CvSTART(sv)));
diff --git a/op.c b/op.c
index cedc5e8..30b5024 100644
--- a/op.c
+++ b/op.c
@@ -2501,6 +2501,7 @@ S_finalize_op(pTHX_ OP* o)
{
PERL_ARGS_ASSERT_FINALIZE_OP;
+ assert(o->op_type != OP_FREED);
switch (o->op_type) {
case OP_NEXTSTATE:
@@ -7990,15 +7991,14 @@ S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
return sv;
}
-static bool
+static void
S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
PADNAME * const name, SV ** const const_svp)
{
assert (cv);
assert (o || name);
assert (const_svp);
- if ((!block
- )) {
+ if (!block) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
@@ -8014,7 +8014,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block,
OP * const o,
(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
& ~(CVf_LVALUE * pureperl));
}
- return FALSE;
+ return;
}
/* redundant check for speed: */
@@ -8036,7 +8036,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block,
OP * const o,
CopLINE_set(PL_curcop, oldline);
}
SAVEFREESV(cv);
- return TRUE;
+ return;
}
CV *
@@ -8070,7 +8070,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
outside, as in:
my sub foo; sub { sub foo { } }
*/
- redo:
+ redo:
name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
pax = PARENT_PAD_INDEX(name);
@@ -8168,10 +8168,12 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
ps_utf8);
/* already defined? */
if (exists) {
- if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
+ S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
@@ -8182,6 +8184,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
reusable = TRUE;
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
@@ -8207,6 +8210,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
PL_compcv = NULL;
goto setname;
}
+
/* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
determine whether this sub definition is in the same scope as its
declaration. If this sub definition is inside an inner named pack-
@@ -8219,10 +8223,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
CvWEAKOUTSIDE_on(compcv);
}
/* XXX else do we have a circular reference? */
+
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
- if (block
- ) {
+ if (block) {
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(cv);
@@ -8251,7 +8255,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
/* inner references to compcv must be fixed up ... */
pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
@@ -8265,7 +8269,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
cv = compcv;
*spot = cv;
}
- setname:
+
+ setname:
CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
if (hek) (void)share_hek_hek(hek);
@@ -8279,43 +8284,45 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
}
CvNAME_HEK_set(cv, hek);
}
- if (const_sv) goto clone;
+
+ if (const_sv)
+ goto clone;
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(cv));
}
- if (!block)
- 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
- pp_entereval that it should not throw away any saved lines at scope
- exit. */
-
- PL_breakable_sub_gen++;
- CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- /* The cv no longer needs to hold a refcount on the slab, as CvROOT
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* 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 pp_entereval that it should not throw away any
+ * saved lines at scope exit. */
+
+ PL_breakable_sub_gen++;
+ CvROOT(cv) = block;
+ CvROOT(cv)->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(CvROOT(cv), 1);
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
+ finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
- /* now that optimizer has done its work, adjust pad values */
+ /* now that optimizer has done its work, adjust pad values */
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
attrs:
if (attrs) {
@@ -8337,7 +8344,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
sv_catpvs(tmpstr, "::");
}
- else sv_setpvs(tmpstr, "__ANON__::");
+ else
+ sv_setpvs(tmpstr, "__ANON__::");
+
sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
@@ -8361,11 +8370,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
assert(CvDEPTH(outcv));
spot = (CV **)
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
- if (reusable) cv_clone_into(clonee, *spot);
+ if (reusable)
+ cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
SvREFCNT_dec_NN(clonee);
cv = *spot;
}
+
if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
PADOFFSET depth = CvDEPTH(outcv);
while (--depth) {
@@ -8389,6 +8400,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
return cv;
}
+
/* _x = extended */
CV *
Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
@@ -8398,7 +8410,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- CV *cv = NULL;
+ CV *cv = NULL; /* the previous CV with this name, if any */
SV *const_sv;
const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
@@ -8455,6 +8467,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
+
if (!ec) {
if (isGV(gv)) {
move_proto_attr(&proto, &attrs, gv);
@@ -8481,8 +8494,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
if (ec) {
op_free(block);
- if (name) SvREFCNT_dec(PL_compcv);
- else cv = PL_compcv;
+
+ if (name)
+ SvREFCNT_dec(PL_compcv);
+ else
+ cv = PL_compcv;
+
PL_compcv = 0;
if (name && block) {
const char *s = strrchr(name, ':');
@@ -8502,35 +8519,37 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
}
if (!block && SvTYPE(gv) != SVt_PVGV) {
- /* If we are not defining a new sub and the existing one is not a
- full GV + CV... */
- if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
- /* We are applying attributes to an existing sub, so we need it
- upgraded if it is a constant. */
- if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
- gv_init_pvn(gv, PL_curstash, name, namlen,
- SVf_UTF8 * name_is_utf8);
- }
- else { /* Maybe prototype now, and had at maximum
- a prototype or const/sub ref before. */
- if (SvTYPE(gv) > SVt_NULL) {
- cv_ckproto_len_flags((const CV *)gv,
- o ? (const GV *)cSVOPo->op_sv : NULL, ps,
- ps_len, ps_utf8);
- }
- if (!SvROK(gv)) {
- if (ps) {
- sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
- sv_setiv(MUTABLE_SV(gv), -1);
- }
+ /* If we are not defining a new sub and the existing one is not a
+ full GV + CV... */
+ if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+ /* We are applying attributes to an existing sub, so we need it
+ upgraded if it is a constant. */
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_init_pvn(gv, PL_curstash, name, namlen,
+ SVf_UTF8 * name_is_utf8);
+ }
+ else { /* Maybe prototype now, and had at maximum
+ a prototype or const/sub ref before. */
+ if (SvTYPE(gv) > SVt_NULL) {
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8);
+ }
- SvREFCNT_dec(PL_compcv);
- cv = PL_compcv = NULL;
- goto done;
- }
+ if (!SvROK(gv)) {
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(gv));
+ }
+ else
+ sv_setiv(MUTABLE_SV(gv), -1);
+ }
+
+ SvREFCNT_dec(PL_compcv);
+ cv = PL_compcv = NULL;
+ goto done;
+ }
}
cv = (!name || (isGV(gv) && GvCVGEN(gv)))
@@ -8612,16 +8631,19 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || (isGV(gv) && GvASSUMECV(gv))) {
- if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
@@ -8661,10 +8683,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
PL_compcv = NULL;
goto done;
}
+
+ /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
+ if (name && *name == 'B' && strEQ(name, "BEGIN"))
+ cv = NULL;
+
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
- if (block
- ) {
+ if (block) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
@@ -8704,14 +8730,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
- }
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
/* 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;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
@@ -8740,8 +8766,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
SvRV_set(gv, (SV *)cv);
}
}
+
if (!CvHASGV(cv)) {
- if (isGV(gv)) CvGV_set(cv, gv);
+ if (isGV(gv))
+ CvGV_set(cv, gv);
else {
dVAR;
U32 hash;
@@ -8758,36 +8786,36 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ if ( ps_utf8 )
+ SvUTF8_on(MUTABLE_SV(cv));
}
- if (!block)
- 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
- pp_entereval that it should not throw away any saved lines at scope
- exit. */
-
- PL_breakable_sub_gen++;
- CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- /* The cv no longer needs to hold a refcount on the slab, as CvROOT
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* 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 pp_entereval that it should not throw away any
+ * saved lines at scope exit. */
+
+ PL_breakable_sub_gen++;
+ CvROOT(cv) = block;
+ CvROOT(cv)->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(CvROOT(cv), 1);
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
+ finalize_optree(CvROOT(cv));
+ S_prune_chain_head(&CvSTART(cv));
- /* now that optimizer has done its work, adjust pad values */
+ /* now that optimizer has done its work, adjust pad values */
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
attrs:
if (attrs) {
@@ -8795,9 +8823,11 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
? GvSTASH(CvGV(cv))
: PL_curstash;
- if (!name) SAVEFREESV(cv);
+ if (!name)
+ SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
- if (!name) SvREFCNT_inc_simple_void_NN(cv);
+ if (!name)
+ SvREFCNT_inc_simple_void_NN(cv);
}
if (block && has_name) {
@@ -8838,12 +8868,13 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+
if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
- if (slab)
+ if (slab)
Slab_to_ro(slab);
#endif
- if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
+ if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
pad_add_weakref(cv);
}
return cv;
@@ -13297,6 +13328,9 @@ Perl_rpeep(pTHX_ OP *o)
if (!o || o->op_opt)
return;
+
+ assert(o->op_type != OP_FREED);
+
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
diff --git a/t/op/attrs.t b/t/op/attrs.t
index 23b00ca..318a9d6 100644
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -447,4 +447,25 @@ package P126257 {
::is $@, "", "RT 126257 sub";
}
+# RT #129099
+# Setting an attribute on a BEGIN prototype causes
+# BEGIN { require "attributes"; ... }
+# to be compiled, which caused problems with ops being prematurely
+# freed when CvSTART was transferred from the old BEGIN to the new BEGIN
+
+is runperl(
+ prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} '
+ . 'sub BEGIN :Foo; print q{OK}',
+ stderr => 1,
+ ),
+ "OK",
+ 'RT #129099 BEGIN';
+is runperl(
+ prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} '
+ . 'no warnings q{prototype}; sub BEGIN() :Foo; print q{OK}',
+ stderr => 1,
+ ),
+ "OK",
+ 'RT #129099 BEGIN()';
+
done_testing();
--
Perl5 Master Repository
