/* pp_hot.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* Then he heard Merry change the note, and up went the Horn-cry of Buckland,
* shaking the air.
*
- * Awake! Awake! Fear, Fire, Foes! Awake!
- * Fire, Foes! Awake!
+ * Awake! Awake! Fear, Fire, Foes! Awake!
+ * Fire, Foes! Awake!
+ *
+ * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
*/
/* This file contains 'hot' pp ("push/pop") functions that
{
dVAR;
dSP;
- if ( PL_op->op_flags & OPf_SPECIAL )
- /* This is a const op added to hold the hints hash for
- pp_entereval. The hash can be modified by the code
- being eval'ed, so we return a copy instead. */
- mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
- else
- /* Normal const. */
- XPUSHs(cSVOP_sv);
+ XPUSHs(cSVOP_sv);
RETURN;
}
PP(pp_gv)
{
dVAR; dSP;
- XPUSHs((SV*)cGVOP_gv);
+ XPUSHs(MUTABLE_SV(cGVOP_gv));
RETURN;
}
The gv becomes a(nother) reference to the constant. */
SV *const value = SvRV(cv);
- SvUPGRADE((SV *)gv, SVt_IV);
+ SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
/* Need to fix things up. */
if (gv_type != SVt_PVGV) {
/* Need to fix GV. */
- right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
+ right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
}
if (!got_coderef) {
all sorts of fun as the reference to our new sub is
donated to the GV that we're about to assign to.
*/
- SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
- SvRV(cv)));
+ SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
+ SvRV(cv))));
SvREFCNT_dec(cv);
LEAVE;
} else {
So change the reference so that it points to the subroutine
of that typeglob, as that's what they were after all along.
*/
- GV *const upgraded = (GV *) cv;
+ GV *const upgraded = MUTABLE_GV(cv);
CV *const source = GvCV(upgraded);
assert(source);
SvREFCNT_inc_void(source);
SvREFCNT_dec(upgraded);
- SvRV_set(left, (SV *)source);
+ SvRV_set(left, MUTABLE_SV(source));
}
}
if (!SvOK(TARG)) {
if (left == right && ckWARN(WARN_UNINITIALIZED))
report_uninit(right);
- sv_setpvn(left, "", 0);
+ sv_setpvs(left, "");
}
(void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
lbyte = !DO_UTF8(left);
{
dVAR;
tryAMAGICunTARGET(iter, 0);
- PL_last_in_gv = (GV*)(*PL_stack_sp--);
- if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
- if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
- PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ if (!isGV_with_GP(PL_last_in_gv)) {
+ if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
+ PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
else {
dSP;
- XPUSHs((SV*)PL_last_in_gv);
+ XPUSHs(MUTABLE_SV(PL_last_in_gv));
PUTBACK;
pp_rv2gv();
- PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
}
return do_readline();
PP(pp_preinc)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+ DIE(aTHX_ "%s", PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
PP(pp_aelemfast)
{
dVAR; dSP;
- AV * const av = PL_op->op_flags & OPf_SPECIAL ?
- (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
+ AV * const av = PL_op->op_flags & OPf_SPECIAL
+ ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
SV** const svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
XPUSHs(sv);
#else
- XPUSHs((SV*)PL_op);
+ XPUSHs(MUTABLE_SV(PL_op));
#endif
RETURN;
}
IO *io;
register PerlIO *fp;
MAGIC *mg;
- GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
+ GV * const gv
+ = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
had_magic:
if (MARK == ORIGMARK) {
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)io, mg);
+ *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
PUTBACK;
ENTER;
if( PL_op->op_type == OP_SAY ) {
}
if (!(io = GvIO(gv))) {
if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
goto just_say_no;
}
else {
+ SV * const ofs = GvSV(PL_ofsgv); /* $, */
MARK++;
- if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
+ if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
while (MARK <= SP) {
if (!do_print(*MARK, fp))
break;
MARK++;
if (MARK <= SP) {
- if (!do_print(PL_ofs_sv, fp)) { /* $, */
+ /* don't use 'ofs' here - it may be invalidated by magic callbacks */
+ if (!do_print(GvSV(PL_ofsgv), fp)) {
MARK--;
break;
}
{
dVAR; dSP; dTOPss;
const I32 gimme = GIMME_V;
- static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
- static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
static const char an_array[] = "an ARRAY";
static const char a_hash[] = "a HASH";
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
- Perl_croak(aTHX_ PL_no_localize_ref);
+ Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
else {
if (SvTYPE(sv) == type) {
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
else {
GV *gv;
- if (SvTYPE(sv) != SVt_PVGV) {
+ if (!isGV_with_GP(sv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
RETURN;
}
else {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
}
- sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
+ sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
if (PL_op->op_private & OPpLVAL_INTRO)
- sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
+ sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
if (PL_op->op_flags & OPf_REF) {
SETs(sv);
RETURN;
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
if (is_pp_rv2av) {
- AV *const av = (AV*)sv;
+ AV *const av = MUTABLE_AV(sv);
/* The guts of pp_rv2av, with no intenting change to preserve history
(until such time as we get tools that can do blame annotation across
whitespace changes. */
}
else if (gimme == G_SCALAR) {
dTARGET;
- TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
+ TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
SPAGAIN;
SETTARG;
}
}
RETURN;
+
+ croak_cant_return:
+ Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
+ is_pp_rv2av ? "array" : "hash");
+ RETURN;
}
STATIC void
}
else
err = "Odd number of elements in hash assignment";
- Perl_warner(aTHX_ packWARN(WARN_MISC), err);
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
}
tmpstr = newSV(0);
sv = *lelem++;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- ary = (AV*)sv;
+ ary = MUTABLE_AV(sv);
magic = SvMAGICAL(ary) != 0;
av_clear(ary);
av_extend(ary, lastrelem - relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv))
+ if (SvSMAGICAL(sv)) {
+ /* More magic can happen in the mg_set callback, so we
+ * backup the delaymagic for now. */
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(sv);
}
TAINT_NOT;
}
if (PL_delaymagic & DM_ARRAY)
- SvSETMAGIC((SV*)ary);
+ SvSETMAGIC(MUTABLE_SV(ary));
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
- hash = (HV*)sv;
+ hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
hv_clear(hash);
firsthashrelem = relem;
duplicates += 2;
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr))
+ if (SvSMAGICAL(tmpstr)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(tmpstr);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(tmpstr);
}
}
else
sv_setsv(sv, &PL_sv_undef);
- SvSETMAGIC(sv);
+
+ if (SvSMAGICAL(sv)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
+ mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
break;
}
}
/* This RV is about to own a reference to the regexp. (In addition to the
reference already owned by the PMOP. */
ReREFCNT_inc(rx);
- SvRV_set(rv, (SV*) rx);
+ SvRV_set(rv, MUTABLE_SV(rx));
SvROK_on(rv);
if (pkg) {
HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ SvREFCNT_dec(pkg);
(void)sv_bless(rv, stash);
}
const I32 gimme = GIMME_V;
if (io) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
ENTER;
call_method("READLINE", gimme);
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
- sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
+ sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
goto have_fp;
I32 gimme = OP_GIMME(PL_op, -1);
if (gimme == -1) {
- if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
+ if (cxstack_ix >= 0) {
+ /* If this flag is set, we're just inside a return, so we should
+ * store the caller's context */
+ gimme = (PL_op->op_flags & OPf_SPECIAL)
+ ? block_gimme()
+ : cxstack[cxstack_ix].blk_gimme;
+ } else
gimme = G_SCALAR;
}
HE* he;
SV **svp;
SV * const keysv = POPs;
- HV * const hv = (HV*)POPs;
+ HV * const hv = MUTABLE_HV(POPs);
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
- I32 preeminent = 0;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (localizing) {
MAGIC *mg;
HV *stash;
- /* does the element we're localizing already exist? */
- preeminent = /* can we determine whether it exists? */
- ( !SvRMAGICAL(hv)
- || mg_find((SV*)hv, PERL_MAGIC_env)
- || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
- /* Try to preserve the existenceness of a tied hash
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise */
- && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
- && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
- && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
- )
- ) ? hv_exists_ent(hv, keysv, 0) : 1;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ preeminent = hv_exists_ent(hv, keysv, 0);
}
+
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
PUSHs(lv);
RETURN;
}
- if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (localizing) {
if (HvNAME_get(hv) && isGV(*svp))
- save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
+ save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
else {
if (!preeminent) {
STRLEN keylen;
SAVEDELETE(hv, savepvn(key,keylen),
SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
} else
- save_helem(hv, keysv, svp);
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
}
}
else if (PL_op->op_private & OPpDEREF)
POPBLOCK(cx,newpm);
- gimme = OP_GIMME(PL_op, -1);
- if (gimme == -1) {
- if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
- gimme = G_SCALAR;
- }
+ gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
TAINT_NOT;
if (gimme == G_VOID)
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- DIE(aTHX_ PL_no_modify);
+ DIE(aTHX_ "%s", PL_no_modify);
PUTBACK;
s = SvPV_mutable(TARG, len);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
- if (!(cv = GvCVu((GV*)sv))) {
+ if (!isGV_with_GP(sv))
+ DIE(aTHX_ "Not a CODE reference");
+ if (!(cv = GvCVu((const GV *)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
}
SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
}
- cv = (CV*)SvRV(sv);
+ cv = MUTABLE_CV(SvRV(sv));
if (SvTYPE(cv) == SVt_PVCV)
break;
/* FALL THROUGH */
DIE(aTHX_ "Not a CODE reference");
/* This is the second most common case: */
case SVt_PVCV:
- cv = (CV*)sv;
+ cv = MUTABLE_CV(sv);
break;
}
Perl_get_db_sub(aTHX_ &sv, cv);
if (CvISXSUB(cv))
PL_curcopdb = PL_curcop;
- cv = GvCV(PL_DBsub);
+ if (CvLVALUE(cv)) {
+ /* check for lsub that handles lvalue subroutines */
+ cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+ /* if lsub not found then fall back to DB::sub */
+ if (!cv) cv = GvCV(PL_DBsub);
+ } else {
+ cv = GvCV(PL_DBsub);
+ }
if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
DIE(aTHX_ "No DB::sub routine defined");
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (hasargs) {
- AV* const av = (AV*)PAD_SVl(0);
+ AV *const av = MUTABLE_AV(PAD_SVl(0));
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
AvREIFY_on(av);
}
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
+ GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++MARK;
if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
sub_crush_depth(cv);
-#if 0
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
-#endif
RETURNOP(CvSTART(cv));
}
else {
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
- AV* const av = (AV*)POPs;
+ AV *const av = MUTABLE_AV(POPs);
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
+
+ if (localizing) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(av))
+ preeminent = av_exists(av, elem);
+ }
+
svp = av_fetch(av, elem, lval && !defer);
if (lval) {
#ifdef PERL_MALLOC_WRAP
PUSHs(lv);
RETURN;
}
- if (PL_op->op_private & OPpLVAL_INTRO)
- save_aelem(av, elem, svp);
+ if (localizing) {
+ if (preeminent)
+ save_aelem(av, elem, svp);
+ else
+ SAVEADELETE(av, elem);
+ }
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
SvRV_set(sv, newSV(0));
break;
case OPpDEREF_AV:
- SvRV_set(sv, (SV*)newAV());
+ SvRV_set(sv, MUTABLE_SV(newAV()));
break;
case OPpDEREF_HV:
- SvRV_set(sv, (SV*)newHV());
+ SvRV_set(sv, MUTABLE_SV(newHV()));
break;
}
SvROK_on(sv);
SvGETMAGIC(sv);
if (SvROK(sv))
- ob = (SV*)SvRV(sv);
+ ob = MUTABLE_SV(SvRV(sv));
else {
GV* iogv;
if (!SvOK(sv) ||
!(packname) ||
!(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
- !(ob=(SV*)GvIO(iogv)))
+ !(ob=MUTABLE_SV(GvIO(iogv))))
{
/* this isn't the name of a filehandle either */
if (!packname ||
goto fetch;
}
/* it _is_ a filehandle name -- replace with a reference */
- *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
+ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
}
/* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
- || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
+ || (SvTYPE(ob) == SVt_PVGV
+ && isGV_with_GP(ob)
+ && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
if (hashp) {
const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
if (he) {
- gv = (GV*)HeVAL(he);
+ gv = MUTABLE_GV(HeVAL(he));
if (isGV(gv) && GvCV(gv) &&
(!GvCVGEN(gv) || GvCVGEN(gv)
== (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
- return (SV*)GvCV(gv);
- }
- }
-
- gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
- if (!gv) {
- /* This code tries to figure out just what went wrong with
- gv_fetchmethod. It therefore needs to duplicate a lot of
- the internals of that function. We can't move it inside
- Perl_gv_fetchmethod_autoload(), however, since that would
- cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
- don't want that.
- */
- const char* leaf = name;
- const char* sep = NULL;
- const char* p;
-
- for (p = name; *p; p++) {
- if (*p == '\'')
- sep = p, leaf = p + 1;
- else if (*p == ':' && *(p + 1) == ':')
- sep = p, leaf = p + 2;
- }
- if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- /* the method name is unqualified or starts with SUPER:: */
-#ifndef USE_ITHREADS
- if (sep)
- stash = CopSTASH(PL_curcop);
-#else
- bool need_strlen = 1;
- if (sep) {
- packname = CopSTASHPV(PL_curcop);
- }
- else
-#endif
- if (stash) {
- HEK * const packhek = HvNAME_HEK(stash);
- if (packhek) {
- packname = HEK_KEY(packhek);
- packlen = HEK_LEN(packhek);
-#ifdef USE_ITHREADS
- need_strlen = 0;
-#endif
- } else {
- goto croak;
- }
- }
-
- if (!packname) {
- croak:
- Perl_croak(aTHX_
- "Can't use anonymous symbol table for method lookup");
- }
-#ifdef USE_ITHREADS
- if (need_strlen)
- packlen = strlen(packname);
-#endif
-
- }
- else {
- /* the method name is qualified */
- packname = name;
- packlen = sep - name;
- }
-
- /* we're relying on gv_fetchmethod not autovivifying the stash */
- if (gv_stashpvn(packname, packlen, 0)) {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\"",
- leaf, (int)packlen, packname);
- }
- else {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\""
- " (perhaps you forgot to load \"%.*s\"?)",
- leaf, (int)packlen, packname, (int)packlen, packname);
+ return MUTABLE_SV(GvCV(gv));
}
}
- return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
+
+ gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
+ GV_AUTOLOAD | GV_CROAK);
+
+ assert(gv);
+
+ return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff