/* Pushy stuff. */
+/* This is also called directly by pp_lvavref. */
PP(pp_padav)
{
dSP; dTARGET;
AV * const av = MUTABLE_AV(TOPs);
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
if (lvalue) {
- SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
- if (!*sv) {
- *sv = newSV_type(SVt_PVMG);
- sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
+ SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
+ if (!*svp) {
+ *svp = newSV_type(SVt_PVMG);
+ sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
}
- SETs(*sv);
+ SETs(*svp);
} else {
SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
}
if (PL_op->op_flags & OPf_STACKED)
sv = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
sv = GETTARGET;
else {
sv = DEFSV;
/* Lvalue operators. */
-static void
+static size_t
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
STRLEN len;
char *s;
+ size_t count = 0;
PERL_ARGS_ASSERT_DO_CHOMP;
if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
- return;
+ return 0;
if (SvTYPE(sv) == SVt_PVAV) {
I32 i;
AV *const av = MUTABLE_AV(sv);
for (i = 0; i <= max; i++) {
sv = MUTABLE_SV(av_fetch(av, i, FALSE));
if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
- do_chomp(retval, sv, chomping);
+ count += do_chomp(retval, sv, chomping);
}
- return;
+ return count;
}
else if (SvTYPE(sv) == SVt_PVHV) {
HV* const hv = MUTABLE_HV(sv);
HE* entry;
(void)hv_iterinit(hv);
while ((entry = hv_iternext(hv)))
- do_chomp(retval, hv_iterval(hv,entry), chomping);
- return;
+ count += do_chomp(retval, hv_iterval(hv,entry), chomping);
+ return count;
}
else if (SvREADONLY(sv)) {
Perl_croak_no_modify();
}
- else if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
- if (PL_encoding) {
+ if (IN_ENCODING) {
if (!SvUTF8(sv)) {
/* XXX, here sv is utf8-ized as a side-effect!
If encoding.pm is used properly, almost string-generating
operations, including literal strings, chr(), input data, etc.
should have been utf8-ized already, right?
*/
- sv_recode_to_utf8(sv, PL_encoding);
+ sv_recode_to_utf8(sv, _get_encoding());
}
}
if (RsPARA(PL_rs)) {
if (*s != '\n')
goto nope;
- ++SvIVX(retval);
+ ++count;
while (len && s[-1] == '\n') {
--len;
--s;
- ++SvIVX(retval);
+ ++count;
}
}
else {
}
rsptr = temp_buffer;
}
- else if (PL_encoding) {
+ else if (IN_ENCODING) {
/* RS is 8 bit, encoding.pm is used.
* Do not recode PL_rs as a side-effect. */
svrecode = newSVpvn(rsptr, rslen);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
rsptr = SvPV_const(svrecode, rslen);
rs_charlen = sv_len_utf8(svrecode);
}
if (rslen == 1) {
if (*s != *rsptr)
goto nope;
- ++SvIVX(retval);
+ ++count;
}
else {
if (len < rslen - 1)
s -= rslen - 1;
if (memNE(s, rsptr, rslen))
goto nope;
- SvIVX(retval) += rs_charlen;
+ count += rs_charlen;
}
}
- s = SvPV_force_nomg_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
SvNIOK_off(sv);
Safefree(temp_buffer);
} else {
- if (len && !SvPOK(sv))
+ if (len && (!SvPOK(sv) || SvIsCOW(sv)))
s = SvPV_force_nomg(sv, len);
if (DO_UTF8(sv)) {
if (s && len) {
sv_setpvs(retval, "");
SvSETMAGIC(sv);
}
+ return count;
}
dSP; dTARGET;
const bool chomping = PL_op->op_type == OP_SCHOMP;
+ const size_t count = do_chomp(TARG, TOPs, chomping);
if (chomping)
- sv_setiv(TARG, 0);
- do_chomp(TARG, TOPs, chomping);
+ sv_setiv(TARG, count);
SETTARG;
RETURN;
}
{
dSP; dMARK; dTARGET; dORIGMARK;
const bool chomping = PL_op->op_type == OP_CHOMP;
+ size_t count = 0;
- if (chomping)
- sv_setiv(TARG, 0);
while (MARK < SP)
- do_chomp(TARG, *++MARK, chomping);
+ count += do_chomp(TARG, *++MARK, chomping);
+ if (chomping)
+ sv_setiv(TARG, count);
SP = ORIGMARK;
XPUSHTARG;
RETURN;
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (inc && !SvOK(TARG))
sv_setiv(TARG, 0);
- SETs(TARG);
+ SETTARG;
return NORMAL;
}
SvGETMAGIC(sv);
}
else {
+ if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
+ /* The parser saw this as a list repeat, and there
+ are probably several items on the stack. But we're
+ in scalar/void context, and there's no pp_list to save us
+ now. So drop the rest of the items -- robin@kitsite.com
+ */
+ dMARK;
+ if (MARK + 1 < SP) {
+ MARK[1] = TOPm1s;
+ MARK[2] = TOPs;
+ }
+ else {
+ dTOPss;
+ ASSUME(MARK + 1 == SP);
+ XPUSHs(sv);
+ MARK[1] = &PL_sv_undef;
+ }
+ SP = MARK + 2;
+ }
tryAMAGICbin_MG(repeat_amg, AMGf_assign);
sv = POPs;
}
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
-#if 0
- /* This code was intended to fix 20010809.028:
-
- $x = 'abcd';
- for (($x =~ /./g) x 2) {
- print chop; # "abcdabcd" expected as output.
- }
-
- * but that change (#11635) broke this code:
-
- $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
-
- * I can't think of a better fix that doesn't introduce
- * an efficiency hit by copying the SVs. The stack isn't
- * refcounted, and mortalisation obviously doesn't
- * Do The Right Thing when the stack has more than
- * one pointer to the same mortal value.
- * .robin.
- */
- if (*SP) {
- *SP = sv_2mortal(newSVsv(*SP));
- SvREADONLY_on(*SP);
- }
-#else
if (*SP) {
if (mod && SvPADTMP(*SP)) {
*SP = sv_mortalcopy(*SP);
}
SvTEMP_off((*SP));
}
-#endif
SP--;
}
MARK++;
else
(void)SvPOK_only(TARG);
- if (PL_op->op_private & OPpREPEAT_DOLIST) {
- /* The parser saw this as a list repeat, and there
- are probably several items on the stack. But we're
- in scalar context, and there's no pp_list to save us
- now. So drop the rest of the items -- robin@kitsite.com
- */
- dMARK;
- SP = MARK;
- }
PUSHTARG;
}
RETURN;
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
#endif
{
/* simplest case shortcut */
/* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
- assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+ STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
SETs(TARG);
if(LIKELY(svflags == SVf_POK))
}
}
SPAGAIN;
- if (rvalue) {
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
+ SP++;
+ else if (rvalue) {
SvSETMAGIC(TARG);
PUSHs(TARG);
}
}
sv_setuv(ret, do_vecget(src, offset, size));
+ if (!lvalue)
+ SvSETMAGIC(ret);
PUSHs(ret);
RETURN;
}
little_utf8 = DO_UTF8(little);
if (big_utf8 ^ little_utf8) {
/* One needs to be upgraded. */
- if (little_utf8 && !PL_encoding) {
+ if (little_utf8 && !IN_ENCODING) {
/* Well, maybe instead we might be able to downgrade the small
string? */
char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
temp = little_utf8
? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
- if (PL_encoding) {
- sv_recode_to_utf8(temp, PL_encoding);
+ if (IN_ENCODING) {
+ sv_recode_to_utf8(temp, _get_encoding());
} else {
sv_utf8_upgrade(temp);
}
STRLEN len;
const U8 *s = (U8*)SvPV_const(argsv, len);
- if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
+ if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
SV * const tmpsv = sv_2mortal(newSVsv(argsv));
- s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
+ s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
argsv = tmpsv;
}
*tmps = '\0';
(void)SvPOK_only(TARG);
SvUTF8_on(TARG);
- XPUSHs(TARG);
+ XPUSHTARG;
RETURN;
}
*tmps = '\0';
(void)SvPOK_only(TARG);
- if (PL_encoding && !IN_BYTES) {
- sv_recode_to_utf8(TARG, PL_encoding);
+ if (IN_ENCODING && !IN_BYTES) {
+ sv_recode_to_utf8(TARG, _get_encoding());
tmps = SvPVX(TARG);
if (SvCUR(TARG) == 0
|| ! is_utf8_string((U8*)tmps, SvCUR(TARG))
}
}
- XPUSHs(TARG);
+ XPUSHTARG;
RETURN;
}
/* If Unicode, try to downgrade.
* If not possible, croak.
* Yes, we made this up. */
- SV* const tsv = sv_2mortal(newSVsv(left));
+ SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
- SvUTF8_on(tsv);
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
# endif
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
#else
PP(pp_split)
{
dSP; dTARG;
- AV *ary;
+ AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
STRLEN len;
#else
pm = (PMOP*)POPs;
#endif
- if (!pm || !s)
+ if (!pm)
DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
}
#endif
- else
- ary = NULL;
+ else if (pm->op_targ)
+ ary = (AV *)PAD_SVl(pm->op_targ);
if (ary) {
realarray = 1;
PUTBACK;
av_extend(ary,0);
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
av_clear(ary);
SPAGAIN;
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
RETURN;
}
+static void
+S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
+ const bool can_preserve)
+{
+ const SSize_t ix = SvIV(keysv);
+ if (can_preserve ? av_exists(av, ix) : TRUE) {
+ SV ** const svp = av_fetch(av, ix, 1);
+ if (!svp || !*svp)
+ Perl_croak(aTHX_ PL_no_aelem, ix);
+ save_aelem(av, ix, svp);
+ }
+ else
+ SAVEADELETE(av, ix);
+}
+
+static void
+S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
+ const bool can_preserve)
+{
+ if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
+ HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
+ SV ** const svp = he ? &HeVAL(he) : NULL;
+ if (!svp || !*svp)
+ Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ save_helem_flags(hv, keysv, svp, 0);
+ }
+ else
+ SAVEHDELETE(hv, keysv);
+}
+
+static void
+S_localise_gv_slot(pTHX_ GV *gv, U8 type)
+{
+ if (type == OPpLVREF_SV) {
+ save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
+ GvSV(gv) = 0;
+ }
+ else if (type == OPpLVREF_AV)
+ /* XXX Inefficient, as it creates a new AV, which we are
+ about to clobber. */
+ save_ary(gv);
+ else {
+ assert(type == OPpLVREF_HV);
+ /* XXX Likewise inefficient. */
+ save_hash(gv);
+ }
+}
+
+
PP(pp_refassign)
{
dSP;
+ SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
dTOPss;
+ const char *bad = NULL;
+ const U8 type = PL_op->op_private & OPpLVREF_TYPE;
if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
- if (SvTYPE(SvRV(sv)) > SVt_PVLV)
+ switch (type) {
+ case OPpLVREF_SV:
+ if (SvTYPE(SvRV(sv)) > SVt_PVLV)
+ bad = " SCALAR";
+ break;
+ case OPpLVREF_AV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVAV)
+ bad = "n ARRAY";
+ break;
+ case OPpLVREF_HV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVHV)
+ bad = " HASH";
+ break;
+ case OPpLVREF_CV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVCV)
+ bad = " CODE";
+ }
+ if (bad)
/* diag_listed_as: Assigned value is not %s reference */
- DIE(aTHX_ "Assigned value is not a SCALAR reference");
+ DIE(aTHX_ "Assigned value is not a%s reference", bad);
+ {
+ MAGIC *mg;
+ HV *stash;
switch (left ? SvTYPE(left) : 0) {
case 0:
{
SV * const old = PAD_SV(ARGTARG);
PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
SvREFCNT_dec(old);
+ if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == OPpLVAL_INTRO)
+ SAVECLEARSV(PAD_SVl(ARGTARG));
break;
}
case SVt_PVGV:
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ S_localise_gv_slot(aTHX_ (GV *)left, type);
+ }
gv_setref(left, sv);
SvSETMAGIC(left);
+ break;
+ case SVt_PVAV:
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
+ S_localise_aelem_lval(aTHX_ (AV *)left, key,
+ SvCANEXISTDELETE(left));
+ }
+ av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
+ break;
+ case SVt_PVHV:
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
+ S_localise_helem_lval(aTHX_ (HV *)left, key,
+ SvCANEXISTDELETE(left));
+ (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
}
if (PL_op->op_flags & OPf_MOD)
SETs(sv_2mortal(newSVsv(sv)));
/* XXX else can weak references go stale before they are read, e.g.,
in leavesub? */
RETURN;
+ }
+}
+
+PP(pp_lvref)
+{
+ dSP;
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
+ SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
+ SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
+ MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
+ &PL_vtbl_lvref, (char *)elem,
+ elem ? HEf_SVKEY : (I32)ARGTARG);
+ mg->mg_private = PL_op->op_private;
+ if (PL_op->op_private & OPpLVREF_ITER)
+ mg->mg_flags |= MGf_PERSIST;
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
+ if (elem) {
+ MAGIC *mg;
+ HV *stash;
+ const bool can_preserve = SvCANEXISTDELETE(arg);
+ if (SvTYPE(arg) == SVt_PVAV)
+ S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
+ else
+ S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
+ }
+ else if (arg) {
+ S_localise_gv_slot(aTHX_ (GV *)arg,
+ PL_op->op_private & OPpLVREF_TYPE);
+ }
+ else if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(ARGTARG));
+ }
+ XPUSHs(ret);
+ RETURN;
+}
+
+PP(pp_lvrefslice)
+{
+ dSP; dMARK;
+ AV * const av = (AV *)POPs;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool can_preserve = FALSE;
+
+ if (UNLIKELY(localizing)) {
+ MAGIC *mg;
+ HV *stash;
+ SV **svp;
+
+ can_preserve = SvCANEXISTDELETE(av);
+
+ if (SvTYPE(av) == SVt_PVAV) {
+ SSize_t max = -1;
+
+ for (svp = MARK + 1; svp <= SP; svp++) {
+ const SSize_t elem = SvIV(*svp);
+ if (elem > max)
+ max = elem;
+ }
+ if (max > AvMAX(av))
+ av_extend(av, max);
+ }
+ }
+
+ while (++MARK <= SP) {
+ SV * const elemsv = *MARK;
+ if (SvTYPE(av) == SVt_PVAV)
+ S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
+ else
+ S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
+ *MARK = sv_2mortal(newSV_type(SVt_PVMG));
+ sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
+ }
+ RETURN;
}
+PP(pp_lvavref)
+{
+ if (PL_op->op_flags & OPf_STACKED)
+ Perl_pp_rv2av(aTHX);
+ else
+ Perl_pp_padav(aTHX);
+ {
+ dSP;
+ dTOPss;
+ SETs(0); /* special alias marker that aassign recognises */
+ XPUSHs(sv);
+ RETURN;
+ }
+}
/*
* Local variables:
https://perl5.git.perl.org / perl5.git / blobdiff