*/
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;
| 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 */
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--;
}
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
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 = sv_newmortal();
- 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 (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)
+ 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;
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);
}
(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;
}
}
}
+#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
}
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;
+#ifdef PERL_SAWAMPERSAND
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;
+#endif
}
if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
RETPUSHYES;
}
+#ifdef PERL_SAWAMPERSAND
yup: /* Confirmed by INTUIT */
+#endif
if (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
RX_SUBLEN(rx) = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
+#ifdef PERL_SAWAMPERSAND
+ if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
+#endif
+ {
I32 off;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+#ifdef PERL_ANY_COW
+ if (SvCANCOW(TARG)) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
{
RX_SUBBEG(rx) = savepvn(t, strend - t);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
RX_SAVED_COPY(rx) = NULL;
#endif
}
off = RX_OFFS(rx)[0].start = s - t;
RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
}
+#ifdef PERL_SAWAMPERSAND
else { /* startp/endp are used by @- @+. */
RX_OFFS(rx)[0].start = s - truebase;
RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
+#endif
/* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
assert(!RX_NPARENS(rx));
RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
}
}
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) {
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
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
+#ifdef PERL_ANY_COW
&& !is_cow
#endif
&& (SvREADONLY(TARG)
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. */
rx = PM_GETRE(pm);
}
+#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;
/* 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))
+ && !(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) {
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 */
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
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
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;
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
*(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)
https://perl5.git.perl.org / perl5.git / blobdiff