summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.fnc3
-rw-r--r--embed.h1
-rw-r--r--gv.c8
-rw-r--r--op.c23
-rw-r--r--proto.h1
-rw-r--r--t/op/coresubs.t4
6 files changed, 31 insertions, 9 deletions
diff --git a/embed.fnc b/embed.fnc
index d6980d609c..3d79971a2a 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 ce0048d156..93d265fafa 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 af8f289cc6..e99af67049 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 1d35396aea..72232ea586 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 fcf5ab9a28..f0f7788daa 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 3a8d0dec42..b0263ee8de 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__
View Lorry Controller Status