_LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
#endif
+static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
+static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
+
/* variations on pp_null */
PP(pp_stub)
{
- dVAR;
dSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
/* Pushy stuff. */
+/* This is also called directly by pp_lvavref. */
PP(pp_padav)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVAV);
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
gimme = GIMME_V;
if (gimme == G_ARRAY) {
/* XXX see also S_pushav in pp_hot.c */
- const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
+ Size_t i;
+ for (i=0; i < maxarg; i++) {
SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
else {
- Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
+ PADOFFSET i;
+ for (i=0; i < (PADOFFSET)maxarg; i++) {
+ SV * const sv = AvARRAY((const AV *)TARG)[i];
+ SP[i+1] = sv ? sv : &PL_sv_undef;
+ }
}
SP += maxarg;
}
else if (gimme == G_SCALAR) {
SV* const sv = sv_newmortal();
- const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
sv_setiv(sv, maxarg);
PUSHs(sv);
}
PP(pp_padhv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVHV);
XPUSHs(TARG);
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
PP(pp_padcv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
assert(SvTYPE(TARG) == SVt_PVCV);
XPUSHs(TARG);
RETURN;
PP(pp_introcv)
{
- dVAR; dTARGET;
+ dTARGET;
SvPADSTALE_off(TARG);
return NORMAL;
}
PP(pp_clonecv)
{
- dVAR; dTARGET;
+ dTARGET;
MAGIC * const mg =
mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
PERL_MAGIC_proto);
S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
const bool noinit)
{
- dVAR;
if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SvREFCNT_inc_void_NN(sv);
sv = MUTABLE_SV(gv);
}
- else if (!isGV_with_GP(sv))
- return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
+ else if (!isGV_with_GP(sv)) {
+ Perl_die(aTHX_ "Not a GLOB reference");
+ }
}
else {
if (!isGV_with_GP(sv)) {
Perl_croak_no_modify();
if (cUNOP->op_targ) {
SV * const namesv = PAD_SV(cUNOP->op_targ);
+ HV *stash = CopSTASH(PL_curcop);
+ if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
gv = MUTABLE_GV(newSV(0));
- gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
+ gv_init_sv(gv, stash, namesv, 0);
}
else {
const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen_flags(name,
- HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
+ HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
+ SvREFCNT_inc_simple_void_NN(gv);
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
SvSETMAGIC(sv);
goto wasref;
}
- if (PL_op->op_flags & OPf_REF || strict)
- return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
+ if (PL_op->op_flags & OPf_REF || strict) {
+ Perl_die(aTHX_ PL_no_usym, "a symbol");
+ }
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
return &PL_sv_undef;
return &PL_sv_undef;
}
else {
- if (strict)
- return
- (SV *)Perl_die(aTHX_
- S_no_symref_sv,
- sv,
- (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
- "a symbol"
- );
+ if (strict) {
+ Perl_die(aTHX_
+ S_no_symref_sv,
+ sv,
+ (SvPOKp(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
PP(pp_rv2gv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
sv = S_rv2gv(aTHX_
sv, PL_op->op_private & OPpDEREF,
Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
const svtype type, SV ***spp)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_SOFTREF2XV;
PP(pp_rv2sv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
GV *gv = NULL;
SvGETMAGIC(sv);
PP(pp_av2arylen)
{
- dVAR; dSP;
+ dSP;
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)))));
}
PP(pp_pos)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
LvTYPE(ret) = '.';
LvTARG(ret) = SvREFCNT_inc_simple(sv);
RETURN;
}
else {
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
- if (mg && mg->mg_len >= 0) {
+ const MAGIC * const mg = mg_find_mglob(sv);
+ if (mg && mg->mg_len != -1) {
dTARGET;
- I32 i = mg->mg_len;
- if (DO_UTF8(sv))
- sv_pos_b2u(sv, &i);
- PUSHi(i);
+ STRLEN i = mg->mg_len;
+ if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
+ i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
+ PUSHu(i);
RETURN;
}
- }
- RETPUSHUNDEF;
+ RETPUSHUNDEF;
}
}
PP(pp_rv2cv)
{
- dVAR; dSP;
+ dSP;
GV *gv;
HV *stash_unused;
const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
? GV_ADDMG
- : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
+ : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
+ == OPpMAY_RETURN_CONSTANT)
? GV_ADD|GV_NOEXPAND
: GV_ADD;
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
- cv = MUTABLE_CV(gv);
+ cv = SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : MUTABLE_CV(gv);
}
else
cv = MUTABLE_CV(&PL_sv_undef);
PP(pp_prototype)
{
- dVAR; dSP;
+ dSP;
CV *cv;
HV *stash;
GV *gv;
const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
- if (!code || code == -KEY_CORE)
- DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
- SVfARG(newSVpvn_flags(
- s+6, SvCUR(TOPs)-6,
- (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
- )));
+ if (!code)
+ DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
+ UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
{
SV * const sv = core_prototype(NULL, s + 6, code, NULL);
if (sv) ret = sv;
PP(pp_anoncode)
{
- dVAR; dSP;
+ dSP;
CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
PP(pp_srefgen)
{
- dVAR; dSP;
+ dSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
STATIC SV*
S_refto(pTHX_ SV *sv)
{
- dVAR;
SV* rv;
PERL_ARGS_ASSERT_REFTO;
SvTEMP_off(sv);
SvREFCNT_inc_void_NN(sv);
}
- else if (SvPADTMP(sv) && !IS_PADGV(sv))
+ else if (SvPADTMP(sv)) {
sv = newSVsv(sv);
+ }
else {
SvTEMP_off(sv);
SvREFCNT_inc_void_NN(sv);
PP(pp_ref)
{
- dVAR; dSP; dTARGET;
- SV * const sv = POPs;
-
- if (sv)
- SvGETMAGIC(sv);
+ dSP;
+ SV * const sv = TOPs;
- if (!sv || !SvROK(sv))
- RETPUSHNO;
+ SvGETMAGIC(sv);
+ if (!SvROK(sv))
+ SETs(&PL_sv_no);
+ else {
+ dTARGET;
+ SETs(TARG);
+ /* use the return value that is in a register, its the same as TARG */
+ TARG = sv_ref(TARG,SvRV(sv),TRUE);
+ SvSETMAGIC(TARG);
+ }
- (void)sv_ref(TARG,SvRV(sv),TRUE);
- PUSHTARG;
- RETURN;
+ return NORMAL;
}
PP(pp_bless)
{
- dVAR; dSP;
+ dSP;
HV *stash;
if (MAXARG == 1)
+ {
curstash:
stash = CopSTASH(PL_curcop);
+ if (SvTYPE(stash) != SVt_PVHV)
+ Perl_croak(aTHX_ "Attempt to bless into a freed package");
+ }
else {
SV * const ssv = POPs;
STRLEN len;
const char *ptr;
if (!ssv) goto curstash;
- if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+ SvGETMAGIC(ssv);
+ if (SvROK(ssv)) {
+ if (!SvAMAGIC(ssv)) {
+ frog:
Perl_croak(aTHX_ "Attempt to bless into a reference");
- ptr = SvPV_const(ssv,len);
+ }
+ /* SvAMAGIC is on here, but it only means potentially overloaded,
+ so after stringification: */
+ ptr = SvPV_nomg_const(ssv,len);
+ /* We need to check the flag again: */
+ if (!SvAMAGIC(ssv)) goto frog;
+ }
+ else ptr = SvPV_nomg_const(ssv,len);
if (len == 0)
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
PP(pp_gelem)
{
- dVAR; dSP;
+ dSP;
SV *sv = POPs;
STRLEN len;
PP(pp_study)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
STRLEN len;
(void)SvPV(sv, len);
RETPUSHYES;
}
+
+/* also used for: pp_transr() */
+
PP(pp_trans)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
SV *sv;
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)
{
- dVAR;
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;
}
+
+/* also used for: pp_schomp() */
+
PP(pp_schop)
{
- dVAR; dSP; dTARGET;
+ 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;
}
+
+/* also used for: pp_chomp() */
+
PP(pp_chop)
{
- dVAR; dSP; dMARK; dTARGET; dORIGMARK;
+ 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;
PP(pp_undef)
{
- dVAR; dSP;
+ dSP;
SV *sv;
if (!PL_op->op_private) {
if (!sv)
RETPUSHUNDEF;
- SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
switch (SvTYPE(sv)) {
case SVt_NULL:
"Constant subroutine %"SVf" undefined",
SVfARG(CvANON((const CV *)sv)
? newSVpvs_flags("(anonymous)", SVs_TEMP)
- : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
+ : sv_2mortal(newSVhek(
+ CvNAMED(sv)
+ ? CvNAME_HEK((CV *)sv)
+ : GvENAME_HEK(CvGV((const CV *)sv))
+ ))
+ ));
/* FALLTHROUGH */
case SVt_PVFM:
- {
/* let user-undef'd sub keep its identity */
- GV* const gv = CvGV((const CV *)sv);
- HEK * const hek = CvNAME_HEK((CV *)sv);
- if (hek) share_hek_hek(hek);
- cv_undef(MUTABLE_CV(sv));
- if (gv) CvGV_set(MUTABLE_CV(sv), gv);
- else if (hek) {
- SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
- CvNAMED_on(sv);
- }
- }
+ cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
break;
case SVt_PVGV:
assert(isGV_with_GP(sv));
else stash = NULL;
}
+ SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
gp_free(MUTABLE_GV(sv));
Newxz(gp, 1, GP);
GvGP_set(sv, gp_ref(gp));
+#ifndef PERL_DONT_CREATE_GVSV
GvSV(sv) = newSV(0);
+#endif
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = MUTABLE_GV(sv);
GvMULTI_on(sv);
RETPUSHUNDEF;
}
+
+/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
+
PP(pp_postinc)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const bool inc =
PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
/* 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;
}
PP(pp_pow)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
PP(pp_multiply)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_divide)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_modulo)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
{
UV left = 0;
PP(pp_repeat)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
IV count;
SV *sv;
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;
}
else
count = uv;
} else {
- const IV iv = SvIV_nomg(sv);
- if (iv < 0)
- count = 0;
- else
- count = iv;
+ count = SvIV_nomg(sv);
}
}
else if (SvNOKp(sv)) {
const NV nv = SvNV_nomg(sv);
if (nv < 0.0)
- count = 0;
+ count = -1; /* An arbitrary negative integer */
else
count = (IV)nv;
}
else
count = SvIV_nomg(sv);
+ if (count < 0) {
+ count = 0;
+ Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Negative repeat count does nothing");
+ }
+
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
static const char* const oom_list_extend = "Out of memory during list extend";
const I32 items = SP - MARK;
const I32 max = items * count;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
/* Did the max computation overflow? */
if (items > 0 && max > 0 && (max < items || max < count))
- Perl_croak(aTHX_ oom_list_extend);
+ Perl_croak(aTHX_ "%s", oom_list_extend);
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 (*SP) {
+ if (mod && SvPADTMP(*SP)) {
+ *SP = sv_mortalcopy(*SP);
+ }
SvTEMP_off((*SP));
-#endif
+ }
SP--;
}
MARK++;
else {
const STRLEN max = (UV)count * len;
if (len > MEM_SIZE_MAX / count)
- Perl_croak(aTHX_ oom_string_extend);
+ Perl_croak(aTHX_ "%s", oom_string_extend);
MEM_WRAP_CHECK_1(max, char, oom_string_extend);
SvGROW(TARG, max + 1);
repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
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;
PP(pp_subtract)
{
- dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ dSP; dATARGET; bool useleft; SV *svl, *svr;
tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_left_shift)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
PP(pp_right_shift)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
PP(pp_lt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
PP(pp_gt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
PP(pp_le)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
PP(pp_ge)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
PP(pp_ne)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
I32
Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
/* Fortunately it seems NaN isn't IOK */
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
#endif
{
PP(pp_ncmp)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
I32 value;
tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
RETURN;
}
+
+/* also used for: pp_sge() pp_sgt() pp_slt() */
+
PP(pp_sle)
{
- dVAR; dSP;
+ dSP;
int amg_type = sle_amg;
int multiplier = 1;
tryAMAGICbin_MG(amg_type, AMGf_set);
{
dPOPTOPssrl;
- const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale_flags(left, right, 0)
- : sv_cmp_flags(left, right, 0));
+ const int cmp =
+#ifdef USE_LOCALE_COLLATE
+ (IN_LC_RUNTIME(LC_COLLATE))
+ ? sv_cmp_locale_flags(left, right, 0)
+ :
+#endif
+ sv_cmp_flags(left, right, 0);
SETs(boolSV(cmp * multiplier < rhs));
RETURN;
}
PP(pp_seq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(seq_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_sne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(sne_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_scmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
- const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale_flags(left, right, 0)
- : sv_cmp_flags(left, right, 0));
+ const int cmp =
+#ifdef USE_LOCALE_COLLATE
+ (IN_LC_RUNTIME(LC_COLLATE))
+ ? sv_cmp_locale_flags(left, right, 0)
+ :
+#endif
+ sv_cmp_flags(left, right, 0);
SETi( cmp );
RETURN;
}
PP(pp_bit_and)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(band_amg, AMGf_assign);
{
dPOPTOPssrl;
}
}
+
+/* also used for: pp_bit_xor() */
+
PP(pp_bit_or)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
const int op_type = PL_op->op_type;
tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
PP(pp_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, AMGf_numeric);
if (S_negate_string(aTHX)) return NORMAL;
{
if (SvIsUV(sv)) {
if (SvIVX(sv) == IV_MIN) {
/* 2s complement assumption. */
- SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
+ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
+ IV_MIN */
RETURN;
}
else if (SvUVX(sv) <= IV_MAX) {
PP(pp_not)
{
- dVAR; dSP;
+ dSP;
tryAMAGICun_MG(not_amg, AMGf_set);
*PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
return NORMAL;
PP(pp_complement)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(compl_amg, AMGf_numeric);
{
dTOPss;
I32 anum;
STRLEN len;
- (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
- sv_setsv_nomg(TARG, sv);
- tmps = (U8*)SvPV_force_nomg(TARG, len);
+ sv_copypv_nomg(TARG, sv);
+ tmps = (U8*)SvPV_nomg(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
/* Calculate exact length, let's not estimate. */
PP(pp_i_multiply)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(mult_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
PP(pp_i_divide)
{
IV num;
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(div_amg, AMGf_assign);
{
dPOPTOPssrl;
#endif
{
/* This is the vanilla old i_modulo. */
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
/* 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; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
PP(pp_i_add)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(add_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_subtract)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(subtr_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_lt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(lt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_gt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(gt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_le)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(le_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ge)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ge_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_eq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(eq_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ne_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ncmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(ncmp_amg, 0);
{
dPOPTOPiirl_nomg;
PP(pp_i_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, 0);
if (S_negate_string(aTHX)) return NORMAL;
{
PP(pp_atan2)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(atan2_amg, 0);
{
dPOPTOPnnrl_nomg;
}
}
+
+/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
+
PP(pp_sin)
{
- dVAR; dSP; dTARGET;
- int amg_type = sin_amg;
+ dSP; dTARGET;
+ int amg_type = fallback_amg;
const char *neg_report = NULL;
- NV (*func)(NV) = Perl_sin;
const int op_type = PL_op->op_type;
switch (op_type) {
- case OP_COS:
- amg_type = cos_amg;
- func = Perl_cos;
- break;
- case OP_EXP:
- amg_type = exp_amg;
- func = Perl_exp;
- break;
- case OP_LOG:
- amg_type = log_amg;
- func = Perl_log;
- neg_report = "log";
- break;
- case OP_SQRT:
- amg_type = sqrt_amg;
- func = Perl_sqrt;
- neg_report = "sqrt";
- break;
+ case OP_SIN: amg_type = sin_amg; break;
+ case OP_COS: amg_type = cos_amg; break;
+ case OP_EXP: amg_type = exp_amg; break;
+ case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
+ case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
}
+ assert(amg_type != fallback_amg);
tryAMAGICun_MG(amg_type, 0);
{
SV * const arg = POPs;
const NV value = SvNV_nomg(arg);
- if (neg_report) {
- if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
+ NV result = NV_NAN;
+ if (neg_report) { /* log or sqrt */
+ if (
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ ! Perl_isnan(value) &&
+#endif
+ (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
SET_NUMERIC_STANDARD();
/* diag_listed_as: Can't take log of %g */
DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
}
}
- XPUSHn(func(value));
+ switch (op_type) {
+ default:
+ case OP_SIN: result = Perl_sin(value); break;
+ case OP_COS: result = Perl_cos(value); break;
+ case OP_EXP: result = Perl_exp(value); break;
+ case OP_LOG: result = Perl_log(value); break;
+ case OP_SQRT: result = Perl_sqrt(value); break;
+ }
+ XPUSHn(result);
RETURN;
}
}
--Jarkko Hietaniemi 27 September 1998
*/
-#ifndef HAS_DRAND48_PROTO
-extern double drand48 (void);
-#endif
-
PP(pp_rand)
{
- dVAR;
if (!PL_srand_called) {
(void)seedDrand01((Rand_seed_t)seed());
PL_srand_called = TRUE;
value = SvNV(sv);
}
/* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (! Perl_isnan(value) && value == 0.0)
+#else
if (value == 0.0)
+#endif
value = 1.0;
{
dTARGET;
PP(pp_srand)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
UV anum;
if (MAXARG >= 1 && (TOPs || POPs)) {
PP(pp_int)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(int_amg, AMGf_numeric);
{
SV * const sv = TOPs;
}
else {
const NV value = SvNV_nomg(sv);
- if (value >= 0.0) {
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
+ SETn(SvNV(sv));
+ else if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
PP(pp_abs)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(abs_amg, AMGf_numeric);
{
SV * const sv = TOPs;
RETURN;
}
+
+/* also used for: pp_hex() */
+
PP(pp_oct)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x' || *tmps == 'X') {
+ if (isALPHA_FOLD_EQ(*tmps, 'x')) {
hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
}
- else if (*tmps == 'b' || *tmps == 'B')
+ else if (isALPHA_FOLD_EQ(*tmps, 'b'))
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
result_uv = grok_oct (tmps, &len, &flags, &result_nv);
PP(pp_length)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
- SvGETMAGIC(sv);
+ U32 in_bytes = IN_BYTES;
+ /* 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);
+ STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+ SETs(TARG);
+
+ if(LIKELY(svflags == SVf_POK))
+ goto simple_pv;
+ if(svflags & SVs_GMG)
+ mg_get(sv);
if (SvOK(sv)) {
- if (!IN_BYTES)
- SETi(sv_len_utf8_nomg(sv));
+ if (!IN_BYTES) /* reread to avoid using an C auto/register */
+ sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
else
{
STRLEN len;
- (void)SvPV_nomg_const(sv,len);
- SETi(len);
+ /* unrolled SvPV_nomg_const(sv,len) */
+ if(SvPOK_nog(sv)){
+ simple_pv:
+ len = SvCUR(sv);
+ } else {
+ (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
+ }
+ sv_setiv(TARG, (IV)(len));
}
} else {
if (!SvPADTMP(TARG)) {
sv_setsv_nomg(TARG, &PL_sv_undef);
- SETTARG;
- }
- SETs(&PL_sv_undef);
+ } else { /* TARG is on stack at this point and is overwriten by SETs.
+ This branch is the odd one out, so put TARG by default on
+ stack earlier to let local SP go out of liveness sooner */
+ SETs(&PL_sv_undef);
+ goto no_set_magic;
+ }
}
- RETURN;
+ SvSETMAGIC(TARG);
+ no_set_magic:
+ return NORMAL; /* no putback, SP didn't move in this opcode */
}
/* Returns false if substring is completely outside original string.
always be true for an explicit 0.
*/
bool
-Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
- bool pos1_is_uv, IV len_iv,
- bool len_is_uv, STRLEN *posp,
- STRLEN *lenp)
+Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
+ bool pos1_is_uv, IV len_iv,
+ bool len_is_uv, STRLEN *posp,
+ STRLEN *lenp)
{
IV pos2_iv;
int pos2_is_uv;
PP(pp_substr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *sv;
STRLEN curlen;
STRLEN utf8_curlen;
}
}
SPAGAIN;
- if (rvalue) {
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
+ SP++;
+ else if (rvalue) {
SvSETMAGIC(TARG);
PUSHs(TARG);
}
PP(pp_vec)
{
- dVAR; dSP;
+ dSP;
const IV size = POPi;
const IV offset = POPi;
SV * const src = POPs;
}
sv_setuv(ret, do_vecget(src, offset, size));
+ if (!lvalue)
+ SvSETMAGIC(ret);
PUSHs(ret);
RETURN;
}
+
+/* also used for: pp_rindex() */
+
PP(pp_index)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *big;
SV *little;
SV *temp = NULL;
STRLEN biglen;
STRLEN llen = 0;
- I32 offset;
- I32 retval;
+ SSize_t offset = 0;
+ SSize_t retval;
const char *big_p;
const char *little_p;
bool big_utf8;
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);
}
offset = is_index ? 0 : biglen;
else {
if (big_utf8 && offset > 0)
- sv_pos_u2b(big, &offset, 0);
+ offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
if (!is_index)
offset += llen;
}
if (offset < 0)
offset = 0;
- else if (offset > (I32)biglen)
+ else if (offset > (SSize_t)biglen)
offset = biglen;
if (!(little_p = is_index
? fbm_instr((unsigned char*)big_p + offset,
else {
retval = little_p - big_p;
if (retval > 0 && big_utf8)
- sv_pos_b2u(big, &retval);
+ retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
}
SvREFCNT_dec(temp);
fail:
PP(pp_sprintf)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SvTAINTED_off(TARG);
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
PP(pp_ord)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *argsv = POPs;
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;
}
- XPUSHu(DO_UTF8(argsv) ?
- utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
- (UV)(*s & 0xff));
+ XPUSHu(DO_UTF8(argsv)
+ ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
+ : (UV)(*s));
RETURN;
}
PP(pp_chr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char *tmps;
UV value;
SV *top = POPs;
SvGETMAGIC(top);
- if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
- && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
- ||
- ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
- && SvNV_nomg(top) < 0.0))) {
+ if (UNLIKELY(isinfnansv(top)))
+ Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
+ else {
+ if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
+ && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
+ ||
+ ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
+ && SvNV_nomg(top) < 0.0))) {
if (ckWARN(WARN_UTF8)) {
if (SvGMAGICAL(top)) {
SV *top2 = sv_newmortal();
sv_setsv_nomg(top2, top);
top = top2;
}
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Invalid negative number (%"SVf") in chr", top);
- }
- value = UNICODE_REPLACEMENT;
- } else {
- value = SvUV_nomg(top);
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid negative number (%"SVf") in chr", SVfARG(top));
+ }
+ value = UNICODE_REPLACEMENT;
+ } else {
+ value = SvUV_nomg(top);
+ }
}
SvUPGRADE(TARG,SVt_PV);
*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;
}
PP(pp_crypt)
{
#ifdef HAS_CRYPT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
dPOPTOPssrl;
STRLEN len;
const char *tmps = SvPV_const(left, len);
/* 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
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
-/* Generates code to store a unicode codepoint c that is known to occupy
- * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
- * and p is advanced to point to the next available byte after the two bytes */
-#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
- STMT_START { \
- *(p)++ = UTF8_TWO_BYTE_HI(c); \
- *((p)++) = UTF8_TWO_BYTE_LO(c); \
- } STMT_END
+
+/* also used for: pp_lcfirst() */
PP(pp_ucfirst)
{
* take the source and change that one character and store it back, but not
* if read-only etc, or if the length changes */
- dVAR;
dSP;
SV *source = TOPs;
STRLEN slen; /* slen is the byte length of the whole SV. */
STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
* lowercased) character stored in tmpbuf. May be either
* UTF-8 or not, but in either case is the number of bytes */
- bool tainted = FALSE;
- SvGETMAGIC(source);
- if (SvOK(source)) {
- s = (const U8*)SvPV_nomg_const(source, slen);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- slen = 0;
- }
+ s = (const U8*)SvPV_const(source, slen);
/* We may be able to get away with changing only the first character, in
* place, but not if read-only, etc. Later we may discover more reasons to
* not convert in-place. */
- inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
+ inplace = !SvREADONLY(source)
+ && ( SvPADTMP(source)
+ || ( SvTEMP(source) && !SvSMAGICAL(source)
+ && SvREFCNT(source) == 1));
/* First calculate what the changed first character should be. This affects
* whether we can just swap it out, leaving the rest of the string unchanged,
doing_utf8 = TRUE;
ulen = UTF8SKIP(s);
if (op_type == OP_UCFIRST) {
- _to_utf8_title_flags(s, tmpbuf, &tculen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
+#endif
}
else {
- _to_utf8_lower_flags(s, tmpbuf, &tculen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
+#endif
}
/* we can't do in-place if the length changes. */
if (op_type == OP_LCFIRST) {
/* lower case the first letter: no trickiness for any character */
- *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
- ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
+ *tmpbuf =
+#ifdef USE_LOCALE_CTYPE
+ (IN_LC_RUNTIME(LC_CTYPE))
+ ? toLOWER_LC(*s)
+ :
+#endif
+ (IN_UNI_8_BIT)
+ ? toLOWER_LATIN1(*s)
+ : toLOWER(*s);
}
/* is ucfirst() */
- else if (IN_LOCALE_RUNTIME) {
- *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
- * have upper and title case different
- */
+#ifdef USE_LOCALE_CTYPE
+ else if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_rules;
+ }
+
+ *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
+ locales have upper and title case
+ different */
}
+#endif
else if (! IN_UNI_8_BIT) {
*tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
* on EBCDIC machines whatever the
* native function does */
}
- else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
- UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
+ else {
+ /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
+ * UTF-8, which we treat as not in locale), and cased latin1 */
+ UV title_ord;
+#ifdef USE_LOCALE_CTYPE
+ do_uni_rules:
+#endif
+
+ title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
if (tculen > 1) {
assert(tculen == 2);
* replace just the first character in place. */
inplace = FALSE;
- /* If the result won't fit in a byte, the entire result will
- * have to be in UTF-8. Assume worst case sizing in
- * conversion. (all latin1 characters occupy at most two bytes
- * in utf8) */
+ /* If the result won't fit in a byte, the entire result
+ * will have to be in UTF-8. Assume worst case sizing in
+ * conversion. (all latin1 characters occupy at most two
+ * bytes in utf8) */
if (title_ord > 255) {
doing_utf8 = TRUE;
convert_source_to_utf8 = TRUE;
SvCUR_set(dest, need - 1);
}
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
}
else { /* Neither source nor dest are in or need to be UTF-8 */
if (slen) {
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
- }
if (inplace) { /* in-place, only need to change the 1st char */
*d = *tmpbuf;
}
/* In a "use bytes" we don't treat the source as UTF-8, but, still want
* the destination to retain that flag */
- if (SvUTF8(source))
+ if (SvUTF8(source) && ! IN_BYTES)
SvUTF8_on(dest);
if (!inplace) { /* Finish the rest of the string, unchanged */
SvCUR_set(dest, need - 1);
}
}
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
of the three tight loops. There is less and less commonality though */
PP(pp_uc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
SvGETMAGIC(source);
- if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && SvTEMP(source) && !DO_UTF8(source)
- && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
-
- /* We can convert in place. The reason we can't if in UNI_8_BIT is to
- * make the loop tight, so we overwrite the source with the dest before
- * looking at it, and we need to look at the original source
- * afterwards. There would also need to be code added to handle
- * switching to not in-place in midstream if we run into characters
- * that change the length.
- */
+ if ((SvPADTMP(source)
+ ||
+ (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
+ && !SvREADONLY(source) && SvPOK(source)
+ && !DO_UTF8(source)
+ && (
+#ifdef USE_LOCALE_CTYPE
+ (IN_LC_RUNTIME(LC_CTYPE))
+ ? ! IN_UTF8_CTYPE_LOCALE
+ :
+#endif
+ ! IN_UNI_8_BIT))
+ {
+
+ /* We can convert in place. The reason we can't if in UNI_8_BIT is to
+ * make the loop tight, so we overwrite the source with the dest before
+ * looking at it, and we need to look at the original source
+ * afterwards. There would also need to be code added to handle
+ * switching to not in-place in midstream if we run into characters
+ * that change the length. Since being in locale overrides UNI_8_BIT,
+ * that latter becomes irrelevant in the above test; instead for
+ * locale, the size can't normally change, except if the locale is a
+ * UTF-8 one */
dest = source;
s = d = (U8*)SvPV_force_nomg(source, len);
min = len + 1;
dest = TARG;
- /* The old implementation would copy source into TARG at this point.
- This had the side effect that if source was undef, TARG was now
- an undefined SV with PADTMP set, and they don't warn inside
- sv_2pv_flags(). However, we're now getting the PV direct from
- source, which doesn't have PADTMP set, so it would warn. Hence the
- little games. */
-
- if (SvOK(source)) {
- s = (const U8*)SvPV_nomg_const(source, len);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- len = 0;
- }
+ s = (const U8*)SvPV_nomg_const(source, len);
min = len + 1;
SvUPGRADE(dest, SVt_PV);
if (DO_UTF8(source)) {
const U8 *const send = s + len;
- U8 tmpbuf[UTF8_MAXBYTES+1];
- bool tainted = FALSE;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
/* All occurrences of these are to be moved to follow any other marks.
* This is context-dependent. We may not be passed enough context to
STRLEN u;
STRLEN ulen;
UV uv;
- if (in_iota_subscript && ! is_utf8_mark(s)) {
+ if (in_iota_subscript && ! _is_utf8_mark(s)) {
/* A non-mark. Time to output the iota subscript */
-#define GREEK_CAPITAL_LETTER_IOTA 0x0399
-#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
-
- CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
+ Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
+ d += capital_iota_len;
in_iota_subscript = FALSE;
}
* and copy it to the output buffer */
u = UTF8SKIP(s);
- uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
+#endif
+#define GREEK_CAPITAL_LETTER_IOTA 0x0399
+#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
if (uv == GREEK_CAPITAL_LETTER_IOTA
&& utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
{
s += u;
}
if (in_iota_subscript) {
- CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
+ Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
+ d += capital_iota_len;
}
SvUTF8_on(dest);
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
}
else { /* Not UTF-8 */
if (len) {
/* Use locale casing if in locale; regular style if not treating
* latin1 as having case; otherwise the latin1 casing. Do the
* whole thing in a tight loop, for speed, */
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_rules;
+ }
for (; s < send; d++, s++)
- *d = toUPPER_LC(*s);
+ *d = (U8) toUPPER_LC(*s);
}
- else if (! IN_UNI_8_BIT) {
+ else
+#endif
+ if (! IN_UNI_8_BIT) {
for (; s < send; d++, s++) {
*d = toUPPER(*s);
}
}
else {
+#ifdef USE_LOCALE_CTYPE
+ do_uni_rules:
+#endif
for (; s < send; d++, s++) {
*d = toUPPER_LATIN1_MOD(*s);
- if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
+ if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+ continue;
+ }
/* The mainstream case is the tight loop above. To avoid
* extra tests in that, all three characters that require
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
} /* End of isn't utf8 */
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
PP(pp_lc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
SvGETMAGIC(source);
- if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && SvTEMP(source) && !DO_UTF8(source)) {
+ if ( ( SvPADTMP(source)
+ || ( SvTEMP(source) && !SvSMAGICAL(source)
+ && SvREFCNT(source) == 1 )
+ )
+ && !SvREADONLY(source) && SvPOK(source)
+ && !DO_UTF8(source)) {
/* We can convert in place, as lowercasing anything in the latin1 range
* (or else DO_UTF8 would have been on) doesn't lengthen it */
dest = TARG;
- /* The old implementation would copy source into TARG at this point.
- This had the side effect that if source was undef, TARG was now
- an undefined SV with PADTMP set, and they don't warn inside
- sv_2pv_flags(). However, we're now getting the PV direct from
- source, which doesn't have PADTMP set, so it would warn. Hence the
- little games. */
-
- if (SvOK(source)) {
- s = (const U8*)SvPV_nomg_const(source, len);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- len = 0;
- }
+ s = (const U8*)SvPV_nomg_const(source, len);
min = len + 1;
SvUPGRADE(dest, SVt_PV);
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- bool tainted = FALSE;
while (s < send) {
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
- _to_utf8_lower_flags(s, tmpbuf, &ulen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
+#endif
/* Here is where we would do context-sensitive actions. See the
- * commit message for this comment for why there isn't any */
+ * commit message for 86510fb15 for why there isn't any */
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
SvUTF8_on(dest);
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
} else { /* Not utf8 */
if (len) {
const U8 *const send = s + len;
/* Use locale casing if in locale; regular style if not treating
* latin1 as having case; otherwise the latin1 casing. Do the
* whole thing in a tight loop, for speed, */
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
for (; s < send; d++, s++)
*d = toLOWER_LC(*s);
- }
- else if (! IN_UNI_8_BIT) {
+ }
+ else
+#endif
+ if (! IN_UNI_8_BIT) {
for (; s < send; d++, s++) {
*d = toLOWER(*s);
}
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
}
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
PP(pp_quotemeta)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
STRLEN len;
const char *s = SvPV_const(sv,len);
}
}
else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
-
+ if (
+#ifdef USE_LOCALE_CTYPE
/* In locale, we quote all non-ASCII Latin1 chars.
* Otherwise use the quoting rules */
- if (IN_LOCALE_RUNTIME
- || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
+
+ IN_LC_RUNTIME(LC_CTYPE)
+ ||
+#endif
+ _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
{
to_quote = TRUE;
}
PP(pp_fc)
{
- dVAR;
dTARGET;
dSP;
SV *source = TOPs;
const U8 *s;
const U8 *send;
U8 *d;
- U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
- const bool full_folding = TRUE;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
+ const bool full_folding = TRUE; /* This variable is here so we can easily
+ move to more generality later */
const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
- | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
+#ifdef USE_LOCALE_CTYPE
+ | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
+#endif
+ ;
/* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
* You are welcome(?) -Hugmeir
send = s + len;
if (DO_UTF8(source)) { /* UTF-8 flagged string. */
- bool tainted = FALSE;
while (s < send) {
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
- _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
+ _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
const UV o = d - (U8*)SvPVX_const(dest);
s += u;
}
SvUTF8_on(dest);
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
} /* Unflagged string */
else if (len) {
- /* For locale, bytes, and nothing, the behavior is supposed to be the
- * same as lc().
- */
- if ( IN_LOCALE_RUNTIME ) { /* Under locale */
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_folding;
+ }
for (; s < send; d++, s++)
- *d = toLOWER_LC(*s);
+ *d = (U8) toFOLD_LC(*s);
}
- else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
+ else
+#endif
+ if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
for (; s < send; d++, s++)
- *d = toLOWER(*s);
+ *d = toFOLD(*s);
}
else {
- /* For ASCII and the Latin-1 range, there's only two troublesome folds,
- * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full casefolding
- * becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which under any fold becomes
- * \x{3BC} (\N{GREEK SMALL LETTER MU}) -- For the rest, the casefold is
- * their lowercase.
- */
+#ifdef USE_LOCALE_CTYPE
+ do_uni_folding:
+#endif
+ /* For ASCII and the Latin-1 range, there's only two troublesome
+ * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
+ * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
+ * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
+ * For the rest, the casefold is their lowercase. */
for (; s < send; d++, s++) {
if (*s == MICRO_SIGN) {
- /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, which
- * is outside of the latin-1 range. There's a couple of ways to
- * deal with this -- khw discusses them in pp_lc/uc, so go there :)
- * What we do here is upgrade what we had already casefolded,
- * then enter an inner loop that appends the rest of the characters
- * as UTF-8.
- */
+ /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
+ * which is outside of the latin-1 range. There's a couple
+ * of ways to deal with this -- khw discusses them in
+ * pp_lc/uc, so go there :) What we do here is upgrade what
+ * we had already casefolded, then enter an inner loop that
+ * appends the rest of the characters as UTF-8. */
len = d - (U8*)SvPVX_const(dest);
SvCUR_set(dest, len);
len = sv_utf8_upgrade_flags_grow(dest,
(send -s) * 2 + 1);
d = (U8*)SvPVX(dest) + len;
- CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
+ Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
+ d += small_mu_len;
s++;
for (; s < send; s++) {
STRLEN ulen;
UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
- if UNI_IS_INVARIANT(fc) {
- if ( full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
+ if UVCHR_IS_INVARIANT(fc) {
+ if (full_folding
+ && *s == LATIN_SMALL_LETTER_SHARP_S)
+ {
*d++ = 's';
*d++ = 's';
}
break;
}
else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
- /* Under full casefolding, LATIN SMALL LETTER SHARP S becomes "ss",
- * which may require growing the SV.
- */
+ /* Under full casefolding, LATIN SMALL LETTER SHARP S
+ * becomes "ss", which may require growing the SV. */
if (SvLEN(dest) < ++min) {
const UV o = d - (U8*)SvPVX_const(dest);
SvGROW(dest, min);
*(d)++ = 's';
*d = 's';
}
- else { /* If it's not one of those two, the fold is their lower case */
+ else { /* If it's not one of those two, the fold is their lower
+ case */
*d = toLOWER_LATIN1(*s);
}
}
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
PP(pp_aslice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
AV *const av = MUTABLE_AV(POPs);
const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (lval && localizing) {
SV **svp;
- I32 max = -1;
+ SSize_t max = -1;
for (svp = MARK + 1; svp <= SP; svp++) {
- const I32 elem = SvIV(*svp);
+ const SSize_t elem = SvIV(*svp);
if (elem > max)
max = elem;
}
while (++MARK <= SP) {
SV **svp;
- I32 elem = SvIV(*MARK);
+ SSize_t elem = SvIV(*MARK);
bool preeminent = TRUE;
if (localizing && can_preserve) {
svp = av_fetch(av, elem, lval);
if (lval) {
- if (!svp || *svp == &PL_sv_undef)
+ if (!svp || !*svp)
DIE(aTHX_ PL_no_aelem, elem);
if (localizing) {
if (preeminent)
RETURN;
}
+PP(pp_kvaslice)
+{
+ dSP; dMARK;
+ AV *const av = MUTABLE_AV(POPs);
+ I32 lval = (PL_op->op_flags & OPf_MOD);
+ SSize_t items = SP - MARK;
+
+ if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags) {
+ if (!(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
+ lval = flags;
+ }
+ }
+
+ MEXTEND(SP,items);
+ while (items > 1) {
+ *(MARK+items*2-1) = *(MARK+items);
+ items--;
+ }
+ items = SP-MARK;
+ SP += items;
+
+ while (++MARK <= SP) {
+ SV **svp;
+
+ svp = av_fetch(av, SvIV(*MARK), lval);
+ if (lval) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
+ DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
+ }
+ *MARK = sv_mortalcopy(*MARK);
+ }
+ *++MARK = svp ? *svp : &PL_sv_undef;
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = SP - items*2;
+ *++MARK = items > 0 ? *SP : &PL_sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
+
/* Smart dereferencing for keys, values and each */
+
+/* also used for: pp_reach() pp_rvalues() */
+
PP(pp_rkeys)
{
- dVAR;
dSP;
dPOPss;
return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
}
else {
- return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
+ return (SvTYPE(sv) == SVt_PVHV)
+ ? Perl_pp_each(aTHX)
+ : Perl_pp_aeach(aTHX);
}
}
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)) {
+ if (current > av_tindex(array)) {
*iterp = 0;
if (gimme == G_SCALAR)
RETPUSHUNDEF;
RETURN;
}
+/* also used for: pp_avalues()*/
PP(pp_akeys)
{
- dVAR;
dSP;
AV *array = MUTABLE_AV(POPs);
const I32 gimme = GIMME_V;
if (gimme == G_SCALAR) {
dTARGET;
- PUSHi(av_len(array) + 1);
+ PUSHi(av_tindex(array) + 1);
}
else if (gimme == G_ARRAY) {
IV n = Perl_av_len(aTHX_ array);
PP(pp_each)
{
- dVAR;
dSP;
HV * hash = MUTABLE_HV(POPs);
HE *entry;
STATIC OP *
S_do_delete_local(pTHX)
{
- dVAR;
dSP;
const I32 gimme = GIMME_V;
const MAGIC *mg;
HV *stash;
const bool sliced = !!(PL_op->op_private & OPpSLICE);
- SV *unsliced_keysv = sliced ? NULL : POPs;
+ SV **unsliced_keysv = sliced ? NULL : sp--;
SV * const osv = POPs;
- SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
+ SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
dORIGMARK;
const bool tied = SvRMAGICAL(osv)
&& mg_find((const SV *)osv, PERL_MAGIC_tied);
const bool can_preserve = SvCANEXISTDELETE(osv);
const U32 type = SvTYPE(osv);
- SV ** const end = sliced ? SP : &unsliced_keysv;
+ SV ** const end = sliced ? SP : unsliced_keysv;
if (type == SVt_PVHV) { /* hash element */
HV * const hv = MUTABLE_HV(osv);
}
else {
sv = hv_delete_ent(hv, keysv, 0, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ if (preeminent)
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
}
if (preeminent) {
if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
if (PL_op->op_flags & OPf_SPECIAL) {
AV * const av = MUTABLE_AV(osv);
while (++MARK <= end) {
- I32 idx = SvIV(*MARK);
+ SSize_t idx = SvIV(*MARK);
SV *sv = NULL;
bool preeminent = TRUE;
if (can_preserve)
}
else {
sv = av_delete(av, idx, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ if (preeminent)
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
}
if (preeminent) {
save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
}
}
else if (gimme != G_VOID)
- PUSHs(unsliced_keysv);
+ PUSHs(*unsliced_keysv);
RETURN;
}
PP(pp_delete)
{
- dVAR;
dSP;
I32 gimme;
I32 discard;
PP(pp_exists)
{
- dVAR;
dSP;
SV *tmpsv;
HV *hv;
- if (PL_op->op_private & OPpEXISTS_SUB) {
+ if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
GV *gv;
SV * const sv = POPs;
CV * const cv = sv_2cv(sv, &hv, &gv, 0);
}
tmpsv = POPs;
hv = MUTABLE_HV(POPs);
- if (SvTYPE(hv) == SVt_PVHV) {
+ if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
}
PP(pp_hslice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
HV * const hv = MUTABLE_HV(POPs);
const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
RETURN;
}
+PP(pp_kvhslice)
+{
+ dSP; dMARK;
+ HV * const hv = MUTABLE_HV(POPs);
+ I32 lval = (PL_op->op_flags & OPf_MOD);
+ SSize_t items = SP - MARK;
+
+ if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags) {
+ if (!(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
+ lval = flags;
+ }
+ }
+
+ MEXTEND(SP,items);
+ while (items > 1) {
+ *(MARK+items*2-1) = *(MARK+items);
+ items--;
+ }
+ items = SP-MARK;
+ SP += items;
+
+ while (++MARK <= SP) {
+ SV * const keysv = *MARK;
+ SV **svp;
+ HE *he;
+
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : NULL;
+
+ if (lval) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ }
+ *MARK = sv_mortalcopy(*MARK);
+ }
+ *++MARK = svp && *svp ? *svp : &PL_sv_undef;
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = SP - items*2;
+ *++MARK = items > 0 ? *SP : &PL_sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
/* List operators. */
PP(pp_list)
{
- dVAR; dSP; dMARK;
+ I32 markidx = POPMARK;
if (GIMME != G_ARRAY) {
+ SV **mark = PL_stack_base + markidx;
+ dSP;
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
else
*MARK = &PL_sv_undef;
SP = MARK;
+ PUTBACK;
}
- RETURN;
+ return NORMAL;
}
PP(pp_lslice)
{
- dVAR;
dSP;
SV ** const lastrelem = PL_stack_sp;
SV ** const lastlelem = PL_stack_base + POPMARK;
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
SV ** const firstrelem = lastlelem + 1;
I32 is_something_there = FALSE;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
const I32 max = lastrelem - lastlelem;
SV **lelem;
is_something_there = TRUE;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
+ else if (mod && SvPADTMP(*lelem)) {
+ *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
+ }
}
}
if (is_something_there)
PP(pp_anonlist)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK;
const I32 items = SP - MARK;
SV * const av = MUTABLE_SV(av_make(items, MARK+1));
- SP = ORIGMARK; /* av_make() might realloc stack_sp */
+ SP = MARK;
mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
? newRV_noinc(av) : av);
RETURN;
PP(pp_anonhash)
{
- dVAR; dSP; dMARK; dORIGMARK;
- HV* const hv = (HV *)sv_2mortal((SV *)newHV());
+ dSP; dMARK; dORIGMARK;
+ HV* const hv = newHV();
+ SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
+ ? newRV_noinc(MUTABLE_SV(hv))
+ : MUTABLE_SV(hv) );
while (MARK < SP) {
SV * const key =
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
- if (PL_op->op_flags & OPf_SPECIAL)
- mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
- else XPUSHs(MUTABLE_SV(hv));
+ XPUSHs(retval);
RETURN;
}
PP(pp_splice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
int num_args = (SP - MARK);
AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
SV **src;
SV **dst;
- I32 i;
- I32 offset;
- I32 length;
- I32 newlen;
- I32 after;
- I32 diff;
+ SSize_t i;
+ SSize_t offset;
+ SSize_t length;
+ SSize_t newlen;
+ SSize_t after;
+ SSize_t diff;
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
- return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ const bool real = cBOOL(AvREAL(ary));
MEXTEND(MARK, length);
- Copy(AvARRAY(ary)+offset, MARK, length, SV*);
- if (AvREAL(ary)) {
+ if (real)
EXTEND_MORTAL(length);
- for (i = length, dst = MARK; i; i--) {
+ for (i = 0, dst = MARK; i < length; i++) {
+ if ((*dst = AvARRAY(ary)[i+offset])) {
+ if (real)
sv_2mortal(*dst); /* free them eventually */
- dst++;
}
+ else
+ *dst = &PL_sv_undef;
+ dst++;
}
MARK += length - 1;
}
}
i = -diff;
while (i)
- dst[--i] = &PL_sv_undef;
+ dst[--i] = NULL;
if (newlen) {
Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
if (length) {
- Copy(tmparyval, MARK, length, SV*);
- if (AvREAL(ary)) {
+ const bool real = cBOOL(AvREAL(ary));
+ if (real)
EXTEND_MORTAL(length);
- for (i = length, dst = MARK; i; i--) {
+ for (i = 0, dst = MARK; i < length; i++) {
+ if ((*dst = tmparyval[i])) {
+ if (real)
sv_2mortal(*dst); /* free them eventually */
- dst++;
}
+ else *dst = &PL_sv_undef;
+ dst++;
}
}
MARK += length - 1;
PP(pp_push)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
PUSHMARK(MARK);
PUTBACK;
ENTER_with_name("call_PUSH");
- call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
LEAVE_with_name("call_PUSH");
SPAGAIN;
}
RETURN;
}
+/* also used for: pp_pop()*/
PP(pp_shift)
{
- dVAR;
dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
PP(pp_unshift)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
PUSHMARK(MARK);
PUTBACK;
ENTER_with_name("call_UNSHIFT");
- call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
LEAVE_with_name("call_UNSHIFT");
SPAGAIN;
}
else {
- I32 i = 0;
+ SSize_t i = 0;
av_unshift(ary, SP - MARK);
while (MARK < SP) {
SV * const sv = newSVsv(*++MARK);
PP(pp_reverse)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
if (GIMME == G_ARRAY) {
if (PL_op->op_private & OPpREVERSE_INPLACE) {
SP = MARK;
if (SvMAGICAL(av)) {
- I32 i, j;
+ SSize_t i, j;
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) {
+ for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
SV *begin, *end;
if (can_preserve) {
do_join(TARG, &PL_sv_no, MARK, SP);
else {
sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
- if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(TARG);
}
up = SvPV_force(TARG, len);
PP(pp_split)
{
- dVAR; dSP; dTARG;
- AV *ary;
+ dSP; dTARG;
+ AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
STRLEN len;
const char *s = SvPV_const(sv, len);
const bool do_utf8 = DO_UTF8(sv);
- const bool skipwhite = PL_op->op_flags & OPf_SPECIAL;
const char *strend = s + len;
PMOP *pm;
REGEXP *rx;
SV *dstr;
const char *m;
- I32 iters = 0;
- const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
- I32 maxiters = slen + 10;
+ SSize_t iters = 0;
+ const STRLEN slen = do_utf8
+ ? utf8_length((U8*)s, (U8*)strend)
+ : (STRLEN)(strend - s);
+ SSize_t maxiters = slen + 10;
I32 trailing_empty = 0;
const char *orig;
const I32 origlimit = limit;
#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);
TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
- (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite));
-
- RX_MATCH_UTF8_set(rx, do_utf8);
+ (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
#ifdef USE_ITHREADS
if (pm->op_pmreplrootu.op_pmtargetoff) {
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))) {
AvREAL_on(ary);
AvREIFY_off(ary);
for (i = AvFILLp(ary); i >= 0; i--)
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
+ AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
SAVESWITCHSTACK(PL_curstack, ary);
}
base = SP - PL_stack_base;
orig = s;
- if (skipwhite) {
+ if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
if (do_utf8) {
- while (*s == ' ' || is_utf8_space((U8*)s))
+ while (isSPACE_utf8(s))
s += UTF8SKIP(s);
}
else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
if (!limit)
limit = maxiters + 2;
- if (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite) {
+ if (RX_EXTFLAGS(rx) & RXf_WHITE) {
while (--limit) {
m = s;
/* this one uses 'm' and is a negative test */
if (do_utf8) {
- while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
+ while (m < strend && ! isSPACE_utf8(m) ) {
const int t = UTF8SKIP(m);
- /* is_utf8_space returns FALSE for malform utf8 */
+ /* isSPACE_utf8 returns FALSE for malform utf8 */
if (strend - m < t)
m = strend;
else
m += t;
}
}
- else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
+ {
while (m < strend && !isSPACE_LC(*m))
++m;
} else {
/* this one uses 's' and is a positive test */
if (do_utf8) {
- while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
+ while (s < strend && isSPACE_utf8(s) )
s += UTF8SKIP(s);
}
- else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
+ {
while (s < strend && isSPACE_LC(*s))
++s;
} else {
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)) {
+ && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
SV * const csv = CALLREG_INTUIT_STRING(rx);
trailing_empty = 0;
} else {
dstr = newSVpvn_flags(s, m-s,
- (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
XPUSHs(dstr);
}
/* The rx->minlen is in characters but we want to step
trailing_empty = 0;
} else {
dstr = newSVpvn_flags(s, m-s,
- (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
+ (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
XPUSHs(dstr);
}
/* The rx->minlen is in characters but we want to step
{
I32 rex_return;
PUTBACK;
- rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
+ rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
sv, NULL, 0);
SPAGAIN;
if (rex_return == 0)
else {
PUTBACK;
ENTER_with_name("call_PUSH");
- call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
LEAVE_with_name("call_PUSH");
SPAGAIN;
if (gimme == G_ARRAY) {
- I32 i;
+ SSize_t i;
/* EXTEND should not be needed - we just popped them */
EXTEND(SP, iters);
for (i=0; i < iters; i++) {
PP(pp_lock)
{
- dVAR;
dSP;
dTOPss;
SV *retsv = sv;
}
+/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
+ * that aren't implemented on a particular platform */
+
PP(unimplemented_op)
{
- dVAR;
const Optype op_type = PL_op->op_type;
/* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
with out of range op numbers - it only "special" cases op_custom.
const bool constr = PL_op->op_private & whicharg;
PUSHs(S_rv2gv(aTHX_
svp && *svp ? *svp : &PL_sv_undef,
- constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
+ constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
!constr
));
}
)
)
DIE(aTHX_
- /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
"Type of arg %d to &CORE::%s must be %s",
whicharg, PL_op_name[opnum],
wantscalar
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");
+ 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%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