* 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
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
return NORMAL;
}
PP(pp_gv)
{
dVAR; dSP;
- XPUSHs((SV*)cGVOP_gv);
+ XPUSHs(MUTABLE_SV(cGVOP_gv));
RETURN;
}
PP(pp_and)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (!SvTRUE(TOPs))
RETURN;
else {
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
SV * const cv = SvRV(left);
const U32 cv_type = SvTYPE(cv);
- const U32 gv_type = SvTYPE(right);
+ const bool is_gv = isGV_with_GP(right);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
/* Can do the optimisation if right (LVALUE) is not a typeglob,
left (RVALUE) is a reference to something, and we're in void
context. */
- if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
+ if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
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) {
+ if (!is_gv) {
/* 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) {
/* We've been returned a constant rather than a full subroutine,
but they expect a subroutine reference to apply. */
if (SvROK(cv)) {
- ENTER;
+ ENTER_with_name("sassign_coderef");
SvREFCNT_inc_void(SvRV(cv));
/* newCONSTSUB takes a reference count on the passed in SV
from us. We set the name to NULL, otherwise we get into
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;
+ LEAVE_with_name("sassign_coderef");
} else {
/* What can happen for the corner case *{"BONK"} = \&{"BONK"};
is that
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));
}
}
PP(pp_cond_expr)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
PP(pp_unstack)
{
dVAR;
- I32 oldsave;
+ PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+ if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ }
return NORMAL;
}
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
bool rbyte = FALSE;
bool rcopied = FALSE;
- if (TARG == right && right != left) {
- /* mg_get(right) may happen here ... */
- rpv = SvPV_const(right, rlen);
+ if (TARG == right && right != left) { /* $r = $l.$r */
+ rpv = SvPV_nomg_const(right, rlen);
rbyte = !DO_UTF8(right);
right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
- if (TARG != left) {
+ if (TARG != left) { /* not $l .= $r */
STRLEN llen;
- const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
+ const char* const lpv = SvPV_nomg_const(left, llen);
lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
else
SvUTF8_off(TARG);
}
- else { /* TARG == left */
- STRLEN llen;
- SvGETMAGIC(left); /* or mg_get(left) may happen here */
+ else { /* $l .= $r */
if (!SvOK(TARG)) {
- if (left == right && ckWARN(WARN_UNINITIALIZED))
+ if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
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);
+ lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
+ ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
- /* or mg_get(right) may happen here */
if (!rcopied) {
- rpv = SvPV_const(right, rlen);
+ if (left == right)
+ /* $r.$r: do magic twice: tied might return different 2nd time */
+ SvGETMAGIC(right);
+ rpv = SvPV_nomg_const(right, rlen);
rbyte = !DO_UTF8(right);
}
if (lbyte != rbyte) {
+ /* sv_utf8_upgrade_nomg() may reallocate the stack */
+ PUTBACK;
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
else {
if (!rcopied)
right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
sv_utf8_upgrade_nomg(right);
- rpv = SvPV_const(right, rlen);
+ rpv = SvPV_nomg_const(right, rlen);
}
+ SPAGAIN;
}
sv_catpvn_nomg(TARG, rpv, rlen);
PP(pp_readline)
{
dVAR;
- tryAMAGICunTARGET(iter, 0);
- PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ dSP; SvGETMAGIC(TOPs);
+ tryAMAGICunTARGET(iter_amg, 0, 0);
+ 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 = (GV*)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--);
+ Perl_pp_rv2gv(aTHX);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
}
return do_readline();
PP(pp_eq)
{
- dVAR; dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
}
#endif
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
/* Unless the left argument is integer in range we are going
to have to use NV maths. Hence only attempt to coerce the
right argument if we know the left is integer. */
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
const bool auvok = SvUOK(TOPm1s);
const bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left == right));
#else
- dPOPnv;
- SETs(boolSV(TOPn == value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) == value));
#endif
RETURN;
}
{
dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
PP(pp_or)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
else {
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
+ PERL_ASYNC_CHECK();
sv = TOPs;
if (!sv || !SvANY(sv)) {
if (op_type == OP_DOR)
PP(pp_add)
{
dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
- tryAMAGICbin(add,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
+ svr = TOPs;
+ svl = TOPm1s;
+
useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
+
if (SvIOK(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
}
#endif
{
- NV value = SvNV(svr);
+ NV value = SvNV_nomg(svr);
(void)POPs;
if (!useleft) {
/* left operand is undef, treat as zero. + 0.0 is identity. */
SETn(value);
RETURN;
}
- SETn( value + SvNV(svl) );
+ SETn( value + SvNV_nomg(svl) );
RETURN;
}
}
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);
EXTEND(SP, 1);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
XPUSHs(sv);
#else
- XPUSHs((SV*)PL_op);
+ XPUSHs(MUTABLE_SV(PL_op));
#endif
RETURN;
}
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- 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;
+ IO *io = GvIO(gv);
- if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ if (io
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
had_magic:
if (MARK == ORIGMARK) {
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)io, mg);
- PUTBACK;
- ENTER;
- if( PL_op->op_type == OP_SAY ) {
- /* local $\ = "\n" */
- SAVEGENERICSV(PL_ors_sv);
- PL_ors_sv = newSVpvs("\n");
- }
- call_method("PRINT", G_SCALAR);
- LEAVE;
- SPAGAIN;
- MARK = ORIGMARK + 1;
- *MARK = *SP;
- SP = MARK;
- RETURN;
+ return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
+ mg,
+ (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
+ | (PL_op->op_type == OP_SAY
+ ? TIED_METHOD_SAY : 0)), sp - mark);
}
- if (!(io = GvIO(gv))) {
- if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ if (!io) {
+ if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
+ && (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);
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (ckWARN2(WARN_CLOSED, WARN_IO)) {
- if (IoIFP(io))
- report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
- else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else
+ report_evil_fh(gv);
SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
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;
}
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
+ if (!(PL_op->op_private & OPpDEREFed))
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- wasref:
- tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
-
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
+ SPAGAIN;
+ }
sv = SvRV(sv);
if (SvTYPE(sv) != type)
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
}
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) {
GV *gv;
if (!isGV_with_GP(sv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
type, &sp);
if (!gv)
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;
}
if (is_pp_rv2av) {
- AV *const av = (AV*)sv;
- /* The guts of pp_rv2av, with no intenting change to preserve history
+ AV *const av = MUTABLE_AV(sv);
+ /* The guts of pp_rv2av, with no intending change to preserve history
(until such time as we get tools that can do blame annotation across
whitespace changes. */
- if (gimme == G_ARRAY) {
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* XXXX May be optimized away? */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- /* See note in pp_helem, and bug id #27839 */
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
- : &PL_sv_undef;
+ if (gimme == G_ARRAY) {
+ const I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* XXXX May be optimized away? */
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
}
+ SP += maxarg;
}
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ const I32 maxarg = AvFILL(av) + 1;
+ SETi(maxarg);
}
- SP += maxarg;
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- const I32 maxarg = AvFILL(av) + 1;
- SETi(maxarg);
- }
} else {
/* The guts of pp_rv2hv */
- if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = sv;
- return do_kv();
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SPAGAIN;
- SETTARG;
- }
+ if (gimme == G_ARRAY) { /* array wanted */
+ *PL_stack_sp = sv;
+ return Perl_do_kv(aTHX);
+ }
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
+ SPAGAIN;
+ SETTARG;
+ }
}
RETURN;
}
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);
for (relem = firstrelem; relem <= lastrelem; relem++) {
if ((sv = *relem)) {
TAINT_NOT; /* Each item is independent */
- *relem = sv_mortalcopy(sv);
+
+ /* Dear TODO test in t/op/sort.t, I love you.
+ (It's relying on a panic, not a "semi-panic" from newSVsv()
+ and then an assertion failure below.) */
+ if (SvIS_FREED(sv)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
+ (void*)sv);
+ }
+ /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
+ and we need a second copy of a temp here. */
+ *relem = sv_2mortal(newSVsv(sv));
}
}
}
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);
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
assert(*relem);
- sv = newSVsv(*relem);
+ sv = newSV(0);
+ sv_setsv(sv, *relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- 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;
+ if (SvSMAGICAL(sv))
mg_set(sv);
- PL_delaymagic = dmbak;
- }
if (!didstore)
sv_2mortal(sv);
}
TAINT_NOT;
}
- if (PL_delaymagic & DM_ARRAY)
- SvSETMAGIC((SV*)ary);
+ if (PL_delaymagic & DM_ARRAY_ISA)
+ SvSETMAGIC(MUTABLE_SV(ary));
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ SV** topelem = relem;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
tmpstr = newSV(0);
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
- *(relem++) = tmpstr;
- if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
- /* key overwrites an existing entry */
- duplicates += 2;
+ relem++;
+ if (gimme != G_VOID) {
+ if (hv_exists_ent(hash, sv, 0))
+ /* key overwrites an existing entry */
+ duplicates += 2;
+ else
+ if (gimme == G_ARRAY) {
+ /* copy element back: possibly to an earlier
+ * stack location if we encountered dups earlier */
+ *topelem++ = sv;
+ *topelem++ = tmpstr;
+ }
+ }
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr)) {
- U16 dmbak = PL_delaymagic;
- PL_delaymagic = 0;
+ if (SvSMAGICAL(tmpstr))
mg_set(tmpstr);
- PL_delaymagic = dmbak;
- }
if (!didstore)
sv_2mortal(tmpstr);
}
}
else
sv_setsv(sv, &PL_sv_undef);
-
- if (SvSMAGICAL(sv)) {
- U16 dmbak = PL_delaymagic;
- PL_delaymagic = 0;
- mg_set(sv);
- PL_delaymagic = dmbak;
- }
+ SvSETMAGIC(sv);
break;
}
}
SP = lastrelem;
else if (hash) {
if (duplicates) {
- /* Removes from the stack the entries which ended up as
- * duplicated keys in the hash (fix for [perl #24380]) */
- Move(firsthashrelem + duplicates,
- firsthashrelem, duplicates, SV**);
+ /* at this point we have removed the duplicate key/value
+ * pairs from the stack, but the remaining values may be
+ * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
+ * the (a 2), but the stack now probably contains
+ * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
+ * obliterates the earlier key. So refresh all values. */
lastrelem -= duplicates;
+ relem = firsthashrelem;
+ while (relem < lastrelem) {
+ HE *he;
+ sv = *relem++;
+ he = hv_fetch_ent(hash, sv, 0, 0);
+ *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ }
}
SP = lastrelem;
}
SV * const rv = sv_newmortal();
SvUPGRADE(rv, SVt_IV);
- /* 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);
+ /* For a subroutine describing itself as "This is a hacky workaround" I'm
+ loathe to use it here, but it seems to be the right fix. Or close.
+ The key part appears to be that it's essential for pp_qr to return a new
+ object (SV), which implies that there needs to be an effective way to
+ generate a new SV from the existing SV that is pre-compiled in the
+ optree. */
+ SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
if (pkg) {
- HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ HV *const stash = gv_stashsv(pkg, GV_ADD);
SvREFCNT_dec(pkg);
(void)sv_bless(rv, stash);
}
}
PUTBACK; /* EVAL blocks need stack_sp. */
- s = SvPV_const(TARG, len);
+ /* Skip get-magic if this is a qr// clone, because regcomp has
+ already done it. */
+ s = ((struct regexp *)SvANY(rx))->mother_re
+ ? SvPV_nomg_const(TARG, len)
+ : SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
/g matches against large strings. So far a solution to this problem
appears to be quite tricky.
Test for the unsafe vars are TODO for now. */
- if (( !global && RX_NPARENS(rx))
- || SvTEMP(TARG) || PL_sawampersand ||
- (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
+ if ( (!global && RX_NPARENS(rx))
+ || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
const I32 gimme = GIMME_V;
if (io) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- PUTBACK;
- ENTER;
- call_method("READLINE", gimme);
- LEAVE;
- SPAGAIN;
+ Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
- SV* const result = POPs;
- SvSetSV_nosteal(TARG, result);
- PUSHTARG;
+ SPAGAIN;
+ SvSetSV_nosteal(TARG, TOPs);
+ SETTARG;
}
- RETURN;
+ return NORMAL;
}
}
fp = NULL;
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;
}
else if (type == OP_GLOB)
SP--;
- else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
- report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
+ else if (IoTYPE(io) == IoTYPE_WRONLY) {
+ report_wrongway_fh(PL_last_in_gv, '>');
}
}
if (!fp) {
"glob failed (can't start child: %s)",
Strerror(errno));
else
- report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
+ report_evil_fh(PL_last_in_gv);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv))
- Sv_Grow(sv, 80); /* try short-buffering it */
+ if (!tmplen && !SvREADONLY(sv)) {
+ /* try short-buffering it. Please update t/op/readline.t
+ * if you change the growth length.
+ */
+ Sv_Grow(sv, 80);
+ }
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
(void)do_close(PL_last_in_gv, FALSE);
}
else if (type == OP_GLOB) {
- if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
- Perl_warner(aTHX_ packWARN(WARN_GLOB),
- "glob failed (child exited with status %d%s)",
- (int)(STATUS_CURRENT >> 8),
- (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+ if (!do_close(PL_last_in_gv, FALSE)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+ "glob failed (child exited with status %d%s)",
+ (int)(STATUS_CURRENT >> 8),
+ (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
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;
}
- ENTER;
+ ENTER_with_name("block");
SAVETMPS;
PUSHBLOCK(cx, CXt_BLOCK, SP);
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));
- else {
- if (!preeminent) {
- STRLEN keylen;
- const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen),
- SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
- } else
- save_helem(hv, keysv, svp);
- }
+ save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
+ else if (preeminent)
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+ else
+ SAVEHDELETE(hv, keysv);
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- /* This makes C<local $tied{foo} = $tied{foo}> possible.
- * Pushing the magical RHS on to the stack is useless, since
- * that magic is soon destined to be misled by the local(),
- * and thus the later pp_sassign() will fail to mg_get() the
- * old value. This should also cure problems with delayed
- * mg_get()s. GSAR 98-07-03 */
- if (!lval && SvGMAGICAL(sv))
- sv = sv_mortalcopy(sv);
+ /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+ * was to make C<local $tied{foo} = $tied{foo}> possible.
+ * However, it seems no longer to be needed for that purpose, and
+ * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+ * would loop endlessly since the pos magic is getting set on the
+ * mortal copy and lost. However, the copy has the effect of
+ * triggering the get magic, and losing it altogether made things like
+ * c<$tied{foo};> in void context no longer do get magic, which some
+ * code relied on. Also, delayed triggering of magic on @+ and friends
+ * meant the original regex may be out of scope by now. So as a
+ * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+ * being called too many times). */
+ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
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)
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE;
+ LEAVE_with_name("block");
RETURN;
}
bool is_cow;
#endif
SV *nsv = NULL;
-
/* known replacement string? */
register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
else if (PL_op->op_private & OPpTARGET_MY)
EXTEND(SP,1);
}
+ /* In non-destructive replacement mode, duplicate target scalar so it
+ * remains unchanged. */
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ TARG = sv_2mortal(newSVsv(TARG));
+
#ifdef PERL_OLD_COPY_ON_WRITE
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
because they make integers such as 256 "false". */
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- DIE(aTHX_ PL_no_modify);
+ Perl_croak_no_modify(aTHX);
PUTBACK;
+ setup_match:
s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
r_flags | REXEC_CHECKED);
/* known replacement string? */
if (dstr) {
+
+ /* Upgrade the source if the replacement is utf8 but the source is not,
+ * but only if it matched; see
+ * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
+ */
+ if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
+ const STRLEN new_len = sv_utf8_upgrade(TARG);
+
+ /* If the lengths are the same, the pattern contains only
+ * invariants, can keep going; otherwise, various internal markers
+ * could be off, so redo */
+ if (new_len != len) {
+ goto setup_match;
+ }
+ }
+
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
doutf8 = FALSE;
}
+ if (!matched)
+ goto ret_no;
+
/* can do inplace substitution? */
if (c
#ifdef PERL_OLD_COPY_ON_WRITE
#endif
&& (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
&& !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
- && (!doutf8 || SvUTF8(TARG))) {
- if (!matched)
- {
- SPAGAIN;
- PUSHs(&PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
+ && (!doutf8 || SvUTF8(TARG)))
+ {
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG)) {
assert (!force_on_match);
}
TAINT_IF(rxtainted & 1);
SPAGAIN;
- PUSHs(&PL_sv_yes);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ PUSHs(&PL_sv_yes);
}
else {
do {
}
TAINT_IF(rxtainted & 1);
SPAGAIN;
- mPUSHi((I32)iters);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ mPUSHi((I32)iters);
}
(void)SvPOK_only_UTF8(TARG);
TAINT_IF(rxtainted);
LEAVE_SCOPE(oldsave);
RETURN;
}
-
- if (matched)
- {
+ else {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
TAINT_IF(rxtainted & 1);
SPAGAIN;
- mPUSHi((I32)iters);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ mPUSHi((I32)iters);
(void)SvPOK_only(TARG);
if (doutf8)
LEAVE_SCOPE(oldsave);
RETURN;
}
- goto ret_no;
+ /* NOTREACHED */
nope:
ret_no:
SPAGAIN;
- PUSHs(&PL_sv_no);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ PUSHs(&PL_sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
}
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
++*PL_markstack_ptr;
- LEAVE; /* exit inner scope */
+ FREETMPS;
+ LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_stack_base + *PL_markstack_ptr > SP) {
I32 items;
const I32 gimme = GIMME_V;
- LEAVE; /* exit outer scope */
+ LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
(void)POPMARK; /* pop dst */
else {
SV *src;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
if (gimme == G_SCALAR)
goto temporise;
if (gimme == G_ARRAY) {
+ mark = newsp + 1;
+ /* We want an array here, but padav will have left us an arrayref for an lvalue,
+ * so we need to expand it */
+ if(SvTYPE(*mark) == SVt_PVAV) {
+ AV *const av = MUTABLE_AV(*mark);
+ const I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* get rid of the array ref */
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
+ PUTBACK;
+ }
if (!CvLVALUE(cx->blk_sub.cv))
goto temporise_array;
EXTEND_MORTAL(SP - newsp);
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- /* Temporaries are bad unless they happen to be elements
- * of a tied hash or array */
- if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
- !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+ /* Temporaries are bad unless they happen to have set magic
+ * attached, such as the elements of a tied hash or array */
+ if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
+ (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
+ == SVf_READONLY
+ ) &&
+ !SvSMAGICAL(TOPs)) {
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
case SVt_PVGV:
if (!isGV_with_GP(sv))
DIE(aTHX_ "Not a CODE reference");
- if (!(cv = GvCVu((GV*)sv))) {
+ we_have_a_glob:
+ if (!(cv = GvCVu((const GV *)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
}
goto try_autoload;
}
break;
+ case SVt_PVLV:
+ if(isGV_with_GP(sv)) goto we_have_a_glob;
+ /*FALLTHROUGH*/
default:
- if (!SvROK(sv)) {
+ if (sv == &PL_sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
+ RETURN;
+ }
+ SvGETMAGIC(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
+ }
+ else {
const char *sym;
STRLEN len;
- if (sv == &PL_sv_yes) { /* unfound import, ignore */
- if (hasargs)
- SP = PL_stack_base + POPMARK;
- RETURN;
- }
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto got_rv;
- if (SvPOKp(sv)) {
- sym = SvPVX_const(sv);
- len = SvCUR(sv);
- } else {
- sym = NULL;
- len = 0;
- }
- }
- else {
- sym = SvPV_const(sv, len);
- }
+ sym = SvPV_nomg_const(sv, len);
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+ DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
- got_rv:
- {
- 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;
}
SAVETMPS;
retry:
+ if (CvCLONE(cv) && ! CvCLONED(cv))
+ DIE(aTHX_ "Closure prototype called");
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* autogv;
SV* sub_name;
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_fetchpvs("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;
PL_curcopdb = NULL;
}
/* Do we need to open block here? XXXX */
- if (CvXSUB(cv)) /* XXX this is supposed to be true */
- (void)(*CvXSUB(cv))(aTHX_ cv);
+
+ /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+ assert(CvXSUB(cv));
+ CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
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);
}
sv = (svp ? *svp : &PL_sv_undef);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak_no_modify(aTHX);
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);
SV* ob;
GV* gv;
HV* stash;
- STRLEN namelen;
const char* packname = NULL;
SV *packsv = NULL;
STRLEN packlen;
- const char * const name = SvPV_const(meth, namelen);
SV * const sv = *(PL_stack_base + TOPMARK + 1);
PERL_ARGS_ASSERT_METHOD_COMMON;
if (!sv)
- Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
+ SVfARG(meth));
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 ||
: !isIDFIRST(*packname)
))
{
- Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
+ SVfARG(meth),
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
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
&& isGV_with_GP(ob)
- && (ob = (SV*)GvIO((GV*)ob))
+ && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
+ const char * const name = SvPV_nolen_const(meth);
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
(SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
name);
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);
+ return MUTABLE_SV(GvCV(gv));
}
}
- gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
+ gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
+ SvPV_nolen_const(meth),
GV_AUTOLOAD | GV_CROAK);
assert(gv);
- return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
+ return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff