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;
+ }
}
}
SV * const temp = left;
left = right; right = temp;
}
- if (PL_tainting && PL_tainted && !SvTAINTED(right))
+ if (TAINTING_get && TAINT_get && !SvTAINTED(right))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
SV * const cv = SvRV(right);
*/
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));
}
}
report_uninit(right);
sv_setpvs(left, "");
}
- lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
- ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
+ SvPV_force_nomg_nolen(left);
+ lbyte = !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
}
}
+/* push the elements of av onto the stack.
+ * XXX Note that padav has similar code but without the mg_get().
+ * I suspect that the mg_get is no longer needed, but while padav
+ * differs, it can't share this function */
+
+STATIC void
+S_pushav(pTHX_ AV* const av)
+{
+ dSP;
+ const I32 maxarg = AvFILL(av) + 1;
+ 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;
+ PUTBACK;
+}
+
+
+/* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
+
+PP(pp_padrange)
+{
+ dVAR; dSP;
+ PADOFFSET base = PL_op->op_targ;
+ int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
+ int i;
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ /* fake the RHS of my ($x,$y,..) = @_ */
+ PUSHMARK(SP);
+ S_pushav(aTHX_ GvAVn(PL_defgv));
+ SPAGAIN;
+ }
+
+ /* note, this is only skipped for compile-time-known void cxt */
+ if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
+ EXTEND(SP, count);
+ PUSHMARK(SP);
+ for (i = 0; i <count; i++)
+ *++SP = PAD_SV(base+i);
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ SV **svp = &(PAD_SVl(base));
+ const UV payload = (UV)(
+ (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
+ | (count << SAVE_TIGHT_SHIFT)
+ | SAVEt_CLEARPADRANGE);
+ assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
+ assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
+ {
+ dSS_ADD;
+ SS_ADD_UV(payload);
+ SS_ADD_END(1);
+ }
+
+ for (i = 0; i <count; i++)
+ SvPADSTALE_off(*svp++); /* mark lexical as active */
+ }
+ RETURN;
+}
+
+
PP(pp_padsv)
{
- dVAR; dSP; dTARGET;
- XPUSHs(TARG);
- if (PL_op->op_flags & OPf_MOD) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- if (PL_op->op_private & OPpDEREF) {
- PUTBACK;
- TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
- SPAGAIN;
+ dVAR; dSP;
+ EXTEND(SP, 1);
+ {
+ OP * const op = PL_op;
+ /* access PL_curpad once */
+ SV ** const padentry = &(PAD_SVl(op->op_targ));
+ {
+ dTARG;
+ TARG = *padentry;
+ PUSHs(TARG);
+ PUTBACK; /* no pop/push after this, TOPs ok */
}
+ if (op->op_flags & OPf_MOD) {
+ if (op->op_private & OPpLVAL_INTRO)
+ if (!(op->op_private & OPpPAD_STATE))
+ save_clearsv(padentry);
+ if (op->op_private & OPpDEREF) {
+ /* 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);
+ }
+ }
+ return op->op_next;
}
- RETURN;
}
PP(pp_readline)
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--;
const bool inc =
PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
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
if (SvTYPE(sv) != type)
/* diag_listed_as: Not an ARRAY reference */
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
- }
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
- else {
- if (SvTYPE(sv) == type) {
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
- }
- else {
+ else if (SvTYPE(sv) != type) {
GV *gv;
if (!isGV_with_GP(sv)) {
sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
if (PL_op->op_private & OPpLVAL_INTRO)
sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
- if (PL_op->op_flags & OPf_REF) {
+ }
+ if (PL_op->op_flags & OPf_REF) {
SETs(sv);
RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
SETs(sv);
RETURN;
}
- }
- }
}
if (is_pp_rv2av) {
(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) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
- }
- }
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
- }
- SP += maxarg;
+ SP--;
+ PUTBACK;
+ S_pushav(aTHX_ av);
+ SPAGAIN;
}
else if (gimme == G_SCALAR) {
dTARGET;
*PL_stack_sp = sv;
return Perl_do_kv(aTHX);
}
+ else if ((PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID ))
+ && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
+ SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
dTARGET;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
}
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;
}
}
HV *hash;
I32 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
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));
+ /* Not newSVsv(), as it does not allow copy-on-write,
+ resulting in wasteful copies. We need a second copy of
+ a temp here, hence the SV_NOSTEAL. */
+ *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
+ |SV_NOSTEAL);
}
}
}
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
assert(*relem);
+ SvGETMAGIC(*relem); /* before newSV, in case it dies */
sv = newSV(0);
- sv_setsv(sv, *relem);
+ sv_setsv_nomg(sv, *relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv))
- mg_set(sv);
if (!didstore)
sv_2mortal(sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
}
TAINT_NOT;
}
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;
+ 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++;
- tmpstr = newSV(0);
- if (*relem)
- sv_setsv(tmpstr,*relem); /* value */
- 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 (magic) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(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_gid = PerlProc_getgid();
tmp_egid = PerlProc_getegid();
}
- PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
+ 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)
+ if (ary || hash)
+ /* note that in this case *firstlelem may have been overwritten
+ by sv_undef in the odd hash case */
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);
- }
- }
- 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;
SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
- cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
+ 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);
}
- if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
+ if (RX_ISTAINTED(rx)) {
SvTAINTED_on(rv);
SvTAINTED_on(SvRV(rv));
}
PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
- s = ((struct regexp *)SvANY(rx))->mother_re
+ s = ReANY(rx)->mother_re
? SvPV_nomg_const(TARG, len)
: SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
- rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
- (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
+ 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 */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ /* empty pattern special-cased to use last successful pattern if
+ possible, except for qr// */
+ if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
+ && PL_curpm) {
pm = PL_curpm;
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;
+ goto nope;
}
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
- if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
+ if (global) {
+ MAGIC * const mg = mg_find_mglob(TARG);
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 (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) {
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;
- }
}
}
- /* XXX: comment out !global get safe $1 vars after a
- match, BUT be aware that this leads to dramatic slowdowns on
- /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) || SvAMAGIC(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
- r_flags |= REXEC_COPY_STR;
+#ifdef PERL_SAWAMPERSAND
+ if ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_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
+ * as $&, to make the rest of the string available for captures in
+ * subsequent iterations */
+ if (! (global && gimme == G_ARRAY))
+ r_flags |= REXEC_COPY_SKIP_POST;
+ };
play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
}
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);
+ s = CALLREG_INTUIT_START(rx, TARG, truebase,
+ (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 (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
+
+ /* update pos */
+
+ if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
+ MAGIC *mg = mg_find_mglob(TARG);
+ if (!mg) {
+ mg = sv_magicext_mglob(TARG);
+ }
+ 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;
+ }
+ }
+
if (gimme == G_ARRAY) {
const I32 nparens = RX_NPARENS(rx);
I32 i = (global && !nparens) ? 1 : 0;
}
}
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));
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 */
+ assert(!RX_NPARENS(rx));
if (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
dynpm->op_pmflags |= PMf_USED;
#endif
}
- if (RX_MATCH_COPIED(rx))
- Safefree(RX_SUBBEG(rx));
- RX_MATCH_COPIED_off(rx);
- RX_SUBBEG(rx) = NULL;
+
+ RX_MATCH_UTF8_set(rx, cBOOL(DO_UTF8(rx)));
+ if ( !(r_flags & REXEC_NOT_FIRST) )
+ Perl_reg_set_capture_string(aTHX_ rx,
+ (char*)truebase, (char *)strend,
+ TARG, r_flags, cBOOL(DO_UTF8(TARG)));
+
+ /* skipping regexec means that indices for $&, $-[0] etc weren't set */
+ RX_OFFS(rx)[0].start = s - truebase;
+ RX_OFFS(rx)[0].end =
+ RX_MATCH_UTF8(rx)
+ ? (char*)utf8_hop((U8*)s, RX_MINLENRET(rx)) - truebase
+ : s - truebase + RX_MINLENRET(rx);
+
if (global) {
- /* FIXME - should rx->subbeg be const char *? */
- RX_SUBBEG(rx) = (char *) truebase;
- 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_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;
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);
+ MAGIC* const 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);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv)) {
+ if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
/* try short-buffering it. Please update t/op/readline.t
* if you change the growth length.
*/
}
}
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) {
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;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
preeminent = hv_exists_ent(hv, keysv, 0);
}
- he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
if (!svp || !*svp || *svp == &PL_sv_undef) {
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);
{
dVAR; dSP;
PERL_CONTEXT *cx;
- SV *sv, *oldsv;
+ SV *oldsv;
SV **itersvp;
- AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
- bool av_is_stack = FALSE;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
- if (!CxTYPE_is_LOOP(cx))
- DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
-
itersvp = CxITERVAR(cx);
- if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
- /* string increment */
- SV* cur = cx->blk_loop.state_u.lazysv.cur;
- SV *end = cx->blk_loop.state_u.lazysv.end;
- /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
- It has SvPVX of "" and SvCUR of 0, which is what we want. */
- STRLEN maxlen = 0;
- const char *max = SvPV_const(end, maxlen);
- if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
- if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
- /* safe to reuse old SV */
- sv_setsv(*itersvp, cur);
- }
- else
- {
- /* we need a fresh SV every time so that loop body sees a
- * completely new SV for closures/references to work as
- * they used to */
- oldsv = *itersvp;
- *itersvp = newSVsv(cur);
- SvREFCNT_dec(oldsv);
- }
- if (strEQ(SvPVX_const(cur), max))
- sv_setiv(cur, 0); /* terminate next time */
- else
- sv_inc(cur);
- RETPUSHYES;
- }
- RETPUSHNO;
+
+ switch (CxTYPE(cx)) {
+
+ case CXt_LOOP_LAZYSV: /* string increment */
+ {
+ SV* cur = cx->blk_loop.state_u.lazysv.cur;
+ SV *end = cx->blk_loop.state_u.lazysv.end;
+ /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+ It has SvPVX of "" and SvCUR of 0, which is what we want. */
+ STRLEN maxlen = 0;
+ const char *max = SvPV_const(end, maxlen);
+ if (SvNIOK(cur) || SvCUR(cur) > maxlen)
+ RETPUSHNO;
+
+ oldsv = *itersvp;
+ if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ /* safe to reuse old SV */
+ sv_setsv(oldsv, cur);
+ }
+ else
+ {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as
+ * they used to */
+ *itersvp = newSVsv(cur);
+ SvREFCNT_dec_NN(oldsv);
+ }
+ if (strEQ(SvPVX_const(cur), max))
+ sv_setiv(cur, 0); /* terminate next time */
+ else
+ sv_inc(cur);
+ break;
}
- else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
- /* integer increment */
- if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
+
+ case CXt_LOOP_LAZYIV: /* integer increment */
+ {
+ IV cur = cx->blk_loop.state_u.lazyiv.cur;
+ if (cur > cx->blk_loop.state_u.lazyiv.end)
RETPUSHNO;
+ oldsv = *itersvp;
/* don't risk potential race */
- if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
+ if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
+ sv_setiv(oldsv, cur);
}
else
{
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- oldsv = *itersvp;
- *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
- SvREFCNT_dec(oldsv);
+ *itersvp = newSViv(cur);
+ SvREFCNT_dec_NN(oldsv);
}
- if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
+ if (cur == IV_MAX) {
/* Handle end of range at IV_MAX */
cx->blk_loop.state_u.lazyiv.end = IV_MIN;
} else
++cx->blk_loop.state_u.lazyiv.cur;
-
- RETPUSHYES;
+ break;
}
- /* iterate array */
- assert(CxTYPE(cx) == CXt_LOOP_FOR);
- av = cx->blk_loop.state_u.ary.ary;
- if (!av) {
- av_is_stack = TRUE;
- av = PL_curstack;
- }
- if (PL_op->op_private & OPpITER_REVERSED) {
- if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
- ? cx->blk_loop.resetsp + 1 : 0))
- RETPUSHNO;
+ case CXt_LOOP_FOR: /* iterate array */
+ {
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
- sv = svp ? *svp : NULL;
- }
- else {
- sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
- }
- }
- else {
- if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
- AvFILL(av)))
- RETPUSHNO;
+ AV *av = cx->blk_loop.state_u.ary.ary;
+ SV *sv;
+ bool av_is_stack = FALSE;
+ IV ix;
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
- sv = svp ? *svp : NULL;
- }
- else {
- sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
- }
- }
+ if (!av) {
+ av_is_stack = TRUE;
+ av = PL_curstack;
+ }
+ if (PL_op->op_private & OPpITER_REVERSED) {
+ ix = --cx->blk_loop.state_u.ary.ix;
+ if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
+ RETPUSHNO;
+ }
+ else {
+ ix = ++cx->blk_loop.state_u.ary.ix;
+ if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
+ RETPUSHNO;
+ }
- if (sv && SvIS_FREED(sv)) {
- *itersvp = NULL;
- Perl_croak(aTHX_ "Use of freed value in iteration");
- }
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV * const * const svp = av_fetch(av, ix, FALSE);
+ sv = svp ? *svp : NULL;
+ }
+ else {
+ sv = AvARRAY(av)[ix];
+ }
- if (sv) {
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
- }
- 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) = cx->blk_loop.state_u.ary.ix;
- LvTARGLEN(lv) = (STRLEN)UV_MAX;
- sv = lv;
- }
+ if (sv) {
+ if (SvIS_FREED(sv)) {
+ *itersvp = NULL;
+ Perl_croak(aTHX_ "Use of freed value in iteration");
+ }
+ if (SvPADTMP(sv) && !IS_PADGV(sv))
+ sv = newSVsv(sv);
+ else {
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
+ }
+ 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);
+ oldsv = *itersvp;
+ *itersvp = sv;
+ SvREFCNT_dec(oldsv);
+ break;
+ }
+ default:
+ DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
+ }
RETPUSHYES;
}
/*
A description of how taint works in pattern matching and substitution.
+This is all conditional on NO_TAINT_SUPPORT not being defined. Under
+NO_TAINT_SUPPORT, taint-related operations should become no-ops.
+
While the pattern is being assembled/concatenated and then compiled,
-PL_tainted will get set if any component of the pattern is tainted, e.g.
-/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
-is set on the pattern if PL_tainted is set.
+PL_tainted will get set (via TAINT_set) if any component of the pattern
+is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
+the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
+TAINT_get).
When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
the pattern is marked as tainted. This means that subsequent usage, such
-as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
+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
int force_on_match = 0;
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
- bool doutf8 = FALSE;
-#ifdef PERL_OLD_COPY_ON_WRITE
+ bool doutf8 = FALSE; /* whether replacement is in utf8 */
+#ifdef PERL_ANY_COW
bool is_cow;
#endif
SV *nsv = NULL;
EXTEND(SP,1);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+ 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;
sv_force_normal_flags(TARG,0);
#endif
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
&& !is_cow
#endif
&& (SvREADONLY(TARG)
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
PUTBACK;
- setup_match:
- s = SvPV_mutable(TARG, len);
+ s = SvPV_nomg(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
force_on_match = 1;
once = !(rpm->op_pmflags & PMf_GLOBAL);
/* See "how taint works" above */
- if (PL_tainting) {
+ if (TAINTING_get) {
rxtainted = (
(SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
- | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
+ | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
| ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
| ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
? SUBST_TAINT_BOOLRET : 0));
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);
strend = s + len;
- slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
+ slen = DO_UTF8(TARG) ? utf8_length((U8*)s, (U8*)strend) : len;
maxiters = 2 * slen + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ if (!RX_PRELEN(rx) && PL_curpm
+ && !ReANY(rx)->mother_re) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
- ? REXEC_COPY_STR : 0;
+
+#ifdef PERL_SAWAMPERSAND
+ r_flags = ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_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);
+ s = CALLREG_INTUIT_START(rx, TARG, orig, s, strend, r_flags, NULL);
if (!s)
goto ret_no;
RETURN;
}
+ PL_curpm = pm;
+
/* known replacement string? */
if (dstr) {
- if (SvTAINTED(dstr))
- rxtainted |= SUBST_TAINT_REPL;
-
- /* 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 (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
- char * const orig_pvx = SvPVX(TARG);
- const STRLEN new_len = sv_utf8_upgrade_nomg(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 || orig_pvx != SvPVX(TARG)) {
- goto setup_match;
- }
- }
-
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
c = SvPV_const(dstr, clen);
doutf8 = DO_UTF8(dstr);
}
+
+ if (SvTAINTED(dstr))
+ rxtainted |= SUBST_TAINT_REPL;
}
else {
c = NULL;
/* 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)
+ && (I32)clen <= RX_MINLENRET(rx)
+ && (once || !(r_flags & REXEC_COPY_STR))
+ && !(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) {
force_on_match = 0;
- s = SvPV_force(TARG, len);
+ s = SvPV_force_nomg(TARG, len);
goto force_it;
}
d = s;
- PL_curpm = pm;
if (once) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
}
}
else {
+ bool first;
+ SV *repl;
if (force_on_match) {
force_on_match = 0;
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
cases where it would be viable to drop into the copy code. */
TARG = sv_2mortal(newSVsv(TARG));
}
- s = SvPV_force(TARG, len);
+ s = 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));
- PL_curpm = pm;
if (!c) {
PERL_CONTEXT *cx;
SPAGAIN;
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
+ first = TRUE;
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(RX_SUBOFFSET(rx) == 0);
orig = RX_SUBBEG(rx);
s = orig + (m - s);
strend = s + (strend - m);
}
m = RX_OFFS(rx)[0].start + orig;
- if (doutf8 && !SvUTF8(dstr))
- sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
- else
- sv_catpvn_nomg(dstr, s, m-s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
s = RX_OFFS(rx)[0].end + orig;
- if (clen)
- sv_catpvn_nomg(dstr, c, clen);
+ if (first) {
+ /* replacement already stringified */
+ if (clen)
+ sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
+ first = FALSE;
+ }
+ else {
+ if (PL_encoding) {
+ if (!nsv) nsv = sv_newmortal();
+ sv_copypv(nsv, repl);
+ if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
+ sv_catsv(dstr, nsv);
+ }
+ else sv_catsv(dstr, repl);
+ if (SvTAINTED(repl))
+ rxtainted |= SUBST_TAINT_REPL;
+ }
if (once)
break;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
- if (doutf8 && !DO_UTF8(TARG))
- sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
- else
- sv_catpvn_nomg(dstr, s, strend - s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
/* From here on down we're using the copy, and leaving the original
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
SvPV_set(TARG, SvPVX(dstr));
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
- doutf8 |= DO_UTF8(dstr);
+ SvFLAGS(TARG) |= SvUTF8(dstr);
SvPV_set(dstr, NULL);
SPAGAIN;
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
(void)SvPOK_only_UTF8(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
}
/* See "how taint works" above */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((rxtainted & SUBST_TAINT_PAT) ||
((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
(SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
SvTAINTED_off(TOPs); /* may have got tainted earlier */
/* needed for mg_set below */
- PL_tainted =
- cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ TAINT_set(
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ );
SvTAINT(TARG);
}
SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
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
}
ENTER;
- SAVETMPS;
retry:
if (CvCLONE(cv) && ! CvCLONED(cv))
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv)))
+ if (CvANON(cv) || !(gv = CvGV(cv))) {
+ if (CvNAMED(cv))
+ DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
+ HEKfARG(CvNAME_HEK(cv)));
DIE(aTHX_ "Undefined subroutine called");
+ }
/* autoloaded stub? */
if (cv != GvCV(gv)) {
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");
else {
I32 markix = TOPMARK;
+ SAVETMPS;
PUTBACK;
+ 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) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
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));
}
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
PERL_ARGS_ASSERT_METHOD_COMMON;
if (!sv)
+ undefined:
Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
SVfARG(meth));
SvGETMAGIC(sv);
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;
STRLEN packlen;
- const char * packname = NULL;
- bool packname_is_utf8 = FALSE;
-
- /* this isn't a reference */
- if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
- const HE* const he =
- (const HE *)hv_common_key_len(
- PL_stashcache, packname,
- packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
+ const char * const packname = SvPV_nomg_const(sv, packlen);
+ const bool packname_is_utf8 = !!SvUTF8(sv);
+ const HE* const he =
+ (const HE *)hv_common(
+ PL_stashcache, NULL, packname, packlen,
+ packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
);
- if (he) {
+ if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
+ stash, sv));
goto fetch;
- }
}
- if (!SvOK(sv) ||
- !(packname) ||
- !(iogv = gv_fetchpvn_flags(
+ if (!(iogv = gv_fetchpvn_flags(
packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
)) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
/* this isn't the name of a filehandle either */
- if (!packname ||
- ((UTF8_IS_START(*packname) && DO_UTF8(sv))
- ? !isIDFIRST_utf8((U8*)packname)
- : !isIDFIRST_L1((U8)*packname)
- ))
+ if (!packlen)
{
- /* diag_listed_as: Can't call method "%s" without a package or object reference */
- Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
- SVfARG(meth),
- SvOK(sv) ? "without a package or object reference"
- : "on an undefined value");
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
+ "without a package or object reference",
+ SVfARG(meth));
}
/* assume it's a package name */
stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
SV* const ref = newSViv(PTR2IV(stash));
(void)hv_store(PL_stashcache, packname,
packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
+ stash, sv));
}
goto fetch;
}
*(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