* 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;
}
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) {
+ 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";
}
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
sv = *lelem++;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- if (relem > lastrelem) {
- av_clear(MUTABLE_AV(sv));
- if (PL_delaymagic & DM_ARRAY_ISA)
- SvSETMAGIC(sv);
- if (gimme == G_ARRAY && !hash && !ary)
- ary = MUTABLE_AV(sv);
- break;
- }
ary = MUTABLE_AV(sv);
magic = SvMAGICAL(ary) != 0;
ENTER;
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ int odd;
+ int duplicates = 0;
SV** topelem = relem;
- if (relem > lastrelem) {
- hv_clear(MUTABLE_HV(sv));
- if (gimme == G_ARRAY && !hash && !ary) {
- hash = MUTABLE_HV(sv);
- firsthashrelem = relem;
- }
- break;
- }
+ 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;
- ODD:
- sv = *relem ? gimme == G_ARRAY ? sv_mortalcopy(*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++;
+ 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 {
/* 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, firsthashrelem);
- /* we have lelem to reuse, it's not needed anymore */
- *(relem+1) = NULL;
- goto ODD;
- }
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;
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 - firsthashrelem)&1)? lastrelem : lastrelem+1;
- }
- 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;
(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;
}
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;
}
}
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) {
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
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. */
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;
#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))
{
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
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));
}
*(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