*/
SV *left = POPs; SV *right = TOPs;
- if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
+ if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
SV * const temp = left;
left = right; right = temp;
}
}
else { /* $l .= $r and left == TARG */
if (!SvOK(left)) {
- if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
- report_uninit(right);
+ if ((left == right /* $l .= $l */
+ || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
+ && ckWARN(WARN_UNINITIALIZED)
+ )
+ report_uninit(left);
sv_setpvs(left, "");
}
else {
| (count << SAVE_TIGHT_SHIFT)
| SAVEt_CLEARPADRANGE);
STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
- assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
+ assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ == (Size_t)base);
{
dSS_ADD;
SS_ADD_UV(payload);
AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
- SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
- SV *sv = (svp ? *svp : &PL_sv_undef);
+ const I8 key = (I8)PL_op->op_private;
+ SV** svp;
+ SV *sv;
- if (UNLIKELY(!svp && lval))
- DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
+ assert(SvTYPE(av) == SVt_PVAV);
EXTEND(SP, 1);
+
+ /* inlined av_fetch() for simple cases ... */
+ if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
+ sv = AvARRAY(av)[key];
+ if (sv) {
+ PUSHs(sv);
+ RETURN;
+ }
+ }
+
+ /* ... else do it the hard way */
+ svp = av_fetch(av, key, lval);
+ sv = (svp ? *svp : &PL_sv_undef);
+
+ if (UNLIKELY(!svp && lval))
+ DIE(aTHX_ PL_no_aelem, (int)key);
+
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
mg_get(sv);
PUSHs(sv);
RETURN;
}
-PP(pp_pushre)
-{
- dSP;
-#ifdef DEBUGGING
- /*
- * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
- * will be enough to hold an OP*.
- */
- SV* const sv = sv_newmortal();
- sv_upgrade(sv, SVt_PVLV);
- LvTYPE(sv) = '/';
- Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
- XPUSHs(sv);
-#else
- XPUSHs(MUTABLE_SV(PL_op));
-#endif
- RETURN;
-}
-
/* Oversized hot code. */
/* also used for: pp_say() */
PP(pp_rv2av)
{
dSP; dTOPss;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
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
SV *sv;
AV *ary;
- I32 gimme;
+ U8 gimme;
HV *hash;
SSize_t i;
int magic;
const char *truebase; /* Start of string */
REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
STRLEN len;
const I32 oldsave = PL_savestack_ix;
I32 had_zerolen = 0;
PerlIO *fp;
IO * const io = GvIO(PL_last_in_gv);
const I32 type = PL_op->op_type;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
if (io) {
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
SV **itersvp;
SV *retsv;
+ SV *sv;
+ AV *av;
+ IV ix;
+ IV inc;
+
cx = CX_CUR();
itersvp = CxITERVAR(cx);
+ assert(itersvp);
switch (CxTYPE(cx)) {
break;
}
- {
- SV *sv;
- AV *av;
- IV ix;
- IV inc;
-
case CXt_LOOP_LIST: /* for (1,2,3) */
assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
*itersvp = sv;
SvREFCNT_dec(oldsv);
break;
- }
default:
DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
*++PL_stack_sp =retsv;
return PL_op->op_next;
-
-
}
/*
STRLEN slen;
bool doutf8 = FALSE; /* whether replacement is in utf8 */
#ifdef PERL_ANY_COW
- bool is_cow;
+ bool was_cow;
#endif
SV *nsv = NULL;
/* known replacement string? */
SvGETMAGIC(TARG); /* must come before cow check */
#ifdef PERL_ANY_COW
- /* Awooga. Awooga. "bool" types that are actually char are dangerous,
- because they make integers such as 256 "false". */
- is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
-#else
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG,0);
+ /* note that a string might get converted to COW during matching */
+ was_cow = cBOOL(SvIsCOW(TARG));
#endif
- if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
- && (SvREADONLY(TARG)
- || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
- || SvTYPE(TARG) > SVt_PVLV)
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- Perl_croak_no_modify();
+ if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
+#ifndef PERL_ANY_COW
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG,0);
+#endif
+ if ((SvREADONLY(TARG)
+ || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+ || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+ Perl_croak_no_modify();
+ }
PUTBACK;
orig = SvPV_nomg(TARG, len);
/* note we don't (yet) force the var into being a string; if we fail
- * to match, we leave as-is; on successful match howeverm, we *will*
+ * to match, we leave as-is; on successful match however, we *will*
* coerce into a string, then repeat the match */
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
force_on_match = 1;
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
SvSetSV(nsv, dstr);
- if (IN_ENCODING)
- sv_recode_to_utf8(nsv, _get_encoding());
- else
- sv_utf8_upgrade(nsv);
+ sv_utf8_upgrade(nsv);
c = SvPV_const(nsv, clen);
doutf8 = TRUE;
}
/* can do inplace substitution? */
if (c
#ifdef PERL_ANY_COW
- && !is_cow
+ && !was_cow
#endif
&& (I32)clen <= RX_MINLENRET(rx)
&& ( once
{
#ifdef PERL_ANY_COW
+ /* string might have got converted to COW since we set was_cow */
if (SvIsCOW(TARG)) {
if (!force_on_match)
goto have_a_cow;
first = FALSE;
}
else {
- if (IN_ENCODING) {
- if (!nsv) nsv = sv_newmortal();
- sv_copypv(nsv, repl);
- if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
- sv_catsv(dstr, nsv);
- }
- else sv_catsv(dstr, repl);
+ sv_catsv(dstr, repl);
if (UNLIKELY(SvTAINTED(repl)))
rxtainted |= SUBST_TAINT_REPL;
}
/* All done yet? */
if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
I32 items;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
*/
void
-Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, I32 gimme, int pass)
+Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
{
+ dVAR;
dSP;
SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
SSize_t nargs;
EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
tmps_basep = PL_tmps_stack + tmps_base;
- /* whether any SVs have have SvTEMP temporarily turned off,
- * indicating that they need saving below the cut */
/* process each return arg */
* 1) there is pp code similar to pp_substr that is
* returning a PADTMP instead of a mortal, and probably
* needs fixing, or
- * 2) pp_leavesub is making unwarranted assumptions
+ * 2) pp_leavesublv is making unwarranted assumptions
* about always croaking on a PADTMP
*/
if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
* merely by moving the cut boundary up one, rather
* than messing with SvTEMP. If all args are 1:1 then
* we can avoid the sorting stage below completely.
+ *
+ * If there are no items above the cut on the tmps
+ * stack, then the SvTEMP must comne from an item
+ * below the cut, so there's nothing to do.
*/
- if (sv == *tmps_basep)
- tmps_basep++;
- else
- SvTEMP_off(sv);
+ if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
+ if (sv == *tmps_basep)
+ tmps_basep++;
+ else
+ SvTEMP_off(sv);
+ }
}
else if (!SvPADTMP(sv)) {
/* mortalise arg to avoid it being freed during save
* stack unwinding. Pad tmps don't need mortalising as
- * they're never freed */
- SvREFCNT_inc_simple_void_NN(sv);
- /* equivalent of sv_2mortal(), except that:
+ * they're never freed. This is the equivalent of
+ * sv_2mortal(SvREFCNT_inc(sv)), except that:
* * it assumes that the temps stack has already been
* extended;
* * it puts the new item at the cut rather than at
* instead.
*/
if (!SvIMMORTAL(sv)) {
+ SvREFCNT_inc_simple_void_NN(sv);
SvTEMP_on(sv);
+ /* Note that if there's nothing above the cut,
+ * this copies the garbage one slot above
+ * PL_tmps_ix onto itself. This is harmless (the
+ * stack's already been extended), but might in
+ * theory trigger warnings from tools like ASan
+ */
PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
*tmps_basep++ = sv;
}
}
+/* also tail-called by pp_return */
+
PP(pp_leavesub)
{
- I32 gimme;
+ U8 gimme;
PERL_CONTEXT *cx;
SV **oldsp;
OP *retop;
/* these two fields are in a union. If they ever become separate,
* we have to test for both of them being null below */
+ assert(cv);
assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
while (UNLIKELY(!CvROOT(cv))) {
GV* autogv;
else {
try_autoload:
autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
- GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
+ (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
+ |(PL_op->op_flags & OPf_REF
+ ? GV_AUTOLOAD_ISMETHOD
+ : 0));
cv = autogv ? GvCV(autogv) : NULL;
}
if (!cv) {
PADLIST *padlist;
I32 depth;
bool hasargs;
- I32 gimme;
+ U8 gimme;
/* keep PADTMP args alive throughout the call (we need to do this
* because @_ isn't refcounted). Note that we create the mortals
}
else {
SSize_t markix = TOPMARK;
+ bool is_scalar;
ENTER;
/* pretend we did the ENTER earlier */
}
/* Do we need to open block here? XXXX */
+ /* calculate gimme here as PL_op might get changed and then not
+ * restored until the LEAVE further down */
+ is_scalar = (GIMME_V == G_SCALAR);
+
/* 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_V == G_SCALAR) {
+ if (is_scalar) {
SV **svp = PL_stack_base + markix + 1;
if (svp != PL_stack_sp) {
*svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
}
}
+
+
+/* like croak, but report in context of caller */
+
+void
+Perl_croak_caller(const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ const PERL_CONTEXT *cx = caller_cx(0, NULL);
+
+ /* make error appear at call site */
+ assert(cx);
+ PL_curcop = cx->blk_oldcop;
+
+ va_start(args, pat);
+ vcroak(pat, &args);
+ NOT_REACHED; /* NOTREACHED */
+ va_end(args);
+}
+
+
PP(pp_aelem)
{
dSP;
https://perl5.git.perl.org / perl5.git / blobdiff