/* pp.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "It's a big house this, and very peculiar. Always a bit more to discover,
- * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
+ * 'It's a big house this, and very peculiar. Always a bit more
+ * to discover, and no knowing what you'll find round a corner.
+ * And Elves, sir!' --Samwise Gamgee
+ *
+ * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
/* This file contains general pp ("push/pop") functions that execute the
}
gimme = GIMME_V;
if (gimme == G_ARRAY) {
- const I32 maxarg = AvFILL((AV*)TARG) + 1;
+ const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
U32 i;
for (i=0; i < (U32)maxarg; i++) {
- SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
else {
- Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
}
SP += maxarg;
}
else if (gimme == G_SCALAR) {
SV* const sv = sv_newmortal();
- const I32 maxarg = AvFILL((AV*)TARG) + 1;
+ const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
sv_setiv(sv, maxarg);
PUSHs(sv);
}
RETURNOP(do_kv());
}
else if (gimme == G_SCALAR) {
- SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
+ SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
SETs(sv);
}
RETURN;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
- GV * const gv = (GV*) sv_newmortal();
+ GV * const gv = MUTABLE_GV(sv_newmortal());
gv_init(gv, 0, "", 0, 0);
- GvIOp(gv) = (IO *)sv;
+ GvIOp(gv) = MUTABLE_IO(sv);
SvREFCNT_inc_void_NN(sv);
- sv = (SV*) gv;
+ sv = MUTABLE_SV(gv);
}
- else if (SvTYPE(sv) != SVt_PVGV)
+ else if (!isGV_with_GP(sv))
DIE(aTHX_ "Not a GLOB reference");
}
else {
- if (SvTYPE(sv) != SVt_PVGV) {
+ if (!isGV_with_GP(sv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
* NI-S 1999/05/07
*/
if (SvREADONLY(sv))
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
if (PL_op->op_private & OPpDEREF) {
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
SV * const namesv = PAD_SV(cUNOP->op_targ);
const char * const name = SvPV(namesv, len);
- gv = (GV*)newSV(0);
+ gv = MUTABLE_GV(newSV(0));
gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
}
else {
const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen(name);
}
- if (SvTYPE(sv) < SVt_RV)
- sv_upgrade(sv, SVt_RV);
- else if (SvPVX_const(sv)) {
- SvPV_free(sv);
- SvLEN_set(sv, 0);
- SvCUR_set(sv, 0);
- }
- SvRV_set(sv, (SV*)gv);
+ prepare_SV_for_RV(sv);
+ SvRV_set(sv, MUTABLE_SV(gv));
SvROK_on(sv);
SvSETMAGIC(sv);
goto wasref;
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
+ SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
if (!temp
&& (!is_gv_magical_sv(sv,0)
- || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
+ || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
+ SVt_PVGV))))) {
RETSETUNDEF;
}
sv = temp;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
+ DIE(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), "a symbol");
if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
== OPpDONT_INIT_GV) {
/* We are the target of a coderef assignment. Return
things. */
RETURN;
}
- sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
+ sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
}
}
}
if (PL_op->op_private & OPpLVAL_INTRO)
- save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
+ save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
SETs(sv);
RETURN;
}
+/* Helper function for pp_rv2sv and pp_rv2av */
+GV *
+Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
+ const svtype type, SV ***spp)
+{
+ dVAR;
+ GV *gv;
+
+ PERL_ARGS_ASSERT_SOFTREF2XV;
+
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), what);
+ else
+ Perl_die(aTHX_ PL_no_usym, what);
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF)
+ Perl_die(aTHX_ PL_no_usym, what);
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ if (type != SVt_PV && GIMME_V == G_ARRAY) {
+ (*spp)--;
+ return NULL;
+ }
+ **spp = &PL_sv_undef;
+ return NULL;
+ }
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ gv = gv_fetchsv(sv, 0, type);
+ if (!gv
+ && (!is_gv_magical_sv(sv,0)
+ || !(gv = gv_fetchsv(sv, GV_ADD, type))))
+ {
+ **spp = &PL_sv_undef;
+ return NULL;
+ }
+ }
+ else {
+ gv = gv_fetchsv(sv, GV_ADD, type);
+ }
+ return gv;
+}
+
PP(pp_rv2sv)
{
dVAR; dSP; dTOPss;
}
}
else {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
goto wasref;
}
- if (PL_op->op_private & HINT_STRICT_REFS) {
- if (SvOK(sv))
- DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
- else
- DIE(aTHX_ PL_no_usym, "a SCALAR");
- }
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF)
- DIE(aTHX_ PL_no_usym, "a SCALAR");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
- if (!gv
- && (!is_gv_magical_sv(sv, 0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
- }
+ gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
+ if (!gv)
+ RETURN;
}
sv = GvSVn(gv);
}
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO) {
if (cUNOP->op_first->op_type == OP_NULL)
- sv = save_scalar((GV*)TOPs);
+ sv = save_scalar(MUTABLE_GV(TOPs));
else if (gv)
sv = save_scalar(gv);
else
- Perl_croak(aTHX_ PL_no_localize_ref);
+ Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(sv, PL_op->op_private & OPpDEREF);
PP(pp_av2arylen)
{
dVAR; dSP;
- AV * const av = (AV*)TOPs;
- SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
- if (!*sv) {
- *sv = newSV(0);
- sv_upgrade(*sv, SVt_PVMG);
- sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
- }
- SETs(*sv);
+ 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);
+ }
+ SETs(*sv);
+ } else {
+ SETs(sv_2mortal(newSViv(
+ AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
+ )));
+ }
RETURN;
}
LvTYPE(TARG) = '.';
if (LvTARG(TARG) != sv) {
- if (LvTARG(TARG))
- SvREFCNT_dec(LvTARG(TARG));
+ SvREFCNT_dec(LvTARG(TARG));
LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
PUSHs(TARG); /* no SvSETMAGIC */
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
if (cv) {
if (CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
if ((PL_op->op_private & OPpLVAL_INTRO)) {
if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
cv = GvCV(gv);
}
}
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
- cv = (CV*)gv;
+ cv = MUTABLE_CV(gv);
}
else
- cv = (CV*)&PL_sv_undef;
- SETs((SV*)cv);
+ cv = MUTABLE_CV(&PL_sv_undef);
+ SETs(MUTABLE_SV(cv));
RETURN;
}
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
if (code == -KEY_chop || code == -KEY_chomp
- || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
+ || code == -KEY_exec || code == -KEY_system)
goto set;
if (code == -KEY_mkdir) {
- ret = sv_2mortal(newSVpvs("_;$"));
+ ret = newSVpvs_flags("_;$", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
+ ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
goto set;
}
if (code == -KEY_readpipe) {
if (defgv && str[n - 1] == '$')
str[n - 1] = '_';
str[n++] = '\0';
- ret = sv_2mortal(newSVpvn(str, n - 1));
+ ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
}
else if (code) /* Non-Overridable */
goto set;
}
cv = sv_2cv(TOPs, &stash, &gv, 0);
if (cv && SvPOK(cv))
- ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
+ ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
set:
SETs(ret);
RETURN;
PP(pp_anoncode)
{
dVAR; dSP;
- CV* cv = (CV*)PAD_SV(PL_op->op_targ);
+ CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
if (CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
EXTEND(SP,1);
- PUSHs((SV*)cv);
+ PUSHs(MUTABLE_SV(cv));
RETURN;
}
dVAR;
SV* rv;
+ PERL_ARGS_ASSERT_REFTO;
+
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
if (LvTARGLEN(sv))
vivify_defelem(sv);
SvREFCNT_inc_void_NN(sv);
}
else if (SvTYPE(sv) == SVt_PVAV) {
- if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
- av_reify((AV*)sv);
+ if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
+ av_reify(MUTABLE_AV(sv));
SvTEMP_off(sv);
SvREFCNT_inc_void_NN(sv);
}
SvREFCNT_inc_void_NN(sv);
}
rv = sv_newmortal();
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_IV);
SvRV_set(rv, sv);
SvROK_on(rv);
return rv;
if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
Perl_croak(aTHX_ "Attempt to bless into a reference");
ptr = SvPV_const(ssv,len);
- if (len == 0 && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Explicit blessing to '' (assuming package main)");
- stash = gv_stashpvn(ptr, len, TRUE);
+ if (len == 0)
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Explicit blessing to '' (assuming package main)");
+ stash = gv_stashpvn(ptr, len, GV_ADD);
}
(void)sv_bless(TOPs, stash);
SV *sv = POPs;
const char * const elem = SvPV_nolen_const(sv);
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
SV * tmpRef = NULL;
sv = NULL;
switch (*elem) {
case 'A':
if (strEQ(second_letter, "RRAY"))
- tmpRef = (SV*)GvAV(gv);
+ tmpRef = MUTABLE_SV(GvAV(gv));
break;
case 'C':
if (strEQ(second_letter, "ODE"))
- tmpRef = (SV*)GvCVu(gv);
+ tmpRef = MUTABLE_SV(GvCVu(gv));
break;
case 'F':
if (strEQ(second_letter, "ILEHANDLE")) {
/* finally deprecated in 5.8.0 */
deprecate("*glob{FILEHANDLE}");
- tmpRef = (SV*)GvIOp(gv);
+ tmpRef = MUTABLE_SV(GvIOp(gv));
}
else
if (strEQ(second_letter, "ORMAT"))
- tmpRef = (SV*)GvFORM(gv);
+ tmpRef = MUTABLE_SV(GvFORM(gv));
break;
case 'G':
if (strEQ(second_letter, "LOB"))
- tmpRef = (SV*)gv;
+ tmpRef = MUTABLE_SV(gv);
break;
case 'H':
if (strEQ(second_letter, "ASH"))
- tmpRef = (SV*)GvHV(gv);
+ tmpRef = MUTABLE_SV(GvHV(gv));
break;
case 'I':
if (*second_letter == 'O' && !elem[2])
- tmpRef = (SV*)GvIOp(gv);
+ tmpRef = MUTABLE_SV(GvIOp(gv));
break;
case 'N':
if (strEQ(second_letter, "AME"))
- sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
+ sv = newSVhek(GvNAME_HEK(gv));
break;
case 'P':
if (strEQ(second_letter, "ACKAGE")) {
case SVt_NULL:
break;
case SVt_PVAV:
- av_undef((AV*)sv);
+ av_undef(MUTABLE_AV(sv));
break;
case SVt_PVHV:
- hv_undef((HV*)sv);
+ hv_undef(MUTABLE_HV(sv));
break;
case SVt_PVCV:
- if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
- CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
+ if (cv_const_sv((const CV *)sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
+ CvANON((const CV *)sv) ? "(anonymous)"
+ : GvENAME(CvGV((const CV *)sv)));
/* FALLTHROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
- GV* const gv = CvGV((CV*)sv);
- cv_undef((CV*)sv);
- CvGV((CV*)sv) = gv;
+ GV* const gv = CvGV((const CV *)sv);
+ cv_undef(MUTABLE_CV(sv));
+ CvGV((const CV *)sv) = gv;
}
break;
case SVt_PVGV:
- if (SvFAKE(sv))
+ if (SvFAKE(sv)) {
SvSetMagicSV(sv, &PL_sv_undef);
- else {
+ break;
+ }
+ else if (isGV_with_GP(sv)) {
GP *gp;
- gp_free((GV*)sv);
+ HV *stash;
+
+ /* undef *Foo:: */
+ if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
+ mro_isa_changed_in(stash);
+ /* undef *Pkg::meth_name ... */
+ else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
+ && HvNAME_get(stash))
+ mro_method_changed_in(stash);
+
+ gp_free(MUTABLE_GV(sv));
Newxz(gp, 1, GP);
GvGP(sv) = gp_ref(gp);
GvSV(sv) = newSV(0);
GvLINE(sv) = CopLINE(PL_curcop);
- GvEGV(sv) = (GV*)sv;
+ GvEGV(sv) = MUTABLE_GV(sv);
GvMULTI_on(sv);
+ break;
}
- break;
+ /* FALL THROUGH */
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
SvPV_free(sv);
PP(pp_predec)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+ DIE(aTHX_ "%s", PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
{
PP(pp_postinc)
{
dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+ DIE(aTHX_ "%s", PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
PP(pp_postdec)
{
dVAR; dSP; dTARGET;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+ DIE(aTHX_ "%s", PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
PP(pp_pow)
{
- dVAR; dSP; dATARGET;
+ dVAR; dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
tryAMAGICbin(pow,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
#ifdef PERL_PRESERVE_IVUV
/* For integer to integer power, we do the calculation by hand wherever
we're sure it is safe; otherwise we call pow() and try to convert to
integer afterwards. */
{
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
UV power;
bool baseuok;
UV baseuv;
- if (SvUOK(TOPs)) {
- power = SvUVX(TOPs);
+ if (SvUOK(svr)) {
+ power = SvUVX(svr);
} else {
- const IV iv = SvIVX(TOPs);
+ const IV iv = SvIVX(svr);
if (iv >= 0) {
power = iv;
} else {
}
}
- baseuok = SvUOK(TOPm1s);
+ baseuok = SvUOK(svl);
if (baseuok) {
- baseuv = SvUVX(TOPm1s);
+ baseuv = SvUVX(svl);
} else {
- const IV iv = SvIVX(TOPm1s);
+ const IV iv = SvIVX(svl);
if (iv >= 0) {
baseuv = iv;
baseuok = TRUE; /* effectively it's a UV now */
}
SP--;
SETn( result );
- SvIV_please(TOPs);
+ SvIV_please(svr);
RETURN;
} else {
register unsigned int highbit = 8 * sizeof(UV);
float_it:
#endif
{
- dPOPTOPnnrl;
+ NV right = SvNV(svr);
+ NV left = SvNV(svl);
+ (void)POPs;
#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
/*
#ifdef PERL_PRESERVE_IVUV
if (is_int)
- SvIV_please(TOPs);
+ SvIV_please(svr);
#endif
RETURN;
}
PP(pp_multiply)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin(mult,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ bool auvok = SvUOK(svl);
+ bool buvok = SvUOK(svr);
const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
UV alow;
UV bhigh;
if (auvok) {
- alow = SvUVX(TOPm1s);
+ alow = SvUVX(svl);
} else {
- const IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
alow = aiv;
auvok = TRUE; /* effectively it's a UV now */
}
}
if (buvok) {
- blow = SvUVX(TOPs);
+ blow = SvUVX(svr);
} else {
- const IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
blow = biv;
buvok = TRUE; /* effectively it's a UV now */
}
} /* product_middle too large */
} /* ahigh && bhigh */
- } /* SvIOK(TOPm1s) */
- } /* SvIOK(TOPs) */
+ } /* SvIOK(svl) */
+ } /* SvIOK(svr) */
#endif
{
- dPOPTOPnnrl;
+ NV right = SvNV(svr);
+ NV left = SvNV(svl);
+ (void)POPs;
SETn( left * right );
RETURN;
}
PP(pp_divide)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin(div,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
/* Only try to do UV divide first
if ((SLOPPYDIVIDE is true) or
(PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
#endif
#ifdef PERL_TRY_UV_DIVIDE
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool left_non_neg = SvUOK(TOPm1s);
- bool right_non_neg = SvUOK(TOPs);
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ bool left_non_neg = SvUOK(svl);
+ bool right_non_neg = SvUOK(svr);
UV left;
UV right;
if (right_non_neg) {
- right = SvUVX(TOPs);
+ right = SvUVX(svr);
}
else {
- const IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
right = biv;
right_non_neg = TRUE; /* effectively it's a UV now */
DIE(aTHX_ "Illegal division by zero");
if (left_non_neg) {
- left = SvUVX(TOPm1s);
+ left = SvUVX(svl);
}
else {
- const IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
left = aiv;
left_non_neg = TRUE; /* effectively it's a UV now */
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
- dPOPPOPnnrl;
+ NV right = SvNV(svr);
+ NV left = SvNV(svl);
+ (void)POPs;(void)POPs;
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (! Perl_isnan(right) && right == 0.0)
+#else
if (right == 0.0)
+#endif
DIE(aTHX_ "Illegal division by zero");
PUSHn( left / right );
RETURN;
bool dright_valid = FALSE;
NV dright = 0.0;
NV dleft = 0.0;
-
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
- right_neg = !SvUOK(TOPs);
+ SV * svl;
+ SV * const svr = sv_2num(TOPs);
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
+ right_neg = !SvUOK(svr);
if (!right_neg) {
- right = SvUVX(POPs);
+ right = SvUVX(svr);
} else {
- const IV biv = SvIVX(POPs);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
right = biv;
right_neg = FALSE; /* effectively it's a UV now */
}
}
else {
- dright = POPn;
+ dright = SvNV(svr);
right_neg = dright < 0;
if (right_neg)
dright = -dright;
use_double = TRUE;
}
}
+ sp--;
/* At this point use_double is only true if right is out of range for
a UV. In range NV has been rounded down to nearest UV and
use_double false. */
- SvIV_please(TOPs);
- if (!use_double && SvIOK(TOPs)) {
- if (SvIOK(TOPs)) {
- left_neg = !SvUOK(TOPs);
+ svl = sv_2num(TOPs);
+ SvIV_please(svl);
+ if (!use_double && SvIOK(svl)) {
+ if (SvIOK(svl)) {
+ left_neg = !SvUOK(svl);
if (!left_neg) {
- left = SvUVX(POPs);
+ left = SvUVX(svl);
} else {
- const IV aiv = SvIVX(POPs);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
left = aiv;
left_neg = FALSE; /* effectively it's a UV now */
}
}
else {
- dleft = POPn;
+ dleft = SvNV(svl);
left_neg = dleft < 0;
if (left_neg)
dleft = -dleft;
}
}
}
+ sp--;
if (use_double) {
NV dans;
count = (IV)nv;
}
else
- count = SvIVx(sv);
+ count = SvIV(sv);
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
static const char oom_list_extend[] = "Out of memory during list extend";
}
MARK++;
repeatcpy((char*)(MARK + items), (char*)MARK,
- items * sizeof(SV*), count - 1);
+ items * sizeof(const SV *), count - 1);
SP += max;
}
else if (count <= 0)
SvCUR_set(TARG, 0);
else {
const STRLEN max = (UV)count * len;
- if (len > ((MEM_SIZE)~0)/count)
+ if (len > MEM_SIZE_MAX / count)
Perl_croak(aTHX_ oom_string_extend);
MEM_WRAP_CHECK_1(max, char, oom_string_extend);
SvGROW(TARG, max + 1);
PP(pp_subtract)
{
- dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
- useleft = USE_LEFT(TOPm1s);
+ dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ tryAMAGICbin(subtr,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
+ useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(svr);
+ if (SvIOK(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- if ((auvok = SvUOK(TOPm1s)))
- auv = SvUVX(TOPm1s);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ if ((auvok = SvUOK(svl)))
+ auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
bool result_good = 0;
UV result;
register UV buv;
- bool buvok = SvUOK(TOPs);
+ bool buvok = SvUOK(svr);
if (buvok)
- buv = SvUVX(TOPs);
+ buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
}
}
#endif
- useleft = USE_LEFT(TOPm1s);
{
- dPOPnv;
+ NV value = SvNV(svr);
+ (void)POPs;
+
if (!useleft) {
/* left operand is undef, treat as zero - value */
SETn(-value);
RETURN;
}
- SETn( TOPn - value );
+ SETn( SvNV(svl) - value );
RETURN;
}
}
{
dVAR; dSP; dTARGET; tryAMAGICun(neg);
{
- dTOPss;
+ SV * const sv = sv_2num(TOPs);
const int flags = SvFLAGS(sv);
SvGETMAGIC(sv);
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
STRLEN len;
const char * const s = SvPV_const(sv, len);
if (isIDFIRST(*s)) {
- sv_setpvn(TARG, "-", 1);
+ sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
else if (*s == '+' || *s == '-') {
if (SvNOK(sv))
sv_setnv(TARG, -SvNV(sv));
else {
- sv_setpvn(TARG, "-", 1);
+ sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
}
sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
SvUTF8_off(TARG);
}
- SETs(TARG);
+ SETTARG;
RETURN;
}
#ifdef LIBERAL
#endif
for ( ; anum > 0; anum--, tmps++)
*tmps = ~*tmps;
-
- SETs(TARG);
+ SETTARG;
}
RETURN;
}
}
}
+#if defined(__GLIBC__) && IVSIZE == 8
STATIC
PP(pp_i_modulo_0)
+#else
+PP(pp_i_modulo)
+#endif
{
/* This is the vanilla old i_modulo. */
dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
#if defined(__GLIBC__) && IVSIZE == 8
STATIC
PP(pp_i_modulo_1)
+
{
/* This is the i_modulo with the workaround for the _moddi3 bug
* in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
* See below for pp_i_modulo. */
- dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
dPOPTOPiirl;
if (!right)
RETURN;
}
}
-#endif
PP(pp_i_modulo)
{
* opcode dispatch table if that is the case, remembering to
* also apply the workaround so that this first round works
* right, too. See [perl #9402] for more information. */
-#if defined(__GLIBC__) && IVSIZE == 8
{
IV l = 3;
IV r = -10;
right = PERL_ABS(right);
}
}
-#endif
/* avoid FPE_INTOVF on some platforms when left is IV_MIN */
if (right == -1)
SETi( 0 );
RETURN;
}
}
+#endif
PP(pp_i_add)
{
{
dVAR; dSP; dTARGET; tryAMAGICun(int);
{
- const IV iv = TOPi; /* attempt to convert to IV if possible. */
+ SV * const sv = sv_2num(TOPs);
+ const IV iv = SvIV(sv);
/* XXX it's arguable that compiler casting to IV might be subtly
different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
else preferring IV has introduced a subtle behaviour change bug. OTOH
relying on floating point to be accurate is a bug. */
- if (!SvOK(TOPs))
+ if (!SvOK(sv)) {
SETu(0);
- else if (SvIOK(TOPs)) {
- if (SvIsUV(TOPs)) {
- const UV uv = TOPu;
- SETu(uv);
- } else
+ }
+ else if (SvIOK(sv)) {
+ if (SvIsUV(sv))
+ SETu(SvUV(sv));
+ else
SETi(iv);
- } else {
- const NV value = TOPn;
+ }
+ else {
+ const NV value = SvNV(sv);
if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
{
dVAR; dSP; dTARGET; tryAMAGICun(abs);
{
+ SV * const sv = sv_2num(TOPs);
/* This will cache the NV value if string isn't actually integer */
- const IV iv = TOPi;
+ const IV iv = SvIV(sv);
- if (!SvOK(TOPs))
+ if (!SvOK(sv)) {
SETu(0);
- else if (SvIOK(TOPs)) {
+ }
+ else if (SvIOK(sv)) {
/* IVX is precise */
- if (SvIsUV(TOPs)) {
- SETu(TOPu); /* force it to be numeric only */
+ if (SvIsUV(sv)) {
+ SETu(SvUV(sv)); /* force it to be numeric only */
} else {
if (iv >= 0) {
SETi(iv);
}
}
} else{
- const NV value = TOPn;
+ const NV value = SvNV(sv);
if (value < 0.0)
SETn(-value);
else
dVAR; dSP; dTARGET;
SV * const sv = TOPs;
- if (SvAMAGIC(sv)) {
- /* For an overloaded scalar, we can't know in advance if it's going to
- be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
- cache the length. Maybe that should be a documented feature of it.
+ if (SvGAMAGIC(sv)) {
+ /* For an overloaded or magic scalar, we can't know in advance if
+ it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
+ it likes to cache the length. Maybe that should be a documented
+ feature of it.
*/
STRLEN len;
- const char *const p = SvPV_const(sv, len);
+ const char *const p
+ = sv_2pv_flags(sv, &len,
+ SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
- if (DO_UTF8(sv)) {
+ if (!p)
+ SETs(&PL_sv_undef);
+ else if (DO_UTF8(sv)) {
SETi(utf8_length((U8*)p, (U8*)p + len));
}
else
SETi(len);
-
+ } else if (SvOK(sv)) {
+ /* Neither magic nor overloaded. */
+ if (DO_UTF8(sv))
+ SETi(sv_len_utf8(sv));
+ else
+ SETi(sv_len(sv));
+ } else {
+ SETs(&PL_sv_undef);
}
- else if (DO_UTF8(sv))
- SETi(sv_len_utf8(sv));
- else
- SETi(sv_len(sv));
RETURN;
}
if (fail < 0) {
if (lvalue || repl)
Perl_croak(aTHX_ "substr outside of string");
- if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
RETPUSHUNDEF;
}
else {
repl = SvPV_const(repl_sv_copy, repl_len);
repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
}
- sv_insert(sv, pos, rem, repl, repl_len);
+ if (!SvOK(sv))
+ sv_setpvs(sv, "");
+ sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
if (repl_is_utf8)
SvUTF8_on(sv);
- if (repl_sv_copy)
- SvREFCNT_dec(repl_sv_copy);
+ SvREFCNT_dec(repl_sv_copy);
}
else if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
SvPV_force_nolen(sv);
- if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr");
}
if (isGV_with_GP(sv))
SvPV_force_nolen(sv);
else if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only_UTF8(sv);
else
- sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
+ sv_setpvs(sv, ""); /* avoid lexical reincarnation */
}
if (SvTYPE(TARG) < SVt_PVLV) {
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
- if (LvTARG(TARG))
- SvREFCNT_dec(LvTARG(TARG));
+ SvREFCNT_dec(LvTARG(TARG));
LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
LvTARGOFF(TARG) = upos;
}
LvTYPE(TARG) = 'v';
if (LvTARG(TARG) != src) {
- if (LvTARG(TARG))
- SvREFCNT_dec(LvTARG(TARG));
+ SvREFCNT_dec(LvTARG(TARG));
LvTARG(TARG) = SvREFCNT_inc_simple(src);
}
LvTARGOFF(TARG) = offset;
Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
will trigger magic and overloading again, as will fbm_instr()
*/
- big = sv_2mortal(newSVpvn(big_p, biglen));
- if (big_utf8)
- SvUTF8_on(big);
+ big = newSVpvn_flags(big_p, biglen,
+ SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
big_p = SvPVX(big);
}
if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
This is all getting to messy. The API isn't quite clean enough,
because data access has side effects.
*/
- little = sv_2mortal(newSVpvn(little_p, llen));
- if (little_utf8)
- SvUTF8_on(little);
+ little = newSVpvn_flags(little_p, llen,
+ SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
little_p = SvPVX(little);
}
if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
}
- if (temp)
- SvREFCNT_dec(temp);
+ SvREFCNT_dec(temp);
fail:
PUSHi(retval + arybase);
RETURN;
PP(pp_sprintf)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ if (SvTAINTED(MARK[1]))
+ TAINT_PROPER("sprintf");
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
XPUSHu(DO_UTF8(argsv) ?
utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
- (*s & 0xff));
+ (UV)(*s & 0xff));
RETURN;
}
# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
# endif
- SETs(TARG);
+ SETTARG;
RETURN;
#else
DIE(aTHX_
if (SvOK(source)) {
s = (const U8*)SvPV_nomg_const(source, slen);
} else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(source);
s = (const U8*)"";
slen = 0;
}
need = slen + 1;
}
- if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
+ if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
/* We can convert in place. */
dest = source;
SvGETMAGIC(source);
if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && !DO_UTF8(source)) {
+ && SvTEMP(source) && !DO_UTF8(source)) {
/* We can convert in place. */
dest = source;
if (SvOK(source)) {
s = (const U8*)SvPV_nomg_const(source, len);
} else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(source);
s = (const U8*)"";
len = 0;
}
SvGETMAGIC(source);
if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && !DO_UTF8(source)) {
+ && SvTEMP(source) && !DO_UTF8(source)) {
/* We can convert in place. */
dest = source;
if (SvOK(source)) {
s = (const U8*)SvPV_nomg_const(source, len);
} else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(source);
s = (const U8*)"";
len = 0;
}
}
else
sv_setpvn(TARG, s, len);
- SETs(TARG);
- if (SvSMAGICAL(TARG))
- mg_set(TARG);
+ SETTARG;
RETURN;
}
PP(pp_aslice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register AV* const av = (AV*)POPs;
+ register AV *const av = MUTABLE_AV(POPs);
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
const I32 arybase = CopARYBASE_get(PL_curcop);
- if (lval && PL_op->op_private & OPpLVAL_INTRO) {
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool can_preserve = FALSE;
+
+ if (localizing) {
+ MAGIC *mg;
+ HV *stash;
+
+ can_preserve = SvCANEXISTDELETE(av);
+ }
+
+ if (lval && localizing) {
register SV **svp;
I32 max = -1;
for (svp = MARK + 1; svp <= SP; svp++) {
- const I32 elem = SvIVx(*svp);
+ const I32 elem = SvIV(*svp);
if (elem > max)
max = elem;
}
if (max > AvMAX(av))
av_extend(av, max);
}
+
while (++MARK <= SP) {
register SV **svp;
- I32 elem = SvIVx(*MARK);
+ I32 elem = SvIV(*MARK);
+ bool preeminent = TRUE;
if (elem > 0)
elem -= arybase;
+ if (localizing && can_preserve) {
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ preeminent = av_exists(av, elem);
+ }
+
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
DIE(aTHX_ PL_no_aelem, elem);
- if (PL_op->op_private & OPpLVAL_INTRO)
- save_aelem(av, elem, svp);
+ if (localizing) {
+ if (preeminent)
+ save_aelem(av, elem, svp);
+ else
+ SAVEADELETE(av, elem);
+ }
}
*MARK = svp ? *svp : &PL_sv_undef;
}
RETURN;
}
+PP(pp_aeach)
+{
+ dVAR;
+ dSP;
+ AV *array = MUTABLE_AV(POPs);
+ const I32 gimme = GIMME_V;
+ IV *iterp = Perl_av_iter_p(aTHX_ array);
+ const IV current = (*iterp)++;
+
+ if (current > av_len(array)) {
+ *iterp = 0;
+ if (gimme == G_SCALAR)
+ RETPUSHUNDEF;
+ else
+ RETURN;
+ }
+
+ EXTEND(SP, 2);
+ mPUSHi(CopARYBASE_get(PL_curcop) + current);
+ if (gimme == G_ARRAY) {
+ SV **const element = av_fetch(array, current, 0);
+ PUSHs(element ? *element : &PL_sv_undef);
+ }
+ RETURN;
+}
+
+PP(pp_akeys)
+{
+ dVAR;
+ dSP;
+ AV *array = MUTABLE_AV(POPs);
+ const I32 gimme = GIMME_V;
+
+ *Perl_av_iter_p(aTHX_ array) = 0;
+
+ if (gimme == G_SCALAR) {
+ dTARGET;
+ PUSHi(av_len(array) + 1);
+ }
+ else if (gimme == G_ARRAY) {
+ IV n = Perl_av_len(aTHX_ array);
+ IV i = CopARYBASE_get(PL_curcop);
+
+ EXTEND(SP, n + 1);
+
+ if (PL_op->op_type == OP_AKEYS) {
+ n += i;
+ for (; i <= n; i++) {
+ mPUSHi(i);
+ }
+ }
+ else {
+ for (i = 0; i <= n; i++) {
+ SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
+ PUSHs(elem ? *elem : &PL_sv_undef);
+ }
+ }
+ }
+ RETURN;
+}
+
/* Associative arrays. */
PP(pp_each)
{
dVAR;
dSP;
- HV * hash = (HV*)POPs;
+ HV * hash = MUTABLE_HV(POPs);
HE *entry;
const I32 gimme = GIMME_V;
RETURN;
}
-PP(pp_delete)
+STATIC OP *
+S_do_delete_local(pTHX)
{
dVAR;
dSP;
const I32 gimme = GIMME_V;
- const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
+ const MAGIC *mg;
+ HV *stash;
if (PL_op->op_private & OPpSLICE) {
dMARK; dORIGMARK;
- HV * const hv = (HV*)POPs;
+ SV * const osv = POPs;
+ const bool tied = SvRMAGICAL(osv)
+ && mg_find((const SV *)osv, PERL_MAGIC_tied);
+ const bool can_preserve = SvCANEXISTDELETE(osv)
+ || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const U32 type = SvTYPE(osv);
+ if (type == SVt_PVHV) { /* hash element */
+ HV * const hv = MUTABLE_HV(osv);
+ while (++MARK <= SP) {
+ SV * const keysv = *MARK;
+ SV *sv = NULL;
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ if (tied) {
+ HE *he = hv_fetch_ent(hv, keysv, 1, 0);
+ if (he)
+ sv = HeVAL(he);
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = hv_delete_ent(hv, keysv, 0, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ *MARK = sv_mortalcopy(sv);
+ mg_clear(sv);
+ } else
+ *MARK = sv;
+ }
+ else {
+ SAVEHDELETE(hv, keysv);
+ *MARK = &PL_sv_undef;
+ }
+ }
+ }
+ else if (type == SVt_PVAV) { /* array element */
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ AV * const av = MUTABLE_AV(osv);
+ while (++MARK <= SP) {
+ I32 idx = SvIV(*MARK);
+ SV *sv = NULL;
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = av_exists(av, idx);
+ if (tied) {
+ SV **svp = av_fetch(av, idx, 1);
+ if (svp)
+ sv = *svp;
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = av_delete(av, idx, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ *MARK = sv_mortalcopy(sv);
+ mg_clear(sv);
+ } else
+ *MARK = sv;
+ }
+ else {
+ SAVEADELETE(av, idx);
+ *MARK = &PL_sv_undef;
+ }
+ }
+ }
+ }
+ else
+ DIE(aTHX_ "Not a HASH reference");
+ if (gimme == G_VOID)
+ SP = ORIGMARK;
+ else if (gimme == G_SCALAR) {
+ MARK = ORIGMARK;
+ if (SP > MARK)
+ *++MARK = *SP;
+ else
+ *++MARK = &PL_sv_undef;
+ SP = MARK;
+ }
+ }
+ else {
+ SV * const keysv = POPs;
+ SV * const osv = POPs;
+ const bool tied = SvRMAGICAL(osv)
+ && mg_find((const SV *)osv, PERL_MAGIC_tied);
+ const bool can_preserve = SvCANEXISTDELETE(osv)
+ || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const U32 type = SvTYPE(osv);
+ SV *sv = NULL;
+ if (type == SVt_PVHV) {
+ HV * const hv = MUTABLE_HV(osv);
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ if (tied) {
+ HE *he = hv_fetch_ent(hv, keysv, 1, 0);
+ if (he)
+ sv = HeVAL(he);
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = hv_delete_ent(hv, keysv, 0, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ SV *nsv = sv_mortalcopy(sv);
+ mg_clear(sv);
+ sv = nsv;
+ }
+ }
+ else
+ SAVEHDELETE(hv, keysv);
+ }
+ else if (type == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ AV * const av = MUTABLE_AV(osv);
+ I32 idx = SvIV(keysv);
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = av_exists(av, idx);
+ if (tied) {
+ SV **svp = av_fetch(av, idx, 1);
+ if (svp)
+ sv = *svp;
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = av_delete(av, idx, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ SV *nsv = sv_mortalcopy(sv);
+ mg_clear(sv);
+ sv = nsv;
+ }
+ }
+ else
+ SAVEADELETE(av, idx);
+ }
+ else
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
+ }
+ else
+ DIE(aTHX_ "Not a HASH reference");
+ if (!sv)
+ sv = &PL_sv_undef;
+ if (gimme != G_VOID)
+ PUSHs(sv);
+ }
+
+ RETURN;
+}
+
+PP(pp_delete)
+{
+ dVAR;
+ dSP;
+ I32 gimme;
+ I32 discard;
+
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ return do_delete_local();
+
+ gimme = GIMME_V;
+ discard = (gimme == G_VOID) ? G_DISCARD : 0;
+
+ if (PL_op->op_private & OPpSLICE) {
+ dMARK; dORIGMARK;
+ HV * const hv = MUTABLE_HV(POPs);
const U32 hvtype = SvTYPE(hv);
if (hvtype == SVt_PVHV) { /* hash element */
while (++MARK <= SP) {
else if (hvtype == SVt_PVAV) { /* array element */
if (PL_op->op_flags & OPf_SPECIAL) {
while (++MARK <= SP) {
- SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
+ SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
*MARK = sv ? sv : &PL_sv_undef;
}
}
}
else {
SV *keysv = POPs;
- HV * const hv = (HV*)POPs;
+ HV * const hv = MUTABLE_HV(POPs);
SV *sv;
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_flags & OPf_SPECIAL)
- sv = av_delete((AV*)hv, SvIV(keysv), discard);
+ sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
else
DIE(aTHX_ "panic: avhv_delete no longer supported");
}
RETPUSHNO;
}
tmpsv = POPs;
- hv = (HV*)POPs;
+ hv = MUTABLE_HV(POPs);
if (SvTYPE(hv) == SVt_PVHV) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
}
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- if (av_exists((AV*)hv, SvIV(tmpsv)))
+ if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
RETPUSHYES;
}
}
PP(pp_hslice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register HV * const hv = (HV*)POPs;
+ register HV * const hv = MUTABLE_HV(POPs);
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
- bool other_magic = FALSE;
+ bool can_preserve = FALSE;
if (localizing) {
MAGIC *mg;
HV *stash;
- other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
- ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
- /* Try to preserve the existenceness of a tied hash
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise */
- && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
- && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
- && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
+ if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ can_preserve = TRUE;
}
while (++MARK <= SP) {
SV * const keysv = *MARK;
SV **svp;
HE *he;
- bool preeminent = FALSE;
-
- if (localizing) {
- preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
- hv_exists_ent(hv, keysv, 0);
+ bool preeminent = TRUE;
+
+ if (localizing && can_preserve) {
+ /* If we can determine whether the element exist,
+ * try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ preeminent = hv_exists_ent(hv, keysv, 0);
}
he = hv_fetch_ent(hv, keysv, lval, 0);
- svp = he ? &HeVAL(he) : 0;
+ svp = he ? &HeVAL(he) : NULL;
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
- DIE(aTHX_ PL_no_helem_sv, keysv);
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
if (localizing) {
if (HvNAME_get(hv) && isGV(*svp))
- save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
- else {
- if (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen),
- SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
- }
- }
+ save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
+ else if (preeminent)
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+ else
+ SAVEHDELETE(hv, keysv);
}
}
*MARK = svp ? *svp : &PL_sv_undef;
register SV **lelem;
if (GIMME != G_ARRAY) {
- I32 ix = SvIVx(*lastlelem);
+ I32 ix = SvIV(*lastlelem);
if (ix < 0)
ix += max;
else
}
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
- I32 ix = SvIVx(*lelem);
+ I32 ix = SvIV(*lelem);
if (ix < 0)
ix += max;
else
{
dVAR; dSP; dMARK; dORIGMARK;
const I32 items = SP - MARK;
- SV * const av = (SV *) av_make(items, MARK+1);
+ SV * const av = MUTABLE_SV(av_make(items, MARK+1));
SP = ORIGMARK; /* av_make() might realloc stack_sp */
- XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
- ? newRV_noinc(av) : av));
+ mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
+ ? newRV_noinc(av) : av);
RETURN;
}
SV * const val = newSV(0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
+ else
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
- XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
- ? newRV_noinc((SV*) hv) : (SV*)hv));
+ mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
+ ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
RETURN;
}
PP(pp_splice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register AV *ary = (AV*)*++MARK;
+ register AV *ary = MUTABLE_AV(*++MARK);
register SV **src;
register SV **dst;
register I32 i;
I32 newlen;
I32 after;
I32 diff;
- const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
+ const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
- *MARK-- = SvTIED_obj((SV*)ary, mg);
+ *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
PUSHMARK(MARK);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_SPLICE");
call_method("SPLICE",GIMME_V);
- LEAVE;
+ LEAVE_with_name("call_SPLICE");
SPAGAIN;
RETURN;
}
SP++;
if (++MARK < SP) {
- offset = i = SvIVx(*MARK);
+ offset = i = SvIV(*MARK);
if (offset < 0)
offset += AvFILLp(ary) + 1;
else
length = AvMAX(ary) + 1;
}
if (offset > AvFILLp(ary) + 1) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
offset = AvFILLp(ary) + 1;
}
after = AvFILLp(ary) + 1 - (offset + length);
PP(pp_push)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV * const ary = (AV*)*++MARK;
- const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
+ register AV * const ary = MUTABLE_AV(*++MARK);
+ const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
- *MARK-- = SvTIED_obj((SV*)ary, mg);
+ *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
PUSHMARK(MARK);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_PUSH");
call_method("PUSH",G_SCALAR|G_DISCARD);
- LEAVE;
+ LEAVE_with_name("call_PUSH");
SPAGAIN;
- SP = ORIGMARK;
- PUSHi( AvFILL(ary) + 1 );
}
else {
+ PL_delaymagic = DM_DELAY;
for (++MARK; MARK <= SP; MARK++) {
SV * const sv = newSV(0);
if (*MARK)
sv_setsv(sv, *MARK);
av_store(ary, AvFILLp(ary)+1, sv);
}
- SP = ORIGMARK;
- PUSHi( AvFILLp(ary) + 1 );
+ if (PL_delaymagic & DM_ARRAY)
+ mg_set(MUTABLE_SV(ary));
+
+ PL_delaymagic = 0;
+ }
+ SP = ORIGMARK;
+ if (OP_GIMME(PL_op, 0) != G_VOID) {
+ PUSHi( AvFILL(ary) + 1 );
}
RETURN;
}
{
dVAR;
dSP;
- AV * const av = (AV*)POPs;
+ AV * const av = MUTABLE_AV(POPs);
SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
assert (sv);
PP(pp_unshift)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = (AV*)*++MARK;
- const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
+ register AV *ary = MUTABLE_AV(*++MARK);
+ const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
- *MARK-- = SvTIED_obj((SV*)ary, mg);
+ *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
PUSHMARK(MARK);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_UNSHIFT");
call_method("UNSHIFT",G_SCALAR|G_DISCARD);
- LEAVE;
+ LEAVE_with_name("call_UNSHIFT");
SPAGAIN;
}
else {
}
}
SP = ORIGMARK;
- PUSHi( AvFILL(ary) + 1 );
+ if (OP_GIMME(PL_op, 0) != G_VOID) {
+ PUSHi( AvFILL(ary) + 1 );
+ }
RETURN;
}
PP(pp_reverse)
{
dVAR; dSP; dMARK;
- SV ** const oldsp = SP;
if (GIMME == G_ARRAY) {
- MARK++;
- while (MARK < SP) {
- register SV * const tmp = *MARK;
- *MARK++ = *SP;
- *SP-- = tmp;
+ if (PL_op->op_private & OPpREVERSE_INPLACE) {
+ AV *av;
+
+ /* See pp_sort() */
+ assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
+ (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
+ av = MUTABLE_AV((*SP));
+ /* In-place reversing only happens in void context for the array
+ * assignment. We don't need to push anything on the stack. */
+ SP = MARK;
+
+ if (SvMAGICAL(av)) {
+ I32 i, j;
+ register SV *tmp = sv_newmortal();
+ /* For SvCANEXISTDELETE */
+ HV *stash;
+ const MAGIC *mg;
+ bool can_preserve = SvCANEXISTDELETE(av);
+
+ for (i = 0, j = av_len(av); i < j; ++i, --j) {
+ register SV *begin, *end;
+
+ if (can_preserve) {
+ if (!av_exists(av, i)) {
+ if (av_exists(av, j)) {
+ register SV *sv = av_delete(av, j, 0);
+ begin = *av_fetch(av, i, TRUE);
+ sv_setsv_mg(begin, sv);
+ }
+ continue;
+ }
+ else if (!av_exists(av, j)) {
+ register SV *sv = av_delete(av, i, 0);
+ end = *av_fetch(av, j, TRUE);
+ sv_setsv_mg(end, sv);
+ continue;
+ }
+ }
+
+ begin = *av_fetch(av, i, TRUE);
+ end = *av_fetch(av, j, TRUE);
+ sv_setsv(tmp, begin);
+ sv_setsv_mg(begin, end);
+ sv_setsv_mg(end, tmp);
+ }
+ }
+ else {
+ SV **begin = AvARRAY(av);
+ SV **end = begin + AvFILLp(av);
+
+ while (begin < end) {
+ register SV * const tmp = *begin;
+ *begin++ = *end;
+ *end-- = tmp;
+ }
+ }
+ }
+ else {
+ SV **oldsp = SP;
+ MARK++;
+ while (MARK < SP) {
+ register SV * const tmp = *MARK;
+ *MARK++ = *SP;
+ *SP-- = tmp;
+ }
+ /* safe as long as stack cannot get extended in the above */
+ SP = oldsp;
}
- /* safe as long as stack cannot get extended in the above */
- SP = oldsp;
}
else {
register char *up;
SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
- else
+ else {
sv_setsv(TARG, (SP > MARK)
? *SP
: (padoff_du = find_rundefsvoffset(),
(padoff_du == NOT_IN_PAD
|| PAD_COMPNAME_FLAGS_isOUR(padoff_du))
? DEFSV : PAD_SVl(padoff_du)));
+
+ if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(TARG);
+ }
+
up = SvPV_force(TARG, len);
if (len > 1) {
if (DO_UTF8(TARG)) { /* first reverse each character */
I32 iters = 0;
const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
I32 maxiters = slen + 10;
+ I32 trailing_empty = 0;
const char *orig;
const I32 origlimit = limit;
I32 realarray = 0;
I32 base;
const I32 gimme = GIMME_V;
+ bool gimme_scalar;
const I32 oldsave = PL_savestack_ix;
- I32 make_mortal = 1;
+ U32 make_mortal = SVs_TEMP;
bool multiline = 0;
MAGIC *mg = NULL;
DIE(aTHX_ "panic: pp_split");
rx = PM_GETRE(pm);
- TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
- (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
+ TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
+ (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
RX_MATCH_UTF8_set(rx, do_utf8);
- if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
+ if (pm->op_pmreplrootu.op_pmtargetoff) {
+ ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
+ }
#else
- ary = GvAVn((GV*)pm->op_pmreplroot);
-#endif
+ if (pm->op_pmreplrootu.op_pmtargetgv) {
+ ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
}
- else if (gimme != G_ARRAY)
- ary = GvAVn(PL_defgv);
+#endif
else
ary = NULL;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
- if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
+ if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)ary, mg));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
}
else {
if (!AvREAL(ary)) {
}
base = SP - PL_stack_base;
orig = s;
- if (pm->op_pmflags & PMf_SKIPWHITE) {
- if (pm->op_pmflags & PMf_LOCALE) {
+ if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
+ if (do_utf8) {
+ while (*s == ' ' || is_utf8_space((U8*)s))
+ s += UTF8SKIP(s);
+ }
+ else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
while (isSPACE_LC(*s))
s++;
}
s++;
}
}
- if (pm->op_pmflags & PMf_MULTILINE) {
+ if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
multiline = 1;
}
+ gimme_scalar = gimme == G_SCALAR && !ary;
+
if (!limit)
limit = maxiters + 2;
- if (pm->op_pmflags & PMf_WHITE) {
+ if (RX_EXTFLAGS(rx) & RXf_WHITE) {
while (--limit) {
m = s;
- while (m < strend &&
- !((pm->op_pmflags & PMf_LOCALE)
- ? isSPACE_LC(*m) : isSPACE(*m)))
- ++m;
+ /* this one uses 'm' and is a negative test */
+ if (do_utf8) {
+ while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
+ const int t = UTF8SKIP(m);
+ /* is_utf8_space returns FALSE for malform utf8 */
+ if (strend - m < t)
+ m = strend;
+ else
+ m += t;
+ }
+ } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
+ while (m < strend && !isSPACE_LC(*m))
+ ++m;
+ } else {
+ while (m < strend && !isSPACE(*m))
+ ++m;
+ }
if (m >= strend)
break;
- dstr = newSVpvn(s, m-s);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
- s = m + 1;
- while (s < strend &&
- ((pm->op_pmflags & PMf_LOCALE)
- ? isSPACE_LC(*s) : isSPACE(*s)))
- ++s;
+ /* skip the whitespace found last */
+ if (do_utf8)
+ s = m + UTF8SKIP(m);
+ else
+ s = m + 1;
+
+ /* this one uses 's' and is a positive test */
+ if (do_utf8) {
+ while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
+ s += UTF8SKIP(s);
+ } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
+ while (s < strend && isSPACE_LC(*s))
+ ++s;
+ } else {
+ while (s < strend && isSPACE(*s))
+ ++s;
+ }
}
}
- else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
+ else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
while (--limit) {
for (m = s; m < strend && *m != '\n'; m++)
;
m++;
if (m >= strend)
break;
- dstr = newSVpvn(s, m-s);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
s = m;
}
}
- else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
- (rx->reganch & RE_USE_INTUIT) && !rx->nparens
- && (rx->reganch & ROPT_CHECK_ALL)
- && !(rx->reganch & ROPT_ANCH)) {
- const int tail = (rx->reganch & RE_INTUIT_TAIL);
+ else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
+ /*
+ Pre-extend the stack, either the number of bytes or
+ characters in the string or a limited amount, triggered by:
+
+ my ($x, $y) = split //, $str;
+ or
+ split //, $str, $i;
+ */
+ if (!gimme_scalar) {
+ const U32 items = limit - 1;
+ if (items < slen)
+ EXTEND(SP, items);
+ else
+ EXTEND(SP, slen);
+ }
+
+ if (do_utf8) {
+ while (--limit) {
+ /* keep track of how many bytes we skip over */
+ m = s;
+ s += UTF8SKIP(s);
+ if (gimme_scalar) {
+ iters++;
+ if (s-m == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
+
+ PUSHs(dstr);
+ }
+
+ if (s >= strend)
+ break;
+ }
+ } else {
+ while (--limit) {
+ if (gimme_scalar) {
+ iters++;
+ } else {
+ dstr = newSVpvn(s, 1);
+
+
+ if (make_mortal)
+ sv_2mortal(dstr);
+
+ PUSHs(dstr);
+ }
+
+ s++;
+
+ if (s >= strend)
+ break;
+ }
+ }
+ }
+ else if (do_utf8 == (RX_UTF8(rx) != 0) &&
+ (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
+ && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
+ && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
+ const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
SV * const csv = CALLREG_INTUIT_STRING(rx);
- len = rx->minlen;
- if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
+ len = RX_MINLENRET(rx);
+ if (len == 1 && !RX_UTF8(rx) && !tail) {
const char c = *SvPV_nolen_const(csv);
while (--limit) {
for (m = s; m < strend && *m != c; m++)
;
if (m >= strend)
break;
- dstr = newSVpvn(s, m-s);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
(m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
csv, multiline ? FBMrf_MULTILINE : 0)) )
{
- dstr = newSVpvn(s, m-s);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
}
}
else {
- maxiters += slen * rx->nparens;
+ maxiters += slen * RX_NPARENS(rx);
while (s < strend && --limit)
{
I32 rex_return;
if (rex_return == 0)
break;
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
+ if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
- orig = rx->subbeg;
+ orig = RX_SUBBEG(rx);
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->startp[0] + orig;
- dstr = newSVpvn(s, m-s);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
- if (rx->nparens) {
+ m = RX_OFFS(rx)[0].start + orig;
+
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
+ if (RX_NPARENS(rx)) {
I32 i;
- for (i = 1; i <= (I32)rx->nparens; i++) {
- s = rx->startp[i] + orig;
- m = rx->endp[i] + orig;
+ for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
+ s = RX_OFFS(rx)[i].start + orig;
+ m = RX_OFFS(rx)[i].end + orig;
/* japhy (07/27/01) -- the (m && s) test doesn't catch
parens that didn't match -- they should be set to
undef, not the empty string */
- if (m >= orig && s >= orig) {
- dstr = newSVpvn(s, m-s);
+ if (gimme_scalar) {
+ iters++;
+ if (m-s == 0)
+ trailing_empty++;
+ else
+ trailing_empty = 0;
+ } else {
+ if (m >= orig && s >= orig) {
+ dstr = newSVpvn_flags(s, m-s,
+ (do_utf8 ? SVf_UTF8 : 0)
+ | make_mortal);
+ }
+ else
+ dstr = &PL_sv_undef; /* undef, not "" */
+ XPUSHs(dstr);
}
- else
- dstr = &PL_sv_undef; /* undef, not "" */
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+
}
}
- s = rx->endp[0] + orig;
+ s = RX_OFFS(rx)[0].end + orig;
}
}
- iters = (SP - PL_stack_base) - base;
+ if (!gimme_scalar) {
+ iters = (SP - PL_stack_base) - base;
+ }
if (iters > maxiters)
DIE(aTHX_ "Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
- const STRLEN l = strend - s;
- dstr = newSVpvn(s, l);
- if (make_mortal)
- sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
- XPUSHs(dstr);
+ if (!gimme_scalar) {
+ const STRLEN l = strend - s;
+ dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ XPUSHs(dstr);
+ }
iters++;
}
else if (!origlimit) {
- while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
- if (TOPs && !make_mortal)
- sv_2mortal(TOPs);
- iters--;
- *SP-- = &PL_sv_undef;
+ if (gimme_scalar) {
+ iters -= trailing_empty;
+ } else {
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
+ if (TOPs && !make_mortal)
+ sv_2mortal(TOPs);
+ *SP-- = &PL_sv_undef;
+ iters--;
+ }
}
}
if (!mg) {
if (SvSMAGICAL(ary)) {
PUTBACK;
- mg_set((SV*)ary);
+ mg_set(MUTABLE_SV(ary));
SPAGAIN;
}
if (gimme == G_ARRAY) {
}
else {
PUTBACK;
- ENTER;
+ ENTER_with_name("call_PUSH");
call_method("PUSH",G_SCALAR|G_DISCARD);
- LEAVE;
+ LEAVE_with_name("call_PUSH");
SPAGAIN;
if (gimme == G_ARRAY) {
I32 i;
RETURN;
}
+PP(pp_once)
+{
+ dSP;
+ SV *const sv = PAD_SVl(PL_op->op_targ);
+
+ if (SvPADSTALE(sv)) {
+ /* First time. */
+ SvPADSTALE_off(sv);
+ RETURNOP(cLOGOP->op_other);
+ }
+ RETURNOP(cLOGOP->op_next);
+}
+
PP(pp_lock)
{
dVAR;
dSP;
dTOPss;
SV *retsv = sv;
+ assert(SvTYPE(retsv) != SVt_PVCV);
SvLOCK(sv);
- if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
- || SvTYPE(retsv) == SVt_PVCV) {
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
retsv = refto(retsv);
}
SETs(retsv);
dVAR;
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
PL_op->op_type);
+ return NORMAL;
+}
+
+PP(pp_boolkeys)
+{
+ dVAR;
+ dSP;
+ HV * const hv = (HV*)POPs;
+
+ if (SvRMAGICAL(hv)) {
+ MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
+ if (mg) {
+ XPUSHs(magic_scalarpack(hv, mg));
+ RETURN;
+ }
+ }
+
+ XPUSHs(boolSV(HvKEYS(hv) != 0));
+ RETURN;
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff