In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/7e68c38b607a044ee5879e316bb8a7347284ec8e?hp=6fa2c250307a2b1de4850e25cb3eb81bc16c7244>
- Log ----------------------------------------------------------------- commit 7e68c38b607a044ee5879e316bb8a7347284ec8e Author: Father Chrysostomos <[email protected]> Date: Mon Jan 23 21:45:21 2012 -0800 [rt.cpan.org #74289] Donât make *CORE::foo read-only newATTRSUB requires the sub name to be passed to it wrapped up in a const op. Commit 8756617677dbd allowed it to accept a GV that way, since S_maybe_add_coresub (in gv.c) needed to pass it an existing GV not in the symbol table yet (to simplify code elsewhere). This had the inadvertent side-effect of making the GV read-only, since thatâs what the check function for const ops does. Even if we were to call this a feature, it wouldnât make sense as implemented, as GVs for non-ampable (&-able) subs like *CORE::chdir were not being made read-only. This commit adds a new flag to newATTRSUB, to allow a GV to be passed as the o parameter, instead of an op. While this may look as though itâs undoing the simplification in commit 8756617677dbd by adding more code, the new code is still conceptually simpler and more straightforward. Since newATTRSUB is in the API, I had to add a new _flags variant. (How did newATTRSUB get into the API to begin with?) In adding a test, I also discovered that âused onceâ warnings were applying to these subs, which is obviously wrong. Commit 8756617677dbd caused that, too, as it was relying on the side-effect of newATTRSUB doing a GV lookup. This fixes that, too, by turning on the multi flag in S_maybe_add_coresub. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 3 +++ embed.h | 1 + gv.c | 8 +++++--- op.c | 23 +++++++++++++++++------ proto.h | 1 + t/op/coresubs.t | 4 ++++ 6 files changed, 31 insertions(+), 9 deletions(-) diff --git a/embed.fnc b/embed.fnc index d6980d6..3d79971 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1590,6 +1590,9 @@ Apd |SV* |sv_rvweaken |NN SV *const sv p |int |magic_killbackrefs|NN SV *sv|NN MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block Ap |CV* |newATTRSUB |I32 floor|NULLOK OP *o|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block +p |CV* |newATTRSUB_flags|I32 floor|NULLOK OP *o|NULLOK OP *proto \ + |NULLOK OP *attrs|NULLOK OP *block \ + |U32 flags #ifdef PERL_MAD Apr |OP * |newMYSUB |I32 floor|NULLOK OP *o|NULLOK OP *proto \ |NULLOK OP *attrs|NULLOK OP *block diff --git a/embed.h b/embed.h index ce0048d..93d265f 100644 --- a/embed.h +++ b/embed.h @@ -1146,6 +1146,7 @@ #define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a) #define my_swabn Perl_my_swabn #define my_unexec() Perl_my_unexec(aTHX) +#define newATTRSUB_flags(a,b,c,d,e,f) Perl_newATTRSUB_flags(aTHX_ a,b,c,d,e,f) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) #define nextargv(a) Perl_nextargv(aTHX_ a) #define oopsAV(a) Perl_oopsAV(aTHX_ a) diff --git a/gv.c b/gv.c index af8f289..e99af67 100644 --- a/gv.c +++ b/gv.c @@ -482,6 +482,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, gv = (GV *)newSV(0); gv_init(gv, stash, name, len, TRUE); } + GvMULTI_on(gv); if (ampable) { ENTER; oldcurcop = PL_curcop; @@ -516,15 +517,16 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { CvLVALUE_on(cv); - newATTRSUB(oldsavestack_ix, - newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(gv)), + newATTRSUB_flags( + oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( opnum ? newSVuv((UV)opnum) : newSVpvn(name,len), code, opnum - ) + ), + 1 ); assert(GvCV(gv) == cv); if (opnum != OP_VEC && opnum != OP_SUBSTR) diff --git a/op.c b/op.c index 1d35396..72232ea 100644 --- a/op.c +++ b/op.c @@ -6445,6 +6445,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { + return newATTRSUB_flags(floor, o, proto, attrs, block, 0); +} + +CV * +Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, U32 flags) +{ dVAR; GV *gv; const char *ps; @@ -6462,9 +6469,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; - const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL; + const bool o_is_gv = flags & 1; + const char * const name = + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; - bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0; + bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -6474,10 +6483,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (name) { - gv = isGV(cSVOPo->op_sv) - ? (GV *)cSVOPo->op_sv - : gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + if (o_is_gv) { + gv = (GV*)o; + o = NULL; + has_name = TRUE; + } else if (name) { + gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); diff --git a/proto.h b/proto.h index fcf5ab9..f0f7788 100644 --- a/proto.h +++ b/proto.h @@ -2548,6 +2548,7 @@ PERL_CALLCONV OP* Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* ri __attribute__warn_unused_result__; PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); +PERL_CALLCONV CV* Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, U32 flags); /* PERL_CALLCONV AV* Perl_newAV(pTHX) __attribute__warn_unused_result__; */ diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 3a8d0de..b0263ee 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -121,6 +121,10 @@ is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n", is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n", 'inherted method calls autovivify coresubs'; +$tests++; +ok eval { *CORE::exit = \42 }, + '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only'; + done_testing $tests; CORE::__END__ -- Perl5 Master Repository
