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.
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
#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)
gv = (GV *)newSV(0);
gv_init(gv, stash, name, len, TRUE);
}
+ GvMULTI_on(gv);
if (ampable) {
ENTER;
oldcurcop = PL_curcop;
(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)
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;
|| 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);
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();
__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__; */
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__