PP(pp_stringify)
{
dVAR; dSP; dTARGET;
- sv_copypv(TARG,TOPs);
- SETTARG;
- RETURN;
+ SV * const sv = TOPs;
+ SETs(TARG);
+ sv_copypv(TARG, sv);
+ SvSETMAGIC(TARG);
+ /* no PUTBACK, SETs doesn't inc/dec SP */
+ return NORMAL;
}
PP(pp_gv)
PP(pp_and)
{
- dVAR; dSP;
+ dVAR;
PERL_ASYNC_CHECK();
- if (!SvTRUE(TOPs))
- RETURN;
- else {
- if (PL_op->op_type == OP_AND)
- --SP;
- RETURNOP(cLOGOP->op_other);
+ {
+ /* SP is not used to remove a variable that is saved across the
+ sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
+ register or load/store vs direct mem ops macro is introduced, this
+ should be a define block between direct PL_stack_sp and dSP operations,
+ presently, using PL_stack_sp is bias towards CISC cpus */
+ SV * const sv = *PL_stack_sp;
+ if (!SvTRUE_NN(sv))
+ return NORMAL;
+ else {
+ if (PL_op->op_type == OP_AND)
+ --PL_stack_sp;
+ return cLOGOP->op_other;
+ }
}
}
*/
SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
SvRV(cv))));
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
LEAVE_with_name("sassign_coderef");
} else {
/* What can happen for the corner case *{"BONK"} = \&{"BONK"};
assert(CvFLAGS(source) & CVf_CONST);
SvREFCNT_inc_void(source);
- SvREFCNT_dec(upgraded);
+ SvREFCNT_dec_NN(upgraded);
SvRV_set(right, MUTABLE_SV(source));
}
}
* I suspect that the mg_get is no longer needed, but while padav
* differs, it can't share this function */
-void
+STATIC void
S_pushav(pTHX_ AV* const av)
{
dSP;
- const I32 maxarg = AvFILL(av) + 1;
+ const SSize_t maxarg = AvFILL(av) + 1;
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
+ PADOFFSET i;
+ for (i=0; i < (PADOFFSET)maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
/* See note in pp_helem, and bug id #27839 */
SP[i+1] = svp
}
}
else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ PADOFFSET i;
+ for (i=0; i < (PADOFFSET)maxarg; i++) {
+ SV * const sv = AvARRAY(av)[i];
+ SP[i+1] = sv ? sv : &PL_sv_undef;
+ }
}
SP += maxarg;
PUTBACK;
| SAVEt_CLEARPADRANGE);
assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
- SSCHECK(1);
- SSPUSHUV(payload);
+ {
+ dSS_ADD;
+ SS_ADD_UV(payload);
+ SS_ADD_END(1);
+ }
for (i = 0; i <count; i++)
SvPADSTALE_off(*svp++); /* mark lexical as active */
if (!(op->op_private & OPpPAD_STATE))
save_clearsv(padentry);
if (op->op_private & OPpDEREF) {
- /* TOPs arg is TARG, but TOPs (SP) rmvs a var across save_clearsv */
+ /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
+ than TARG reduces the scope of TARG, so it does not
+ span the call to save_clearsv, resulting in smaller
+ machine code. */
TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
}
}
dSP;
if (TOPs) {
SvGETMAGIC(TOPs);
- tryAMAGICunTARGETlist(iter_amg, 0, 0);
+ tryAMAGICunTARGETlist(iter_amg, 0);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
+ return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
mg,
(G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
| (PL_op->op_type == OP_SAY
}
else if (gimme == G_SCALAR) {
dTARGET;
- const I32 maxarg = AvFILL(av) + 1;
+ const SSize_t maxarg = AvFILL(av) + 1;
SETi(maxarg);
}
} else {
}
STATIC void
-S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
+S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
dVAR;
PERL_ARGS_ASSERT_DO_ODDBALL;
- if (*relem) {
- SV *tmpstr;
- const HE *didstore;
-
+ if (*oddkey) {
if (ckWARN(WARN_MISC)) {
const char *err;
- if (relem == firstrelem &&
- SvROK(*relem) &&
- (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
- SvTYPE(SvRV(*relem)) == SVt_PVHV))
+ if (oddkey == firstkey &&
+ SvROK(*oddkey) &&
+ (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
+ SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
{
err = "Reference found where even-sized list expected";
}
Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
}
- tmpstr = newSV(0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (SvMAGICAL(hash)) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
- TAINT_NOT;
}
}
I32 gimme;
HV *hash;
- I32 i;
+ SSize_t i;
int magic;
- int duplicates = 0;
- SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
+ U32 lval = 0;
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
gimme = GIMME_V;
+ if (gimme == G_ARRAY)
+ lval = PL_op->op_flags & OPf_MOD || LVRET;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
- assert(*relem);
- SvGETMAGIC(*relem); /* before newSV, in case it dies */
+ if (*relem)
+ SvGETMAGIC(*relem); /* before newSV, in case it dies */
sv = newSV(0);
sv_setsv_nomg(sv, *relem);
*(relem++) = sv;
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ int odd;
+ int duplicates = 0;
SV** topelem = relem;
+ SV **firsthashrelem = relem;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
+
+ odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
+ if ( odd ) {
+ do_oddball(lastrelem, firsthashrelem);
+ /* we have firstlelem to reuse, it's not needed anymore
+ */
+ *(lastrelem+1) = &PL_sv_undef;
+ }
+
ENTER;
SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
hv_clear(hash);
- firsthashrelem = relem;
-
- while (relem < lastrelem) { /* gobble up all the rest */
+ while (relem < lastrelem+odd) { /* gobble up all the rest */
HE *didstore;
- sv = *relem ? *relem : &PL_sv_no;
- relem++;
- tmpstr = sv_newmortal();
- if (*relem)
- sv_setsv(tmpstr,*relem); /* value */
+ assert(*relem);
+ /* Copy the key if aassign is called in lvalue context,
+ to avoid having the next op modify our rhs. Copy
+ it also if it is gmagical, lest it make the
+ hv_store_ent call below croak, leaking the value. */
+ sv = lval || SvGMAGICAL(*relem)
+ ? sv_mortalcopy(*relem)
+ : *relem;
relem++;
- if (gimme != G_VOID) {
+ assert(*relem);
+ SvGETMAGIC(*relem);
+ tmpstr = newSV(0);
+ sv_setsv_nomg(tmpstr,*relem++); /* value */
+ if (gimme == G_ARRAY) {
if (hv_exists_ent(hash, sv, 0))
/* key overwrites an existing entry */
duplicates += 2;
- else
- if (gimme == G_ARRAY) {
+ else {
/* copy element back: possibly to an earlier
- * stack location if we encountered dups earlier */
+ * stack location if we encountered dups earlier,
+ * possibly to a later stack location if odd */
*topelem++ = sv;
*topelem++ = tmpstr;
}
}
didstore = hv_store_ent(hash,sv,tmpstr,0);
- if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr);
if (magic) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- }
+ if (!didstore) sv_2mortal(tmpstr);
+ SvSETMAGIC(tmpstr);
+ }
TAINT_NOT;
}
- if (relem == lastrelem) {
- do_oddball(hash, relem, firstrelem);
- relem++;
- }
LEAVE;
+ if (duplicates && gimme == G_ARRAY) {
+ /* 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+odd) {
+ HE *he;
+ he = hv_fetch_ent(hash, *relem++, 0, 0);
+ *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ }
+ }
+ if (odd && gimme == G_ARRAY) lastrelem++;
}
break;
default:
}
if (PL_delaymagic & ~DM_DELAY) {
/* Will be used to set PL_tainting below */
- UV tmp_uid = PerlProc_getuid();
- UV tmp_euid = PerlProc_geteuid();
- UV tmp_gid = PerlProc_getgid();
- UV tmp_egid = PerlProc_getegid();
+ Uid_t tmp_uid = PerlProc_getuid();
+ Uid_t tmp_euid = PerlProc_geteuid();
+ Gid_t tmp_gid = PerlProc_getgid();
+ Gid_t tmp_egid = PerlProc_getegid();
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
tmp_egid = PerlProc_getegid();
}
TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(tmp_uid);
+ PERL_UNUSED_VAR(tmp_euid);
+ PERL_UNUSED_VAR(tmp_gid);
+ PERL_UNUSED_VAR(tmp_egid);
+#endif
}
PL_delaymagic = 0;
else if (gimme == G_SCALAR) {
dTARGET;
SP = firstrelem;
- SETi(lastrelem - firstrelem + 1 - duplicates);
+ SETi(lastrelem - firstrelem + 1);
}
else {
- if (ary)
- SP = lastrelem;
- else if (hash) {
- if (duplicates) {
- /* 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);
- }
- }
+ if (ary || hash)
+ /* note that in this case *firstlelem may have been overwritten
+ by sv_undef in the odd hash case */
SP = lastrelem;
- }
- else
+ else {
SP = firstrelem + (lastlelem - firstlelem);
- lelem = firstlelem + (relem - firstrelem);
- while (relem <= SP)
- *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
+ lelem = firstlelem + (relem - firstrelem);
+ while (relem <= SP)
+ *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
+ }
}
RETURN;
cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
if ((cv = *cvp) && CvCLONE(*cvp)) {
*cvp = cv_clone(cv);
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
}
if (pkg) {
HV *const stash = gv_stashsv(pkg, GV_ADD);
- SvREFCNT_dec(pkg);
+ SvREFCNT_dec_NN(pkg);
(void)sv_bless(rv, stash);
}
dVAR; dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
- const char *t;
const char *s;
const char *strend;
+ SSize_t curpos = 0; /* initial pos() or current $+[0] */
I32 global;
- U8 r_flags = REXEC_CHECKED;
+ U8 r_flags = 0;
const char *truebase; /* Start of string */
REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
const I32 gimme = GIMME;
STRLEN len;
- I32 minmatch = 0;
const I32 oldsave = PL_savestack_ix;
- I32 update_minmatch = 1;
I32 had_zerolen = 0;
- U32 gpos = 0;
+ MAGIC *mg = NULL;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
- s = ReANY(rx)->mother_re
+ truebase = ReANY(rx)->mother_re
? SvPV_nomg_const(TARG, len)
: SvPV_const(TARG, len);
- if (!s)
+ if (!truebase)
DIE(aTHX_ "panic: pp_match");
- strend = s + len;
+ strend = truebase + len;
rxtainted = (RX_ISTAINTED(rx) ||
(TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
- RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
+ /* We need to know this in case we fail out early - pos() must be reset */
+ global = dynpm->op_pmflags & PMf_GLOBAL;
/* PMdf_USED is set after a ?? matches once */
if (
#endif
) {
DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
- failure:
-
- if (gimme == G_ARRAY)
- RETURN;
- RETPUSHNO;
+ goto nope;
}
-
-
/* empty pattern special-cased to use last successful pattern if
possible, except for qr// */
if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
rx = PM_GETRE(pm);
}
- if (RX_MINLEN(rx) > (I32)len) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
- goto failure;
- }
-
- truebase = t = s;
-
- /* XXXX What part of this is needed with true \G-support? */
- if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
- RX_OFFS(rx)[0].start = -1;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
- if (mg && mg->mg_len >= 0) {
- if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
- else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
- r_flags |= REXEC_IGNOREPOS;
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
- } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
- gpos = mg->mg_len;
- else
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
- minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
- update_minmatch = 0;
- }
- }
+ if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
+ UVuf" < %"IVdf")\n",
+ (UV)len, (IV)RX_MINLEN(rx)));
+ goto nope;
+ }
+
+ /* get pos() if //g */
+ if (global) {
+ mg = mg_find_mglob(TARG);
+ if (mg && mg->mg_len >= 0) {
+ curpos = MgBYTEPOS(mg, TARG, truebase, len);
+ /* last time pos() was set, it was zero-length match */
+ if (mg->mg_flags & MGf_MINMATCH)
+ had_zerolen = 1;
+ }
}
+
+#ifdef PERL_SAWAMPERSAND
if ( RX_NPARENS(rx)
|| PL_sawampersand
|| (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
- ) {
+ || (dynpm->op_pmflags & PMf_KEEPCOPY)
+ )
+#endif
+ {
r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
/* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
* only on the first iteration. Therefore we need to copy $' as well
if (! (global && gimme == G_ARRAY))
r_flags |= REXEC_COPY_SKIP_POST;
};
+#ifdef PERL_SAWAMPERSAND
+ if (dynpm->op_pmflags & PMf_KEEPCOPY)
+ /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
+ r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
+#endif
+
+ s = truebase;
play_it_again:
- if (global && RX_OFFS(rx)[0].start != -1) {
- t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
- if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
- goto nope;
- }
- if (update_minmatch++)
- minmatch = had_zerolen;
- }
- if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
- DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
- /* FIXME - can PL_bostr be made const char *? */
- PL_bostr = (char *)truebase;
- s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
-
- if (!s)
- goto nope;
- if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
- && !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
- && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
- goto yup;
- }
+ if (global)
+ s = truebase + curpos;
+
if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
- goto ret_no;
+ had_zerolen, TARG, NULL, r_flags))
+ goto nope;
PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
+ if (dynpm->op_pmflags & PMf_ONCE)
#ifdef USE_ITHREADS
SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
#else
dynpm->op_pmflags |= PMf_USED;
#endif
- }
- gotcha:
if (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (gimme == G_ARRAY) {
+
+ /* update pos */
+
+ if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
+ if (!mg)
+ mg = sv_magicext_mglob(TARG);
+ MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
+ if (RX_ZERO_LEN(rx))
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+
+ if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
+ LEAVE_SCOPE(oldsave);
+ RETPUSHYES;
+ }
+
+ /* push captures on stack */
+
+ {
const I32 nparens = RX_NPARENS(rx);
I32 i = (global && !nparens) ? 1 : 0;
PUSHs(sv_newmortal());
if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
- s = RX_OFFS(rx)[i].start + truebase;
+ const char * const s = RX_OFFS(rx)[i].start + truebase;
if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
}
}
if (global) {
- if (dynpm->op_pmflags & PMf_CONTINUE) {
- MAGIC* mg = NULL;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
- if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG, 0);
-#endif
- mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
- &PL_vtbl_mglob, NULL, 0);
- }
- if (RX_OFFS(rx)[0].start != -1) {
- mg->mg_len = RX_OFFS(rx)[0].end;
- if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
- mg->mg_flags |= MGf_MINMATCH;
- else
- mg->mg_flags &= ~MGf_MINMATCH;
- }
- }
- had_zerolen = (RX_OFFS(rx)[0].start != -1
- && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
- == (UV)RX_OFFS(rx)[0].end));
+ curpos = (UV)RX_OFFS(rx)[0].end;
+ had_zerolen = RX_ZERO_LEN(rx);
PUTBACK; /* EVAL blocks may use stack */
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
goto play_it_again;
}
- else if (!nparens)
- XPUSHs(&PL_sv_yes);
LEAVE_SCOPE(oldsave);
RETURN;
}
- else {
- if (global) {
- MAGIC* mg;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
- else
- mg = NULL;
- if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG, 0);
-#endif
- mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
- &PL_vtbl_mglob, NULL, 0);
- }
- if (RX_OFFS(rx)[0].start != -1) {
- mg->mg_len = RX_OFFS(rx)[0].end;
- if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
- mg->mg_flags |= MGf_MINMATCH;
- else
- mg->mg_flags &= ~MGf_MINMATCH;
- }
- }
- LEAVE_SCOPE(oldsave);
- RETPUSHYES;
- }
-
-yup: /* Confirmed by INTUIT */
- if (rxtainted)
- RX_MATCH_TAINTED_on(rx);
- TAINT_IF(RX_MATCH_TAINTED(rx));
- PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
-#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
-#else
- dynpm->op_pmflags |= PMf_USED;
-#endif
- }
- if (RX_MATCH_COPIED(rx))
- Safefree(RX_SUBBEG(rx));
- RX_MATCH_COPIED_off(rx);
- RX_SUBBEG(rx) = NULL;
- if (global) {
- /* FIXME - should rx->subbeg be const char *? */
- RX_SUBBEG(rx) = (char *) truebase;
- RX_SUBOFFSET(rx) = 0;
- RX_SUBCOFFSET(rx) = 0;
- RX_OFFS(rx)[0].start = s - truebase;
- if (RX_MATCH_UTF8(rx)) {
- char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
- RX_OFFS(rx)[0].end = t - truebase;
- }
- else {
- RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
- }
- RX_SUBLEN(rx) = strend - truebase;
- goto gotcha;
- }
- if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
- I32 off;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
- if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log,
- "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
- (int) SvTYPE(TARG), (void*)truebase, (void*)t,
- (int)(t-truebase));
- }
- RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
- RX_SUBBEG(rx)
- = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
- assert (SvPOKp(RX_SAVED_COPY(rx)));
- } else
-#endif
- {
-
- RX_SUBBEG(rx) = savepvn(t, strend - t);
-#ifdef PERL_OLD_COPY_ON_WRITE
- RX_SAVED_COPY(rx) = NULL;
-#endif
- }
- RX_SUBLEN(rx) = strend - t;
- RX_SUBOFFSET(rx) = 0;
- RX_SUBCOFFSET(rx) = 0;
- RX_MATCH_COPIED_on(rx);
- off = RX_OFFS(rx)[0].start = s - t;
- RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
- }
- else { /* startp/endp are used by @- @+. */
- RX_OFFS(rx)[0].start = s - truebase;
- RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
- }
- /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
- assert(!RX_NPARENS(rx));
- RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
- LEAVE_SCOPE(oldsave);
- RETPUSHYES;
+ /* NOTREACHED */
nope:
-ret_no:
if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
- if (mg)
- mg->mg_len = -1;
- }
+ if (!mg)
+ mg = mg_find_mglob(TARG);
+ if (mg)
+ mg->mg_len = -1;
}
LEAVE_SCOPE(oldsave);
if (gimme == G_ARRAY)
if (io) {
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
+ Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetSV_nosteal(TARG, TOPs);
}
if (!fp) {
if ((!io || !(IoFLAGS(io) & IOf_START))
- && ckWARN2(WARN_GLOB, WARN_CLOSED))
+ && ckWARN(WARN_CLOSED)
+ && type != OP_GLOB)
{
- if (type == OP_GLOB)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
- "glob failed (can't start child: %s)",
- Strerror(errno));
- else
- report_evil_fh(PL_last_in_gv);
+ report_evil_fh(PL_last_in_gv);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALNUMC(*t1) &&
+ if (!isALPHANUMERIC(*t1) &&
strchr("$&*(){}[]'\";\\|?<>~`", *t1))
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
- SvREFCNT_dec(key2); /* sv_magic() increments refcount */
+ SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc_simple(hv);
LvTARGLEN(lv) = 1;
PUSHs(lv);
* completely new SV for closures/references to work as
* they used to */
*itersvp = newSVsv(cur);
- SvREFCNT_dec(oldsv);
+ SvREFCNT_dec_NN(oldsv);
}
if (strEQ(SvPVX_const(cur), max))
sv_setiv(cur, 0); /* terminate next time */
* completely new SV for closures/references to work as they
* used to */
*itersvp = newSViv(cur);
- SvREFCNT_dec(oldsv);
+ SvREFCNT_dec_NN(oldsv);
}
if (cur == IV_MAX) {
*itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
+ if (SvPADTMP(sv) && !IS_PADGV(sv))
+ sv = newSVsv(sv);
+ else {
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
+ }
+ else if (!av_is_stack) {
+ sv = newSVavdefelem(av, ix, 0);
}
else
sv = &PL_sv_undef;
- if (!av_is_stack && sv == &PL_sv_undef) {
- SV *lv = newSV_type(SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
- LvTARG(lv) = SvREFCNT_inc_simple(av);
- LvTARGOFF(lv) = ix;
- LvTARGLEN(lv) = (STRLEN)UV_MAX;
- sv = lv;
- }
-
oldsv = *itersvp;
*itersvp = sv;
SvREFCNT_dec(oldsv);
as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
on the new pattern too.
-During execution of a pattern, locale-variant ops such as ALNUML set the
-local flag RF_tainted. At the end of execution, the engine sets the
-RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
-otherwise.
+At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
+regex is cleared; during execution, locale-variant ops such as POSIXL may
+set RXf_TAINTED_SEEN.
-In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
+RXf_TAINTED_SEEN is used post-execution by the get magic code
of $1 et al to indicate whether the returned value should be tainted.
It is the responsibility of the caller of the pattern (i.e. pp_match,
pp_subst etc) to set this flag for any other circumstances where $1 needs
PMOP *rpm = pm;
char *s;
char *strend;
- char *m;
const char *c;
- char *d;
STRLEN clen;
I32 iters = 0;
I32 maxiters;
- I32 i;
bool once;
U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
See "how taint works" above */
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE; /* whether replacement is in utf8 */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
bool is_cow;
#endif
SV *nsv = NULL;
}
SvGETMAGIC(TARG); /* must come before cow check */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#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;
sv_force_normal_flags(TARG,0);
#endif
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
-#ifdef PERL_OLD_COPY_ON_WRITE
- && !is_cow
-#endif
&& (SvREADONLY(TARG)
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
Perl_croak_no_modify();
PUTBACK;
- s = SvPV_nomg(TARG, len);
+ 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*
+ * coerce into a string, then repeat the match */
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
force_on_match = 1;
TAINT_NOT;
}
- RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
-
force_it:
- if (!pm || !s)
- DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
+ if (!pm || !orig)
+ DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
- strend = s + len;
- slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
+ strend = orig + len;
+ slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
maxiters = 2 * slen + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
rx = PM_GETRE(pm);
}
+#ifdef PERL_SAWAMPERSAND
r_flags = ( RX_NPARENS(rx)
|| PL_sawampersand
|| (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+ || (rpm->op_pmflags & PMf_KEEPCOPY)
)
? REXEC_COPY_STR
: 0;
+#else
+ r_flags = REXEC_COPY_STR;
+#endif
- orig = m = s;
- if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
- PL_bostr = orig;
- s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
-
- if (!s)
- goto ret_no;
- /* How to do it in subst? */
-/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
- && !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
- goto yup;
-*/
- }
-
- if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
{
- ret_no:
SPAGAIN;
PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
}
-
PL_curpm = pm;
/* known replacement string? */
/* can do inplace substitution? */
if (c
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
&& !is_cow
#endif
&& (I32)clen <= RX_MINLENRET(rx)
- && (once || !(r_flags & REXEC_COPY_STR))
- && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
+ && ( once
+ || !(r_flags & REXEC_COPY_STR)
+ || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
+ )
+ && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
&& (!doutf8 || SvUTF8(TARG))
&& !(rpm->op_pmflags & PMf_NONDESTRUCT))
{
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (SvIsCOW(TARG)) {
- assert (!force_on_match);
+ if (!force_on_match)
goto have_a_cow;
+ assert(SvVOK(TARG));
}
#endif
if (force_on_match) {
+ /* redo the first match, this time with the orig var
+ * forced into being a string */
force_on_match = 0;
- s = SvPV_force_nomg(TARG, len);
+ orig = SvPV_force_nomg(TARG, len);
goto force_it;
}
- d = s;
+
if (once) {
+ char *d, *m;
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
m = orig + RX_OFFS(rx)[0].start;
d = orig + RX_OFFS(rx)[0].end;
s = orig;
if (m - s > strend - d) { /* faster to shorten from end */
+ I32 i;
if (clen) {
Copy(c, m, clen, char);
m += clen;
*m = '\0';
SvCUR_set(TARG, m - s);
}
- else if ((i = m - s)) { /* faster from front */
+ else { /* faster from front */
+ I32 i = m - s;
d -= clen;
- m = d;
- Move(s, d - i, i, char);
+ if (i > 0)
+ Move(s, d - i, i, char);
sv_chop(TARG, d-i);
if (clen)
- Copy(c, m, clen, char);
- }
- else if (clen) {
- d -= clen;
- sv_chop(TARG, d);
- Copy(c, d, clen, char);
- }
- else {
- sv_chop(TARG, d);
+ Copy(c, d, clen, char);
}
SPAGAIN;
PUSHs(&PL_sv_yes);
}
else {
+ char *d, *m;
+ d = s = RX_OFFS(rx)[0].start + orig;
do {
+ I32 i;
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
d += clen;
}
s = RX_OFFS(rx)[0].end + orig;
- } while (CALLREGEXEC(rx, s, strend, orig, s == m,
+ } while (CALLREGEXEC(rx, s, strend, orig,
+ s == m, /* don't match same null twice */
TARG, NULL,
- /* don't match same null twice */
- REXEC_NOT_FIRST|REXEC_IGNOREPOS));
+ REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
if (s != d) {
- i = strend - s;
+ I32 i = strend - s;
SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
Move(s, d, i+1, char); /* include the NUL */
}
}
else {
bool first;
+ char *m;
SV *repl;
if (force_on_match) {
+ /* redo the first match, this time with the orig var
+ * forced into being a string */
force_on_match = 0;
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
/* I feel that it should be possible to avoid this mortal copy
cases where it would be viable to drop into the copy code. */
TARG = sv_2mortal(newSVsv(TARG));
}
- s = SvPV_force_nomg(TARG, len);
+ orig = SvPV_force_nomg(TARG, len);
goto force_it;
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
have_a_cow:
#endif
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
repl = dstr;
- dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
+ s = RX_OFFS(rx)[0].start + orig;
+ dstr = newSVpvn_flags(orig, s-orig,
+ SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
if (!c) {
PERL_CONTEXT *cx;
SPAGAIN;
+ m = orig;
/* note that a whole bunch of local vars are saved here for
* use by pp_substcont: here's a list of them in case you're
* searching for places in this sub that uses a particular var:
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
- r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
first = TRUE;
do {
if (iters++ > maxiters)
if (RX_MATCH_TAINTED(rx))
rxtainted |= SUBST_TAINT_PAT;
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
- m = s;
- s = orig;
+ char *old_s = s;
+ char *old_orig = orig;
assert(RX_SUBOFFSET(rx) == 0);
+
orig = RX_SUBBEG(rx);
- s = orig + (m - s);
- strend = s + (strend - m);
+ s = orig + (old_s - old_orig);
+ strend = s + (strend - old_s);
}
m = RX_OFFS(rx)[0].start + orig;
sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
if (once)
break;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
- TARG, NULL, r_flags));
+ TARG, NULL,
+ REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
SPAGAIN;
PUSHs(dstr);
} else {
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
/* The match may make the string COW. If so, brilliant, because
that's just saved us one malloc, copy and free - the regexp has
donated the old buffer, and we malloc an entirely new one, rather
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
+ if (SvPADTMP(src) && !IS_PADGV(src)) {
+ src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ PL_tmps_floor++;
+ }
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
FREETMPS;
*MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
}
else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
PUTBACK;
LEAVE;
- cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
+ cxstack_ix--;
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
}
ENTER;
- SAVETMPS;
retry:
if (CvCLONE(cv) && ! CvCLONED(cv))
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- I32 items = SP - MARK;
+ SSize_t items = SP - MARK;
PADLIST * const padlist = CvPADLIST(cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.argarray = av;
++MARK;
- if (items > AvMAX(av) + 1) {
- SV **ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- AvARRAY(av) = ary;
- }
- if (items > AvMAX(av) + 1) {
- AvMAX(av) = items - 1;
- Renew(ary,items,SV*);
- AvALLOC(av) = ary;
- AvARRAY(av) = ary;
- }
- }
+ if (items - 1 > AvMAX(av)) {
+ SV **ary = AvALLOC(av);
+ AvMAX(av) = items - 1;
+ Renew(ary, items, SV*);
+ AvALLOC(av) = ary;
+ AvARRAY(av) = ary;
+ }
+
Copy(MARK,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
+ MARK = AvARRAY(av);
while (items--) {
if (*MARK)
+ {
+ if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+ *MARK = sv_mortalcopy(*MARK);
SvTEMP_off(*MARK);
+ }
MARK++;
}
}
+ SAVETMPS;
if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
!CvLVALUE(cv))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
RETURNOP(CvSTART(cv));
}
else {
- I32 markix = TOPMARK;
+ SSize_t markix = TOPMARK;
+ SAVETMPS;
PUTBACK;
- if (!hasargs) {
+ if (((PL_op->op_private
+ & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
+ ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+
+ if (!hasargs && GvAV(PL_defgv)) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
AV * const av = GvAV(PL_defgv);
- const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
+ const SSize_t items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
+ SSize_t i = 0;
/* Mark is at the end of the stack. */
EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
+ for (; i < items; ++i)
+ if (AvARRAY(av)[i]) SP[i+1] = AvARRAY(av)[i];
+ else {
+ SP[i+1] = newSVavdefelem(av, i, 1);
+ }
SP += items;
PUTBACK ;
}
}
+ else {
+ SV **mark = PL_stack_base + markix;
+ SSize_t items = SP - mark;
+ while (items--) {
+ mark++;
+ if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
+ *mark = sv_mortalcopy(*mark);
+ }
+ }
/* We assume first XSUB in &DB::sub is the called one. */
if (PL_curcopdb) {
SAVEVPTR(PL_curcop);
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- SV* const tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), NULL);
+ HEK *const hek = CvNAME_HEK(cv);
+ SV *tmpstr;
+ if (hek) {
+ tmpstr = sv_2mortal(newSVhek(hek));
+ }
+ else {
+ tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, CvGV(cv), NULL);
+ }
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
SVfARG(tmpstr));
}
IV elem = SvIV(elemsv);
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 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
SV *sv;
MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
}
#endif
- if (!svp || *svp == &PL_sv_undef) {
- SV* lv;
+ if (!svp || !*svp) {
+ IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- lv = sv_newmortal();
- sv_upgrade(lv, SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
- LvTARG(lv) = SvREFCNT_inc_simple(av);
- LvTARGOFF(lv) = elem;
- LvTARGLEN(lv) = 1;
- PUSHs(lv);
+ len = av_len(av);
+ mPUSHs(newSVavdefelem(av,
+ /* Resolve a negative index now, unless it points before the
+ beginning of the array, in which case record it for error
+ reporting in magic_setdefelem. */
+ elem < 0 && len + elem >= 0 ? len + elem : elem,
+ 1));
RETURN;
}
if (localizing) {
if (SvROK(sv))
ob = MUTABLE_SV(SvRV(sv));
else if (!SvOK(sv)) goto undefined;
+ else if (isGV_with_GP(sv)) {
+ if (!GvIO(sv))
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
+ "without a package or object reference",
+ SVfARG(meth));
+ ob = sv;
+ if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
+ assert(!LvTARGLEN(ob));
+ ob = LvTARG(ob);
+ assert(ob);
+ }
+ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
+ }
else {
/* this isn't a reference */
GV* 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 we got here, ob should be an object or a glob */
if (!ob || !(SvOBJECT(ob)
- || (SvTYPE(ob) == SVt_PVGV
- && isGV_with_GP(ob)
+ || (isGV_with_GP(ob)
&& (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
https://perl5.git.perl.org / perl5.git / blobdiff