/* pp.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
PP(pp_stub)
{
+ dVAR;
dSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
PP(pp_padav)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
I32 gimme;
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
PP(pp_padhv)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
I32 gimme;
XPUSHs(TARG);
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
else if (LVRET) {
PP(pp_rv2gv)
{
- dSP; dTOPss;
+ dVAR; dSP; dTOPss;
if (SvROK(sv)) {
wasref:
GV * const gv = (GV*) sv_newmortal();
gv_init(gv, 0, "", 0, 0);
GvIOp(gv) = (IO *)sv;
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
sv = (SV*) gv;
}
else if (SvTYPE(sv) != SVt_PVGV)
STRLEN len;
SV * const namesv = PAD_SV(cUNOP->op_targ);
const char * const name = SvPV(namesv, len);
- gv = (GV*)NEWSV(0,0);
+ gv = (GV*)newSV(0);
gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
}
else {
}
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
- if (SvPVX_const(sv)) {
+ else if (SvPVX_const(sv)) {
SvPV_free(sv);
SvLEN_set(sv, 0);
SvCUR_set(sv, 0);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
+ SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
if (!temp
&& (!is_gv_magical_sv(sv,0)
- || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
+ || !(sv = (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");
- sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
+ if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
+ == OPpDONT_INIT_GV) {
+ /* We are the target of a coderef assignment. Return
+ the scalar unchanged, and let pp_sasssign deal with
+ things. */
+ RETURN;
+ }
+ sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
}
}
}
RETURN;
}
+/* Helper function for pp_rv2sv and pp_rv2av */
+GV *
+Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
+ SV ***spp)
+{
+ dVAR;
+ GV *gv;
+
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv, 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*)gv_fetchsv(sv, 0, type);
+ if (!gv
+ && (!is_gv_magical_sv(sv,0)
+ || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, type))))
+ {
+ **spp = &PL_sv_undef;
+ return NULL;
+ }
+ }
+ else {
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, type);
+ }
+ return gv;
+}
+
PP(pp_rv2sv)
{
- GV *gv = Nullgv;
- dSP; dTOPss;
+ dVAR; dSP; dTOPss;
+ GV *gv = NULL;
if (SvROK(sv)) {
wasref:
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
DIE(aTHX_ "Not a SCALAR reference");
+ default: NOOP;
}
}
else {
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, FALSE, SVt_PV);
- if (!gv
- && (!is_gv_magical_sv(sv, 0)
- || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
- }
+ gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
+ if (!gv)
+ RETURN;
}
sv = GvSVn(gv);
}
PP(pp_av2arylen)
{
- dSP;
+ dVAR; dSP;
AV * const av = (AV*)TOPs;
SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
if (!*sv) {
- *sv = NEWSV(0,0);
+ *sv = newSV(0);
sv_upgrade(*sv, SVt_PVMG);
- sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
+ sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
}
SETs(*sv);
RETURN;
PP(pp_pos)
{
- dSP; dTARGET; dPOPss;
+ dVAR; dSP; dTARGET; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
}
LvTYPE(TARG) = '.';
if (LvTARG(TARG) != sv) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(sv);
+ LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
PUSHs(TARG); /* no SvSETMAGIC */
RETURN;
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
- PUSHi(i + PL_curcop->cop_arybase);
+ PUSHi(i + CopARYBASE_get(PL_curcop));
RETURN;
}
}
PP(pp_rv2cv)
{
- dSP;
+ dVAR; dSP;
GV *gv;
- HV *stash;
-
+ HV *stash_unused;
+ const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
+ ? 0
+ : ((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. */
/* (But not in defined().) */
- CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
+
+ CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
}
+ else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
+ cv = (CV*)gv;
+ }
else
cv = (CV*)&PL_sv_undef;
SETs((SV*)cv);
PP(pp_prototype)
{
- dSP;
+ dVAR; dSP;
CV *cv;
HV *stash;
GV *gv;
- SV *ret;
+ SV *ret = &PL_sv_undef;
- ret = &PL_sv_undef;
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
- const char * const s = SvPVX_const(TOPs);
+ const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
- const int code = keyword(s + 6, SvCUR(TOPs) - 6);
+ const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
if (code < 0) { /* Overridable. */
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
- int i = 0, n = 0, seen_question = 0;
+ int i = 0, n = 0, seen_question = 0, defgv = 0;
I32 oa;
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_exec || code == -KEY_system || code == -KEY_err)
+ goto set;
+ if (code == -KEY_mkdir) {
+ ret = sv_2mortal(newSVpvs("_;$"));
goto set;
+ }
+ if (code == -KEY_readpipe) {
+ s = "CORE::backtick";
+ }
while (i < MAXO) { /* The slow way. */
if (strEQ(s + 6, PL_op_name[i])
|| strEQ(s + 6, PL_op_desc[i]))
}
goto nonesuch; /* Should not happen... */
found:
+ defgv = PL_opargs[i] & OA_DEFGV;
oa = PL_opargs[i] >> OASHIFT;
while (oa) {
- if (oa & OA_OPTIONAL && !seen_question) {
+ if (oa & OA_OPTIONAL && !seen_question && !defgv) {
seen_question = 1;
str[n++] = ';';
}
str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
oa = oa >> 4;
}
+ if (defgv && str[n - 1] == '$')
+ str[n - 1] = '_';
str[n++] = '\0';
ret = sv_2mortal(newSVpvn(str, n - 1));
}
}
}
}
- cv = sv_2cv(TOPs, &stash, &gv, FALSE);
+ cv = sv_2cv(TOPs, &stash, &gv, 0);
if (cv && SvPOK(cv))
ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
set:
PP(pp_anoncode)
{
- dSP;
+ dVAR; dSP;
CV* cv = (CV*)PAD_SV(PL_op->op_targ);
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
PP(pp_srefgen)
{
- dSP;
+ dVAR; dSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
STATIC SV*
S_refto(pTHX_ SV *sv)
{
+ dVAR;
SV* rv;
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
else
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
else if (SvTYPE(sv) == SVt_PVAV) {
if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
av_reify((AV*)sv);
SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
else if (SvPADTMP(sv) && !IS_PADGV(sv))
sv = newSVsv(sv);
else {
SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
rv = sv_newmortal();
sv_upgrade(rv, SVt_RV);
PP(pp_ref)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
const char *pv;
SV * const sv = POPs;
PP(pp_bless)
{
- dSP;
+ dVAR; dSP;
HV *stash;
if (MAXARG == 1)
if (len == 0 && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
- stash = gv_stashpvn(ptr, len, TRUE);
+ stash = gv_stashpvn(ptr, len, GV_ADD);
}
(void)sv_bless(TOPs, stash);
PP(pp_gelem)
{
- dSP;
+ dVAR; dSP;
SV *sv = POPs;
const char * const elem = SvPV_nolen_const(sv);
GV * const gv = (GV*)POPs;
- SV * tmpRef = Nullsv;
+ SV * tmpRef = NULL;
- sv = Nullsv;
+ sv = NULL;
if (elem) {
/* elem will always be NUL terminated. */
const char * const second_letter = elem + 1;
break;
case 'P':
if (strEQ(second_letter, "ACKAGE")) {
- const HEK *hek = HvNAME_HEK(GvSTASH(gv));
- sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
+ const HV * const stash = GvSTASH(gv);
+ const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
+ sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
}
break;
case 'S':
if (strEQ(second_letter, "CALAR"))
- tmpRef = GvSV(gv);
+ tmpRef = GvSVn(gv);
break;
}
}
PP(pp_study)
{
- dSP; dPOPss;
+ dVAR; dSP; dPOPss;
register unsigned char *s;
register I32 pos;
register I32 ch;
if (SvSCREAM(sv))
RETPUSHYES;
}
- else {
- if (PL_lastscream) {
- SvSCREAM_off(PL_lastscream);
- SvREFCNT_dec(PL_lastscream);
- }
- PL_lastscream = SvREFCNT_inc(sv);
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
+ /* No point in studying a zero length string, and not safe to study
+ anything that doesn't appear to be a simple scalar (and hence might
+ change between now and when the regexp engine runs without our set
+ magic ever running) such as a reference to an object with overloaded
+ stringification. */
+ RETPUSHNO;
}
+ if (PL_lastscream) {
+ SvSCREAM_off(PL_lastscream);
+ SvREFCNT_dec(PL_lastscream);
+ }
+ PL_lastscream = SvREFCNT_inc_simple(sv);
+
s = (unsigned char*)(SvPV(sv, len));
pos = len;
if (pos <= 0)
SvSCREAM_on(sv);
/* piggyback on m//g magic */
- sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
+ sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
RETPUSHYES;
}
PP(pp_trans)
{
- dSP; dTARG;
+ dVAR; dSP; dTARG;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
PP(pp_schop)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
do_chop(TARG, TOPs);
SETTARG;
RETURN;
PP(pp_chop)
{
- dSP; dMARK; dTARGET; dORIGMARK;
+ dVAR; dSP; dMARK; dTARGET; dORIGMARK;
while (MARK < SP)
do_chop(TARG, *++MARK);
SP = ORIGMARK;
PP(pp_schomp)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SETi(do_chomp(TOPs));
RETURN;
}
PP(pp_chomp)
{
- dSP; dMARK; dTARGET;
+ dVAR; dSP; dMARK; dTARGET;
register I32 count = 0;
while (SP > MARK)
PP(pp_undef)
{
- dSP;
+ dVAR; dSP;
SV *sv;
if (!PL_op->op_private) {
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)));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
gp_free((GV*)sv);
Newxz(gp, 1, GP);
GvGP(sv) = gp_ref(gp);
- GvSV(sv) = NEWSV(72,0);
+ GvSV(sv) = newSV(0);
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = (GV*)sv;
GvMULTI_on(sv);
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
SvPV_free(sv);
- SvPV_set(sv, Nullch);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
}
SvOK_off(sv);
PP(pp_predec)
{
- dSP;
+ dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
PP(pp_postinc)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
PP(pp_postdec)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
PP(pp_pow)
{
- dSP; dATARGET;
+ dVAR; dSP; dATARGET;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
#endif
{
dPOPTOPnnrl;
+
+#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
+ /*
+ We are building perl with long double support and are on an AIX OS
+ afflicted with a powl() function that wrongly returns NaNQ for any
+ negative base. This was reported to IBM as PMR #23047-379 on
+ 03/06/2006. The problem exists in at least the following versions
+ of AIX and the libm fileset, and no doubt others as well:
+
+ AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
+ AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
+ AIX 5.2.0 bos.adt.libm 5.2.0.85
+
+ So, until IBM fixes powl(), we provide the following workaround to
+ handle the problem ourselves. Our logic is as follows: for
+ negative bases (left), we use fmod(right, 2) to check if the
+ exponent is an odd or even integer:
+
+ - if odd, powl(left, right) == -powl(-left, right)
+ - if even, powl(left, right) == powl(-left, right)
+
+ If the exponent is not an integer, the result is rightly NaNQ, so
+ we just return that (as NV_NAN).
+ */
+
+ if (left < 0.0) {
+ NV mod2 = Perl_fmod( right, 2.0 );
+ if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
+ SETn( -Perl_pow( -left, right) );
+ } else if (mod2 == 0.0) { /* even integer */
+ SETn( Perl_pow( -left, right) );
+ } else { /* fractional power */
+ SETn( NV_NAN );
+ }
+ } else {
+ SETn( Perl_pow( left, right) );
+ }
+#else
SETn( Perl_pow( left, right) );
+#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
+
#ifdef PERL_PRESERVE_IVUV
if (is_int)
SvIV_please(TOPs);
PP(pp_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
bhigh = blow >> (4 * sizeof (UV));
blow &= botmask;
if (ahigh && bhigh) {
+ NOOP;
/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
which is overflow. Drop to NVs below. */
} else if (!ahigh && !bhigh) {
/* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
so the unsigned multiply cannot overflow. */
- UV product = alow * blow;
+ const UV product = alow * blow;
if (auvok == buvok) {
/* -ve * -ve or +ve * +ve gives a +ve result. */
SP--;
PP(pp_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
/* 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
PP(pp_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
UV left = 0;
UV right = 0;
PP(pp_repeat)
{
- dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
register IV count;
dPOPss;
if (count < 1)
SvCUR_set(TARG, 0);
else {
- STRLEN max = (UV)count * len;
+ const STRLEN max = (UV)count * len;
if (len > ((MEM_SIZE)~0)/count)
Perl_croak(aTHX_ oom_string_extend);
MEM_WRAP_CHECK_1(max, char, oom_string_extend);
PP(pp_subtract)
{
- dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
+ dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
useleft = USE_LEFT(TOPm1s);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
PP(pp_left_shift)
{
- dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
const IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IV i = TOPi;
+ const IV i = TOPi;
SETi(i << shift);
}
else {
- UV u = TOPu;
+ const UV u = TOPu;
SETu(u << shift);
}
RETURN;
PP(pp_right_shift)
{
- dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
const IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
PP(pp_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP; tryAMAGICbinSET(lt,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left < right));
+#else
dPOPnv;
SETs(boolSV(TOPn < value));
+#endif
RETURN;
}
}
PP(pp_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP; tryAMAGICbinSET(gt,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left > right));
+#else
dPOPnv;
SETs(boolSV(TOPn > value));
+#endif
RETURN;
}
}
PP(pp_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP; tryAMAGICbinSET(le,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left <= right));
+#else
dPOPnv;
SETs(boolSV(TOPn <= value));
+#endif
RETURN;
}
}
PP(pp_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP; tryAMAGICbinSET(ge,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left >= right));
+#else
dPOPnv;
SETs(boolSV(TOPn >= value));
+#endif
RETURN;
}
}
PP(pp_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP; tryAMAGICbinSET(ne,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETYES;
+ SETs(boolSV(left != right));
+#else
dPOPnv;
SETs(boolSV(TOPn != value));
+#endif
RETURN;
}
}
PP(pp_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
const UV right = PTR2UV(SvRV(POPs));
PP(pp_sle)
{
- dSP;
+ dVAR; dSP;
int amg_type = sle_amg;
int multiplier = 1;
PP(pp_seq)
{
- dSP; tryAMAGICbinSET(seq,0);
+ dVAR; dSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
PP(pp_sne)
{
- dSP; tryAMAGICbinSET(sne,0);
+ dVAR; dSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
PP(pp_scmp)
{
- dSP; dTARGET; tryAMAGICbin(scmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
const int cmp = (IN_LOCALE_RUNTIME
PP(pp_bit_and)
{
- dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
SvGETMAGIC(left);
}
}
-PP(pp_bit_xor)
-{
- dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
- {
- dPOPTOPssrl;
- SvGETMAGIC(left);
- SvGETMAGIC(right);
- if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
- SETi(i);
- }
- else {
- const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
- SETu(u);
- }
- }
- else {
- do_vop(PL_op->op_type, TARG, left, right);
- SETTARG;
- }
- RETURN;
- }
-}
-
PP(pp_bit_or)
{
- dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ dVAR; dSP; dATARGET;
+ const int op_type = PL_op->op_type;
+
+ tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
{
dPOPTOPssrl;
SvGETMAGIC(left);
SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
- SETi(i);
+ const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
+ const IV r = SvIV_nomg(right);
+ const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+ SETi(result);
}
else {
- const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
- SETu(u);
+ const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
+ const UV r = SvUV_nomg(right);
+ const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+ SETu(result);
}
}
else {
- do_vop(PL_op->op_type, TARG, left, right);
+ do_vop(op_type, TARG, left, right);
SETTARG;
}
RETURN;
PP(pp_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ dVAR; dSP; dTARGET; tryAMAGICun(neg);
{
dTOPss;
const int flags = SvFLAGS(sv);
SETn(-SvNV(sv));
else if (SvPOKp(sv)) {
STRLEN len;
- const char *s = SvPV_const(sv, len);
+ const char * const s = SvPV_const(sv, len);
if (isIDFIRST(*s)) {
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
PP(pp_not)
{
- dSP; tryAMAGICunSET(not);
+ dVAR; dSP; tryAMAGICunSET(not);
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dSP; dTARGET; tryAMAGICun(compl);
+ dVAR; dSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
SvGETMAGIC(sv);
if (SvUTF8(TARG)) {
/* Calculate exact length, let's not estimate. */
STRLEN targlen = 0;
- U8 *result;
- U8 *send;
STRLEN l;
UV nchar = 0;
UV nwide = 0;
+ U8 * const send = tmps + len;
+ U8 * const origtmps = tmps;
+ const UV utf8flags = UTF8_ALLOW_ANYUV;
- send = tmps + len;
while (tmps < send) {
- const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
- tmps += UTF8SKIP(tmps);
+ const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
+ tmps += l;
targlen += UNISKIP(~c);
nchar++;
if (c > 0xff)
}
/* Now rewind strings and write them. */
- tmps -= len;
+ tmps = origtmps;
if (nwide) {
- Newxz(result, targlen + 1, U8);
+ U8 *result;
+ U8 *p;
+
+ Newx(result, targlen + 1, U8);
+ p = result;
while (tmps < send) {
- const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
- tmps += UTF8SKIP(tmps);
- result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
+ const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
+ tmps += l;
+ p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
}
- *result = '\0';
- result -= targlen;
- sv_setpvn(TARG, (char*)result, targlen);
+ *p = '\0';
+ sv_usepvn_flags(TARG, (char*)result, targlen,
+ SV_HAS_TRAILING_NUL);
SvUTF8_on(TARG);
}
else {
- Newxz(result, nchar + 1, U8);
+ U8 *result;
+ U8 *p;
+
+ Newx(result, nchar + 1, U8);
+ p = result;
while (tmps < send) {
- const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
- tmps += UTF8SKIP(tmps);
- *result++ = ~c;
+ const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
+ tmps += l;
+ *p++ = ~c;
}
- *result = '\0';
- result -= nchar;
- sv_setpvn(TARG, (char*)result, nchar);
+ *p = '\0';
+ sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
SvUTF8_off(TARG);
}
- Safefree(result);
SETs(TARG);
RETURN;
}
for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
*tmps = ~*tmps;
tmpl = (long*)tmps;
- for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+ for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
*tmpl = ~*tmpl;
tmps = (U8*)tmpl;
}
PP(pp_i_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
PP(pp_i_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ IV num;
+ dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
- DIE(aTHX_ "Illegal division by zero");
- value = POPi / value;
+ DIE(aTHX_ "Illegal division by zero");
+ num = POPi;
+
+ /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
+ if (value == -1)
+ value = - num;
+ else
+ value = num / value;
PUSHi( value );
RETURN;
}
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
/* 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; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % PERL_ABS(right) );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % PERL_ABS(right) );
RETURN;
}
}
}
}
#endif
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
PP(pp_i_add)
{
- dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPiirl_ul;
SETi( left + right );
PP(pp_i_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPiirl_ul;
SETi( left - right );
PP(pp_i_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
SETs(boolSV(left < right));
PP(pp_i_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
SETs(boolSV(left > right));
PP(pp_i_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
SETs(boolSV(left <= right));
PP(pp_i_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
SETs(boolSV(left >= right));
PP(pp_i_eq)
{
- dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
SETs(boolSV(left == right));
PP(pp_i_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
SETs(boolSV(left != right));
PP(pp_i_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
PP(pp_i_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ dVAR; dSP; dTARGET; tryAMAGICun(neg);
SETi(-TOPi);
RETURN;
}
PP(pp_atan2)
{
- dSP; dTARGET; tryAMAGICbin(atan2,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(Perl_atan2(left, right));
PP(pp_sin)
{
- dSP; dTARGET; tryAMAGICun(sin);
- {
- const NV value = POPn;
- XPUSHn(Perl_sin(value));
- RETURN;
+ dVAR; dSP; dTARGET;
+ int amg_type = sin_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;
}
-}
-PP(pp_cos)
-{
- dSP; dTARGET; tryAMAGICun(cos);
+ tryAMAGICun_var(amg_type);
{
const NV value = POPn;
- XPUSHn(Perl_cos(value));
+ if (neg_report) {
+ if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
+ SET_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
+ }
+ }
+ XPUSHn(func(value));
RETURN;
}
}
PP(pp_rand)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
NV value;
if (MAXARG < 1)
value = 1.0;
PP(pp_srand)
{
- dSP;
+ dVAR; dSP;
const UV anum = (MAXARG < 1) ? seed() : POPu;
(void)seedDrand01((Rand_seed_t)anum);
PL_srand_called = TRUE;
RETPUSHYES;
}
-PP(pp_exp)
-{
- dSP; dTARGET; tryAMAGICun(exp);
- {
- NV value;
- value = POPn;
- value = Perl_exp(value);
- XPUSHn(value);
- RETURN;
- }
-}
-
-PP(pp_log)
-{
- dSP; dTARGET; tryAMAGICun(log);
- {
- const NV value = POPn;
- if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %"NVgf, value);
- }
- XPUSHn(Perl_log(value));
- RETURN;
- }
-}
-
-PP(pp_sqrt)
-{
- dSP; dTARGET; tryAMAGICun(sqrt);
- {
- const NV value = POPn;
- if (value < 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
- }
- XPUSHn(Perl_sqrt(value));
- RETURN;
- }
-}
-
PP(pp_int)
{
- dSP; dTARGET; tryAMAGICun(int);
+ dVAR; dSP; dTARGET; tryAMAGICun(int);
{
const IV iv = TOPi; /* attempt to convert to IV if possible. */
/* XXX it's arguable that compiler casting to IV might be subtly
PP(pp_abs)
{
- dSP; dTARGET; tryAMAGICun(abs);
+ dVAR; dSP; dTARGET; tryAMAGICun(abs);
{
/* This will cache the NV value if string isn't actually integer */
const IV iv = TOPi;
RETURN;
}
-
-PP(pp_hex)
-{
- dSP; dTARGET;
- const char *tmps;
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
- STRLEN len;
- NV result_nv;
- UV result_uv;
- SV* const sv = POPs;
-
- tmps = (SvPV_const(sv, len));
- if (DO_UTF8(sv)) {
- /* If Unicode, try to downgrade
- * If not possible, croak. */
- SV* const tsv = sv_2mortal(newSVsv(sv));
-
- SvUTF8_on(tsv);
- sv_utf8_downgrade(tsv, FALSE);
- tmps = SvPV_const(tsv, len);
- }
- result_uv = grok_hex (tmps, &len, &flags, &result_nv);
- if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
- XPUSHn(result_nv);
- }
- else {
- XPUSHu(result_uv);
- }
- RETURN;
-}
-
PP(pp_oct)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
+ if (PL_op->op_type == OP_HEX)
+ goto hex;
+
while (*tmps && len && isSPACE(*tmps))
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x')
+ if (*tmps == 'x') {
+ hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
+ }
else if (*tmps == 'b')
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
PP(pp_length)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV * const sv = TOPs;
- if (DO_UTF8(sv))
+ 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.
+ */
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ if (DO_UTF8(sv)) {
+ SETi(utf8_length((U8*)p, (U8*)p + len));
+ }
+ else
+ SETi(len);
+
+ }
+ else if (DO_UTF8(sv))
SETi(sv_len_utf8(sv));
else
SETi(sv_len(sv));
PP(pp_substr)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *sv;
I32 len = 0;
STRLEN curlen;
I32 fail;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
const char *tmps;
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
SV *repl_sv = NULL;
- const char *repl = 0;
+ const char *repl = NULL;
STRLEN repl_len;
const int num_args = PL_op->op_private & 7;
bool repl_need_utf8_upgrade = FALSE;
Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr");
}
- if (SvOK(sv)) /* is it defined ? */
+ 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 */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
}
- else
- SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(sv);
+ LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
LvTARGOFF(TARG) = upos;
LvTARGLEN(TARG) = urem;
PP(pp_vec)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
register const IV size = POPi;
register const IV offset = POPi;
register SV * const src = POPs;
TARG = sv_newmortal();
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
}
LvTYPE(TARG) = 'v';
if (LvTARG(TARG) != src) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(src);
+ LvTARG(TARG) = SvREFCNT_inc_simple(src);
}
LvTARGOFF(TARG) = offset;
LvTARGLEN(TARG) = size;
PP(pp_index)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *big;
SV *little;
- SV *temp = Nullsv;
+ SV *temp = NULL;
+ STRLEN biglen;
+ STRLEN llen = 0;
I32 offset;
I32 retval;
- const char *tmps;
- const char *tmps2;
- STRLEN biglen;
- const I32 arybase = PL_curcop->cop_arybase;
- int big_utf8;
- int little_utf8;
-
- if (MAXARG < 3)
- offset = 0;
- else
+ const char *big_p;
+ const char *little_p;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
+ bool big_utf8;
+ bool little_utf8;
+ const bool is_index = PL_op->op_type == OP_INDEX;
+
+ if (MAXARG >= 3) {
+ /* arybase is in characters, like offset, so combine prior to the
+ UTF-8 to bytes calculation. */
offset = POPi - arybase;
- little = POPs;
- big = POPs;
- big_utf8 = DO_UTF8(big);
- little_utf8 = DO_UTF8(little);
- if (big_utf8 ^ little_utf8) {
- /* One needs to be upgraded. */
- SV * const bytes = little_utf8 ? big : little;
- STRLEN len;
- const char * const p = SvPV_const(bytes, len);
-
- temp = newSVpvn(p, len);
-
- if (PL_encoding) {
- sv_recode_to_utf8(temp, PL_encoding);
- } else {
- sv_utf8_upgrade(temp);
- }
- if (little_utf8) {
- big = temp;
- big_utf8 = TRUE;
- } else {
- little = temp;
- }
}
- if (big_utf8 && offset > 0)
- sv_pos_u2b(big, &offset, 0);
- tmps = SvPV_const(big, biglen);
- if (offset < 0)
- offset = 0;
- else if (offset > (I32)biglen)
- offset = biglen;
- if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
- (unsigned char*)tmps + biglen, little, 0)))
- retval = -1;
- else
- retval = tmps2 - tmps;
- if (retval > 0 && big_utf8)
- sv_pos_b2u(big, &retval);
- if (temp)
- SvREFCNT_dec(temp);
- PUSHi(retval + arybase);
- RETURN;
-}
-
-PP(pp_rindex)
-{
- dSP; dTARGET;
- SV *big;
- SV *little;
- SV *temp = Nullsv;
- STRLEN blen;
- STRLEN llen;
- I32 offset;
- I32 retval;
- const char *tmps;
- const char *tmps2;
- const I32 arybase = PL_curcop->cop_arybase;
- int big_utf8;
- int little_utf8;
-
- if (MAXARG >= 3)
- offset = POPi;
little = POPs;
big = POPs;
+ big_p = SvPV_const(big, biglen);
+ little_p = SvPV_const(little, llen);
+
big_utf8 = DO_UTF8(big);
little_utf8 = DO_UTF8(little);
if (big_utf8 ^ little_utf8) {
/* One needs to be upgraded. */
- SV * const bytes = little_utf8 ? big : little;
- STRLEN len;
- const char *p = SvPV_const(bytes, len);
-
- temp = newSVpvn(p, len);
+ if (little_utf8 && !PL_encoding) {
+ /* Well, maybe instead we might be able to downgrade the small
+ string? */
+ char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
+ &little_utf8);
+ if (little_utf8) {
+ /* If the large string is ISO-8859-1, and it's not possible to
+ convert the small string to ISO-8859-1, then there is no
+ way that it could be found anywhere by index. */
+ retval = -1;
+ goto fail;
+ }
- if (PL_encoding) {
- sv_recode_to_utf8(temp, PL_encoding);
- } else {
- sv_utf8_upgrade(temp);
- }
- if (little_utf8) {
- big = temp;
- big_utf8 = TRUE;
+ /* At this point, pv is a malloc()ed string. So donate it to temp
+ to ensure it will get free()d */
+ little = temp = newSV(0);
+ sv_usepvn(temp, pv, llen);
+ little_p = SvPVX(little);
} else {
- little = temp;
+ temp = little_utf8
+ ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ big_p = SvPV_const(big, biglen);
+ } else {
+ little = temp;
+ little_p = SvPV_const(little, llen);
+ }
}
}
- tmps2 = SvPV_const(little, llen);
- tmps = SvPV_const(big, blen);
+ if (SvGAMAGIC(big)) {
+ /* Life just becomes a lot easier if I use a temporary here.
+ 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_p = SvPVX(big);
+ }
+ if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
+ /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
+ warn on undef, and we've already triggered a warning with the
+ SvPV_const some lines above. We can't remove that, as we need to
+ call some SvPV to trigger overloading early and find out if the
+ string is UTF-8.
+ 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_p = SvPVX(little);
+ }
if (MAXARG < 3)
- offset = blen;
+ offset = is_index ? 0 : biglen;
else {
- if (offset > 0 && big_utf8)
+ if (big_utf8 && offset > 0)
sv_pos_u2b(big, &offset, 0);
- offset = offset - arybase + llen;
+ if (!is_index)
+ offset += llen;
}
if (offset < 0)
offset = 0;
- else if (offset > (I32)blen)
- offset = blen;
- if (!(tmps2 = rninstr(tmps, tmps + offset,
- tmps2, tmps2 + llen)))
+ else if (offset > (I32)biglen)
+ offset = biglen;
+ if (!(little_p = is_index
+ ? fbm_instr((unsigned char*)big_p + offset,
+ (unsigned char*)big_p + biglen, little, 0)
+ : rninstr(big_p, big_p + offset,
+ little_p, little_p + llen)))
retval = -1;
- else
- retval = tmps2 - tmps;
- if (retval > 0 && big_utf8)
- sv_pos_b2u(big, &retval);
+ else {
+ retval = little_p - big_p;
+ if (retval > 0 && big_utf8)
+ sv_pos_b2u(big, &retval);
+ }
if (temp)
SvREFCNT_dec(temp);
+ fail:
PUSHi(retval + arybase);
RETURN;
}
PP(pp_sprintf)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ 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;
PP(pp_ord)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
+
SV *argsv = POPs;
STRLEN len;
const U8 *s = (U8*)SvPV_const(argsv, len);
- SV *tmpsv;
if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
- tmpsv = sv_2mortal(newSVsv(argsv));
+ SV * const tmpsv = sv_2mortal(newSVsv(argsv));
s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
argsv = tmpsv;
}
PP(pp_chr)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
char *tmps;
UV value;
*tmps++ = (char)value;
*tmps = '\0';
(void)SvPOK_only(TARG);
+
if (PL_encoding && !IN_BYTES) {
sv_recode_to_utf8(TARG, PL_encoding);
tmps = SvPVX(TARG);
if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
- memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
- SvGROW(TARG, 3);
+ UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
+ SvGROW(TARG, 2);
tmps = SvPVX(TARG);
- SvCUR_set(TARG, 2);
- *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
- *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
+ SvCUR_set(TARG, 1);
+ *tmps++ = (char)value;
*tmps = '\0';
- SvUTF8_on(TARG);
+ SvUTF8_off(TARG);
}
}
+
XPUSHs(TARG);
RETURN;
}
PP(pp_crypt)
{
#ifdef HAS_CRYPT
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
dPOPTOPssrl;
STRLEN len;
const char *tmps = SvPV_const(left, len);
PP(pp_ucfirst)
{
+ dVAR;
dSP;
- SV *sv = TOPs;
- const U8 *s;
+ SV *source = TOPs;
STRLEN slen;
+ STRLEN need;
+ SV *dest;
+ bool inplace = TRUE;
+ bool doing_utf8;
const int op_type = PL_op->op_type;
+ const U8 *s;
+ U8 *d;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
+ STRLEN ulen;
+ STRLEN tculen;
+
+ SvGETMAGIC(source);
+ if (SvOK(source)) {
+ s = (const U8*)SvPV_nomg_const(source, slen);
+ } else {
+ s = (const U8*)"";
+ slen = 0;
+ }
- SvGETMAGIC(sv);
- if (DO_UTF8(sv) &&
- (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
- UTF8_IS_START(*s)) {
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- STRLEN ulen;
- STRLEN tculen;
-
+ if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
+ doing_utf8 = TRUE;
utf8_to_uvchr(s, &ulen);
if (op_type == OP_UCFIRST) {
toTITLE_utf8(s, tmpbuf, &tculen);
} else {
toLOWER_utf8(s, tmpbuf, &tculen);
}
+ /* If the two differ, we definately cannot do inplace. */
+ inplace = (ulen == tculen);
+ need = slen + 1 - ulen + tculen;
+ } else {
+ doing_utf8 = FALSE;
+ need = slen + 1;
+ }
+
+ if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
+ /* We can convert in place. */
+
+ dest = source;
+ s = d = (U8*)SvPV_force_nomg(source, slen);
+ } else {
+ dTARGET;
+
+ dest = TARG;
+
+ SvUPGRADE(dest, SVt_PV);
+ d = (U8*)SvGROW(dest, need);
+ (void)SvPOK_only(dest);
- if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
- dTARGET;
+ SETs(dest);
+
+ inplace = FALSE;
+ }
+
+ if (doing_utf8) {
+ if(!inplace) {
/* slen is the byte length of the whole SV.
* ulen is the byte length of the original Unicode character
* stored as UTF-8 at s.
* lowercased) Unicode character stored as UTF-8 at tmpbuf.
* We first set the result to be the titlecased (/lowercased)
* character, and then append the rest of the SV data. */
- sv_setpvn(TARG, (char*)tmpbuf, tculen);
+ sv_setpvn(dest, (char*)tmpbuf, tculen);
if (slen > ulen)
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
- SvUTF8_on(TARG);
- SETs(TARG);
+ sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
+ SvUTF8_on(dest);
}
else {
- s = (U8*)SvPV_force_nomg(sv, slen);
- Copy(tmpbuf, s, tculen, U8);
+ Copy(tmpbuf, d, tculen, U8);
+ SvCUR_set(dest, need - 1);
}
}
else {
- U8 *s1;
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv_nomg(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s1 = (U8*)SvPV_force_nomg(sv, slen);
- if (*s1) {
+ if (*s) {
if (IN_LOCALE_RUNTIME) {
TAINT;
- SvTAINTED_on(sv);
- *s1 = (op_type == OP_UCFIRST)
- ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
+ SvTAINTED_on(dest);
+ *d = (op_type == OP_UCFIRST)
+ ? toUPPER_LC(*s) : toLOWER_LC(*s);
}
else
- *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
+ *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
+ } else {
+ /* See bug #39028 */
+ *d = *s;
+ }
+
+ if (SvUTF8(source))
+ SvUTF8_on(dest);
+
+ if (!inplace) {
+ /* This will copy the trailing NUL */
+ Copy(s + 1, d + 1, slen, U8);
+ SvCUR_set(dest, need - 1);
}
}
- SvSETMAGIC(sv);
+ SvSETMAGIC(dest);
RETURN;
}
+/* There's so much setup/teardown code common between uc and lc, I wonder if
+ it would be worth merging the two, and just having a switch outside each
+ of the three tight loops. */
PP(pp_uc)
{
+ dVAR;
dSP;
- SV *sv = TOPs;
+ SV *source = TOPs;
STRLEN len;
+ STRLEN min;
+ SV *dest;
+ const U8 *s;
+ U8 *d;
- SvGETMAGIC(sv);
- if (DO_UTF8(sv)) {
+ SvGETMAGIC(source);
+
+ if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
+ && !DO_UTF8(source)) {
+ /* We can convert in place. */
+
+ dest = source;
+ s = d = (U8*)SvPV_force_nomg(source, len);
+ min = len + 1;
+ } else {
dTARGET;
- STRLEN ulen;
- register U8 *d;
- const U8 *s;
- const U8 *send;
- U8 tmpbuf[UTF8_MAXBYTES+1];
- s = (const U8*)SvPV_nomg_const(sv,len);
- if (!len) {
- SvUTF8_off(TARG); /* decontaminate */
- sv_setpvn(TARG, "", 0);
- SETs(TARG);
- }
- else {
- STRLEN min = len + 1;
+ dest = TARG;
- SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, min);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- while (s < send) {
- STRLEN u = UTF8SKIP(s);
-
- toUPPER_utf8(s, tmpbuf, &ulen);
- if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(TARG);
-
- /* If someone uppercases one million U+03B0s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating
- * too much. Such is life. */
- SvGROW(TARG, min);
- d = (U8*)SvPVX(TARG) + o;
- }
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- s += u;
- }
- *d = '\0';
- SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(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 {
+ s = (const U8*)"";
+ len = 0;
}
+ min = len + 1;
+
+ SvUPGRADE(dest, SVt_PV);
+ d = (U8*)SvGROW(dest, min);
+ (void)SvPOK_only(dest);
+
+ SETs(dest);
}
- else {
- U8 *s;
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv_nomg(TARG, sv);
- sv = TARG;
- SETs(sv);
+
+ /* Overloaded values may have toggled the UTF-8 flag on source, so we need
+ to check DO_UTF8 again here. */
+
+ if (DO_UTF8(source)) {
+ const U8 *const send = s + len;
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+
+ while (s < send) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
+
+ toUPPER_utf8(s, tmpbuf, &ulen);
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
+
+ /* If someone uppercases one million U+03B0s we SvGROW() one
+ * million times. Or we could try guessing how much to
+ allocate without allocating too much. Such is life. */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
}
- s = (U8*)SvPV_force_nomg(sv, len);
+ SvUTF8_on(dest);
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ } else {
if (len) {
- register const U8 *send = s + len;
-
+ const U8 *const send = s + len;
if (IN_LOCALE_RUNTIME) {
TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toUPPER_LC(*s);
+ SvTAINTED_on(dest);
+ for (; s < send; d++, s++)
+ *d = toUPPER_LC(*s);
}
else {
- for (; s < send; s++)
- *s = toUPPER(*s);
+ for (; s < send; d++, s++)
+ *d = toUPPER(*s);
}
}
+ if (source != dest) {
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ }
}
- SvSETMAGIC(sv);
+ SvSETMAGIC(dest);
RETURN;
}
PP(pp_lc)
{
+ dVAR;
dSP;
- SV *sv = TOPs;
+ SV *source = TOPs;
STRLEN len;
+ STRLEN min;
+ SV *dest;
+ const U8 *s;
+ U8 *d;
- SvGETMAGIC(sv);
- if (DO_UTF8(sv)) {
+ SvGETMAGIC(source);
+
+ if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
+ && !DO_UTF8(source)) {
+ /* We can convert in place. */
+
+ dest = source;
+ s = d = (U8*)SvPV_force_nomg(source, len);
+ min = len + 1;
+ } else {
dTARGET;
- const U8 *s;
- STRLEN ulen;
- register U8 *d;
- const U8 *send;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- s = (const U8*)SvPV_nomg_const(sv,len);
- if (!len) {
- SvUTF8_off(TARG); /* decontaminate */
- sv_setpvn(TARG, "", 0);
- SETs(TARG);
+ 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 {
+ s = (const U8*)"";
+ len = 0;
}
- else {
- STRLEN min = len + 1;
+ min = len + 1;
- SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, min);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- while (s < send) {
- const STRLEN u = UTF8SKIP(s);
- const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
+ SvUPGRADE(dest, SVt_PV);
+ d = (U8*)SvGROW(dest, min);
+ (void)SvPOK_only(dest);
+
+ SETs(dest);
+ }
+
+ /* Overloaded values may have toggled the UTF-8 flag on source, so we need
+ to check DO_UTF8 again here. */
+
+ if (DO_UTF8(source)) {
+ const U8 *const send = s + len;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
+
+ while (s < send) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
+ const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
- if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
- /*
- * Now if the sigma is NOT followed by
- * /$ignorable_sequence$cased_letter/;
- * and it IS preceded by
- * /$cased_letter$ignorable_sequence/;
- * where $ignorable_sequence is
- * [\x{2010}\x{AD}\p{Mn}]*
- * and $cased_letter is
- * [\p{Ll}\p{Lo}\p{Lt}]
- * then it should be mapped to 0x03C2,
- * (GREEK SMALL LETTER FINAL SIGMA),
- * instead of staying 0x03A3.
- * "should be": in other words,
- * this is not implemented yet.
- * See lib/unicore/SpecialCasing.txt.
- */
- }
- if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(TARG);
-
- /* If someone lowercases one million U+0130s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating.
- * too much. Such is life. */
- SvGROW(TARG, min);
- d = (U8*)SvPVX(TARG) + o;
- }
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- s += u;
+ if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
+ NOOP;
+ /*
+ * Now if the sigma is NOT followed by
+ * /$ignorable_sequence$cased_letter/;
+ * and it IS preceded by /$cased_letter$ignorable_sequence/;
+ * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
+ * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
+ * then it should be mapped to 0x03C2,
+ * (GREEK SMALL LETTER FINAL SIGMA),
+ * instead of staying 0x03A3.
+ * "should be": in other words, this is not implemented yet.
+ * See lib/unicore/SpecialCasing.txt.
+ */
}
- *d = '\0';
- SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(TARG);
- }
- }
- else {
- U8 *s;
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv_nomg(TARG, sv);
- sv = TARG;
- SETs(sv);
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
+
+ /* If someone lowercases one million U+0130s we SvGROW() one
+ * million times. Or we could try guessing how much to
+ allocate without allocating too much. Such is life. */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
}
-
- s = (U8*)SvPV_force_nomg(sv, len);
+ SvUTF8_on(dest);
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ } else {
if (len) {
- register const U8 * const send = s + len;
-
+ const U8 *const send = s + len;
if (IN_LOCALE_RUNTIME) {
TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toLOWER_LC(*s);
+ SvTAINTED_on(dest);
+ for (; s < send; d++, s++)
+ *d = toLOWER_LC(*s);
}
else {
- for (; s < send; s++)
- *s = toLOWER(*s);
+ for (; s < send; d++, s++)
+ *d = toLOWER(*s);
}
}
+ if (source != dest) {
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ }
}
- SvSETMAGIC(sv);
+ SvSETMAGIC(dest);
RETURN;
}
PP(pp_quotemeta)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV * const sv = TOPs;
STRLEN len;
register const char *s = SvPV_const(sv,len);
PP(pp_aslice)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
register AV* const av = (AV*)POPs;
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
if (lval && PL_op->op_private & OPpLVAL_INTRO) {
register SV **svp;
I32 max = -1;
PP(pp_each)
{
+ dVAR;
dSP;
- HV * const hash = (HV*)POPs;
+ HV * hash = (HV*)POPs;
HE *entry;
const I32 gimme = GIMME_V;
PP(pp_delete)
{
+ dVAR;
dSP;
const I32 gimme = GIMME_V;
const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
PP(pp_exists)
{
+ dVAR;
dSP;
SV *tmpsv;
HV *hv;
if (PL_op->op_private & OPpEXISTS_SUB) {
GV *gv;
SV * const sv = POPs;
- CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
+ CV * const cv = sv_2cv(sv, &hv, &gv, 0);
if (cv)
RETPUSHYES;
if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
PP(pp_hslice)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
register HV * const hv = (HV*)POPs;
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
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 (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- const char *key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
- }
+ 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);
+ }
+ }
}
}
*MARK = svp ? *svp : &PL_sv_undef;
PP(pp_list)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
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;
register SV ** const firstrelem = lastlelem + 1;
- const I32 arybase = PL_curcop->cop_arybase;
- I32 is_something_there = PL_op->op_flags & OPf_MOD;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
+ I32 is_something_there = FALSE;
register const I32 max = lastrelem - lastlelem;
register SV **lelem;
PP(pp_anonlist)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
const I32 items = SP - MARK;
- SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
+ SV * const av = (SV *) av_make(items, MARK+1);
SP = ORIGMARK; /* av_make() might realloc stack_sp */
- XPUSHs(av);
+ XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
+ ? newRV_noinc(av) : av));
RETURN;
}
PP(pp_anonhash)
{
- dSP; dMARK; dORIGMARK;
- HV* const hv = (HV*)sv_2mortal((SV*)newHV());
+ dVAR; dSP; dMARK; dORIGMARK;
+ HV* const hv = newHV();
while (MARK < SP) {
SV * const key = *++MARK;
- SV * const val = NEWSV(46, 0);
+ SV * const val = newSV(0);
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_MISC))
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
- XPUSHs((SV*)hv);
+ XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
+ ? newRV_noinc((SV*) hv) : (SV*)hv));
RETURN;
}
I32 newlen;
I32 after;
I32 diff;
- SV **tmparyval = 0;
const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
if (mg) {
if (offset < 0)
offset += AvFILLp(ary) + 1;
else
- offset -= PL_curcop->cop_arybase;
+ offset -= CopARYBASE_get(PL_curcop);
if (offset < 0)
DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
}
if (diff < 0) { /* shrinking the area */
+ SV **tmparyval = NULL;
if (newlen) {
Newx(tmparyval, newlen, SV*); /* so remember insertion */
Copy(MARK, tmparyval, newlen, SV*);
*dst-- = *src--;
}
dst = AvARRAY(ary);
- SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
+ AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
AvMAX(ary) += diff;
}
else {
}
}
else { /* no, expanding (or same) */
+ SV** tmparyval = NULL;
if (length) {
Newx(tmparyval, length, SV*); /* so remember deletion */
Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
}
if (diff > 0) { /* expanding */
-
/* push up or down? */
-
if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
if (offset) {
src = AvARRAY(ary);
dst = src - diff;
Move(src, dst, offset, SV*);
}
- SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
+ AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
AvMAX(ary) += diff;
AvFILLp(ary) += diff;
}
dst++;
}
}
- Safefree(tmparyval);
}
MARK += length - 1;
}
while (length-- > 0)
SvREFCNT_dec(tmparyval[length]);
}
- Safefree(tmparyval);
}
else
*MARK = &PL_sv_undef;
+ Safefree(tmparyval);
}
SP = MARK;
RETURN;
PP(pp_push)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = (AV*)*++MARK;
+ register AV * const ary = (AV*)*++MARK;
const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
if (mg) {
}
else {
for (++MARK; MARK <= SP; MARK++) {
- SV * const sv = NEWSV(51, 0);
+ SV * const sv = newSV(0);
if (*MARK)
sv_setsv(sv, *MARK);
av_store(ary, AvFILLp(ary)+1, sv);
RETURN;
}
-PP(pp_pop)
-{
- dSP;
- AV * const av = (AV*)POPs;
- SV * const sv = av_pop(av);
- if (AvREAL(av))
- (void)sv_2mortal(sv);
- PUSHs(sv);
- RETURN;
-}
-
PP(pp_shift)
{
+ dVAR;
dSP;
AV * const av = (AV*)POPs;
- SV * const sv = av_shift(av);
+ SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
- if (!sv)
- RETPUSHUNDEF;
+ assert (sv);
if (AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
PP(pp_reverse)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
SV ** const oldsp = SP;
if (GIMME == G_ARRAY) {
register I32 tmp;
dTARGET;
STRLEN len;
- I32 padoff_du;
+ PADOFFSET padoff_du;
SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
sv_setsv(TARG, (SP > MARK)
? *SP
: (padoff_du = find_rundefsvoffset(),
- (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+ (padoff_du == NOT_IN_PAD
+ || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
? DEFSV : PAD_SVl(padoff_du)));
up = SvPV_force(TARG, len);
if (len > 1) {
register SV *dstr;
register const char *m;
I32 iters = 0;
- const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
+ const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
I32 maxiters = slen + 10;
const char *orig;
const I32 origlimit = limit;
const I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
bool multiline = 0;
- MAGIC *mg = (MAGIC *) NULL;
+ MAGIC *mg = NULL;
#ifdef DEBUGGING
Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
else if (gimme != G_ARRAY)
ary = GvAVn(PL_defgv);
else
- ary = Nullav;
+ ary = NULL;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
realarray = 1;
PUTBACK;
base = SP - PL_stack_base;
orig = s;
if (pm->op_pmflags & PMf_SKIPWHITE) {
- if (pm->op_pmflags & PMf_LOCALE) {
+ if (do_utf8) {
+ while (*s == ' ' || is_utf8_space((U8*)s))
+ s += UTF8SKIP(s);
+ }
+ else if (pm->op_pmflags & PMf_LOCALE) {
while (isSPACE_LC(*s))
s++;
}
if (pm->op_pmflags & PMf_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 (pm->op_pmflags & PMf_LOCALE) {
+ while (m < strend && !isSPACE_LC(*m))
+ ++m;
+ } else {
+ while (m < strend && !isSPACE(*m))
+ ++m;
+ }
if (m >= strend)
break;
(void)SvUTF8_on(dstr);
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 (pm->op_pmflags & 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 & RXf_START_ONLY) {
while (--limit) {
for (m = s; m < strend && *m != '\n'; m++)
;
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);
- SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
+ else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
+ (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
+ && (rx->extflags & RXf_CHECK_ALL)
+ && !(rx->extflags & RXf_ANCH)) {
+ const int tail = (rx->extflags & RXf_INTUIT_TAIL);
+ SV * const csv = CALLREG_INTUIT_STRING(rx);
- len = rx->minlen;
- if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
+ len = rx->minlenret;
+ if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
const char c = *SvPV_nolen_const(csv);
while (--limit) {
for (m = s; m < strend && *m != c; m++)
{
I32 rex_return;
PUTBACK;
- rex_return = CALLREGEXEC(aTHX_ 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)
PP(pp_lock)
{
+ dVAR;
dSP;
dTOPss;
SV *retsv = sv;
PP(unimplemented_op)
{
+ dVAR;
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
PL_op->op_type);
}
https://perl5.git.perl.org / perl5.git / blobdiff