X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=e1a45c1a42ebc0289a26c3f8dd5131706825843b;hb=798b63bc924a07589315b3229311582adce06136;hp=896b5737f2e8426cc578ca105347b13b4bcccbd0;hpb=727b75065266fe9d20c37c822e74919eb0b182dc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 896b573..e1a45c1 100644 --- a/pp.c +++ b/pp.c @@ -1,7 +1,7 @@ /* 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. @@ -47,25 +47,22 @@ extern Pid_t getpid (void); PP(pp_stub) { + dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); RETURN; } -PP(pp_scalar) -{ - return NORMAL; -} - /* Pushy stuff. */ 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); @@ -83,7 +80,7 @@ PP(pp_padav) if (SvMAGICAL(TARG)) { U32 i; for (i=0; i < (U32)maxarg; i++) { - SV **svp = av_fetch((AV*)TARG, i, FALSE); + SV * const * const svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } @@ -93,7 +90,7 @@ PP(pp_padav) SP += maxarg; } else if (gimme == G_SCALAR) { - SV* sv = sv_newmortal(); + SV* const sv = sv_newmortal(); const I32 maxarg = AvFILL((AV*)TARG) + 1; sv_setiv(sv, maxarg); PUSHs(sv); @@ -103,12 +100,13 @@ PP(pp_padav) 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) { @@ -121,22 +119,17 @@ PP(pp_padhv) RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { - SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG); + SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG); SETs(sv); } RETURN; } -PP(pp_padany) -{ - DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); -} - /* Translations. */ PP(pp_rv2gv) { - dSP; dTOPss; + dVAR; dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -144,10 +137,10 @@ PP(pp_rv2gv) sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { - GV *gv = (GV*) sv_newmortal(); + 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) @@ -170,18 +163,18 @@ PP(pp_rv2gv) GV *gv; if (cUNOP->op_targ) { STRLEN len; - SV *namesv = PAD_SV(cUNOP->op_targ); - const char *name = SvPV(namesv, len); - gv = (GV*)NEWSV(0,0); + SV * const namesv = PAD_SV(cUNOP->op_targ); + const char * const name = SvPV(namesv, len); + gv = (GV*)newSV(0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { - const char *name = CopSTASHPV(PL_curcop); + const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } 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); @@ -201,10 +194,10 @@ PP(pp_rv2gv) if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - SV * 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; @@ -212,7 +205,14 @@ PP(pp_rv2gv) 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); } } } @@ -222,10 +222,54 @@ PP(pp_rv2gv) 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: @@ -236,7 +280,10 @@ PP(pp_rv2sv) case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: DIE(aTHX_ "Not a SCALAR reference"); + default: NOOP; } } else { @@ -248,32 +295,11 @@ PP(pp_rv2sv) if (SvROK(sv)) goto wasref; } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) - 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 { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); - gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV); - } + gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp); + if (!gv) + RETURN; } - sv = GvSV(gv); + sv = GvSVn(gv); } if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) { @@ -293,13 +319,13 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dSP; - AV *av = (AV*)TOPs; - SV **sv = Perl_av_arylen_p(aTHX_ (AV*)av); + 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; @@ -307,33 +333,31 @@ PP(pp_av2arylen) 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; } else { - MAGIC* mg; - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - mg = mg_find(sv, PERL_MAGIC_regex_global); + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { 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; } } @@ -343,13 +367,18 @@ PP(pp_pos) 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)); @@ -360,6 +389,9 @@ PP(pp_rv2cv) 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); @@ -368,26 +400,32 @@ PP(pp_rv2cv) 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 *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])) @@ -398,9 +436,10 @@ PP(pp_prototype) } 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++] = ';'; } @@ -414,6 +453,8 @@ PP(pp_prototype) 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)); } @@ -425,7 +466,7 @@ PP(pp_prototype) } } } - 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: @@ -435,7 +476,7 @@ PP(pp_prototype) 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)); @@ -446,14 +487,14 @@ PP(pp_anoncode) 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; @@ -472,6 +513,7 @@ PP(pp_refgen) STATIC SV* S_refto(pTHX_ SV *sv) { + dVAR; SV* rv; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { @@ -480,19 +522,19 @@ S_refto(pTHX_ SV *sv) 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); @@ -503,43 +545,40 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dSP; dTARGET; - SV *sv; + dVAR; dSP; dTARGET; const char *pv; + SV * const sv = POPs; - sv = POPs; - - if (sv && SvGMAGICAL(sv)) - mg_get(sv); + if (sv) + SvGETMAGIC(sv); if (!sv || !SvROK(sv)) RETPUSHNO; - sv = SvRV(sv); - pv = sv_reftype(sv,TRUE); + pv = sv_reftype(SvRV(sv),TRUE); PUSHp(pv, strlen(pv)); RETURN; } PP(pp_bless) { - dSP; + dVAR; dSP; HV *stash; if (MAXARG == 1) stash = CopSTASH(PL_curcop); else { - SV *ssv = POPs; + SV * const ssv = POPs; STRLEN len; const char *ptr; if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) Perl_croak(aTHX_ "Attempt to bless into a reference"); ptr = SvPV_const(ssv,len); - if (ckWARN(WARN_MISC) && len == 0) + 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); @@ -548,65 +587,62 @@ PP(pp_bless) PP(pp_gelem) { - GV *gv; - SV *sv; - SV *tmpRef; - const char *elem; - dSP; - STRLEN n_a; + dVAR; dSP; - sv = POPs; - elem = SvPV(sv, n_a); - gv = (GV*)POPs; - tmpRef = Nullsv; - sv = Nullsv; + SV *sv = POPs; + const char * const elem = SvPV_nolen_const(sv); + GV * const gv = (GV*)POPs; + SV * tmpRef = NULL; + + sv = NULL; if (elem) { /* elem will always be NUL terminated. */ - const char *elem2 = elem + 1; + const char * const second_letter = elem + 1; switch (*elem) { case 'A': - if (strEQ(elem2, "RRAY")) + if (strEQ(second_letter, "RRAY")) tmpRef = (SV*)GvAV(gv); break; case 'C': - if (strEQ(elem2, "ODE")) + if (strEQ(second_letter, "ODE")) tmpRef = (SV*)GvCVu(gv); break; case 'F': - if (strEQ(elem2, "ILEHANDLE")) { + if (strEQ(second_letter, "ILEHANDLE")) { /* finally deprecated in 5.8.0 */ deprecate("*glob{FILEHANDLE}"); tmpRef = (SV*)GvIOp(gv); } else - if (strEQ(elem2, "ORMAT")) + if (strEQ(second_letter, "ORMAT")) tmpRef = (SV*)GvFORM(gv); break; case 'G': - if (strEQ(elem2, "LOB")) + if (strEQ(second_letter, "LOB")) tmpRef = (SV*)gv; break; case 'H': - if (strEQ(elem2, "ASH")) + if (strEQ(second_letter, "ASH")) tmpRef = (SV*)GvHV(gv); break; case 'I': - if (*elem2 == 'O' && !elem[2]) + if (*second_letter == 'O' && !elem[2]) tmpRef = (SV*)GvIOp(gv); break; case 'N': - if (strEQ(elem2, "AME")) + if (strEQ(second_letter, "AME")) sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); break; case 'P': - if (strEQ(elem2, "ACKAGE")) { - const HEK *hek = HvNAME_HEK(GvSTASH(gv)); - sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8); + if (strEQ(second_letter, "ACKAGE")) { + 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(elem2, "CALAR")) - tmpRef = GvSV(gv); + if (strEQ(second_letter, "CALAR")) + tmpRef = GvSVn(gv); break; } } @@ -624,7 +660,7 @@ PP(pp_gelem) PP(pp_study) { - dSP; dPOPss; + dVAR; dSP; dPOPss; register unsigned char *s; register I32 pos; register I32 ch; @@ -636,13 +672,22 @@ PP(pp_study) 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; @@ -651,8 +696,8 @@ PP(pp_study) if (pos > PL_maxscream) { if (PL_maxscream < 0) { PL_maxscream = pos + 80; - New(301, PL_screamfirst, 256, I32); - New(302, PL_screamnext, PL_maxscream, I32); + Newx(PL_screamfirst, 256, I32); + Newx(PL_screamnext, PL_maxscream, I32); } else { PL_maxscream = pos + pos / 4; @@ -671,7 +716,7 @@ PP(pp_study) sfirst -= 256; while (--pos >= 0) { - ch = s[pos]; + register const I32 ch = s[pos]; if (sfirst[ch] >= 0) snext[pos] = sfirst[ch] - pos; else @@ -681,13 +726,13 @@ PP(pp_study) 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) @@ -707,7 +752,7 @@ PP(pp_trans) PP(pp_schop) { - dSP; dTARGET; + dVAR; dSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -715,67 +760,35 @@ PP(pp_schop) PP(pp_chop) { - dSP; dMARK; dTARGET; dORIGMARK; + dVAR; dSP; dMARK; dTARGET; dORIGMARK; while (MARK < SP) do_chop(TARG, *++MARK); SP = ORIGMARK; - PUSHTARG; + XPUSHTARG; RETURN; } 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) count += do_chomp(POPs); - PUSHi(count); + XPUSHi(count); RETURN; } -PP(pp_defined) -{ - dSP; - register SV* sv; - - sv = POPs; - if (!sv || !SvANY(sv)) - RETPUSHNO; - switch (SvTYPE(sv)) { - case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) - || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETPUSHYES; - break; - case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv) - || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETPUSHYES; - break; - case SVt_PVCV: - if (CvROOT(sv) || CvXSUB(sv)) - RETPUSHYES; - break; - default: - if (SvGMAGICAL(sv)) - mg_get(sv); - if (SvOK(sv)) - RETPUSHYES; - } - RETPUSHNO; -} - PP(pp_undef) { - dSP; + dVAR; dSP; SV *sv; if (!PL_op->op_private) { @@ -799,14 +812,14 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) + 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 */ - GV* gv = CvGV((CV*)sv); + GV* const gv = CvGV((CV*)sv); cv_undef((CV*)sv); CvGV((CV*)sv) = gv; } @@ -817,9 +830,9 @@ PP(pp_undef) else { GP *gp; gp_free((GV*)sv); - Newz(602, gp, 1, GP); + 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); @@ -828,7 +841,7 @@ PP(pp_undef) 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); @@ -840,7 +853,7 @@ PP(pp_undef) 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) @@ -857,7 +870,7 @@ PP(pp_predec) 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); @@ -879,7 +892,7 @@ PP(pp_postinc) 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); @@ -900,7 +913,7 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; + dVAR; dSP; dATARGET; #ifdef PERL_PRESERVE_IVUV bool is_int = 0; #endif @@ -910,36 +923,37 @@ PP(pp_pow) we're sure it is safe; otherwise we call pow() and try to convert to integer afterwards. */ { - SvIV_please(TOPm1s); - if (SvIOK(TOPm1s)) { - bool baseuok = SvUOK(TOPm1s); - UV baseuv; + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + UV power; + bool baseuok; + UV baseuv; - if (baseuok) { - baseuv = SvUVX(TOPm1s); - } else { - IV iv = SvIVX(TOPm1s); - if (iv >= 0) { - baseuv = iv; - baseuok = TRUE; /* effectively it's a UV now */ - } else { - baseuv = -iv; /* abs, baseuok == false records sign */ - } - } - SvIV_please(TOPs); - if (SvIOK(TOPs)) { - UV power; + if (SvUOK(TOPs)) { + power = SvUVX(TOPs); + } else { + const IV iv = SvIVX(TOPs); + if (iv >= 0) { + power = iv; + } else { + goto float_it; /* Can't do negative powers this way. */ + } + } - if (SvUOK(TOPs)) { - power = SvUVX(TOPs); - } else { - IV iv = SvIVX(TOPs); - if (iv >= 0) { - power = iv; - } else { - goto float_it; /* Can't do negative powers this way. */ - } - } + baseuok = SvUOK(TOPm1s); + if (baseuok) { + baseuv = SvUVX(TOPm1s); + } else { + const IV iv = SvIVX(TOPm1s); + if (iv >= 0) { + baseuv = iv; + baseuok = TRUE; /* effectively it's a UV now */ + } else { + baseuv = -iv; /* abs, baseuok == false records sign */ + } + } /* now we have integer ** positive integer. */ is_int = 1; @@ -955,34 +969,28 @@ PP(pp_pow) programmers to notice ** not doing what they mean. */ NV result = 1.0; NV base = baseuok ? baseuv : -(NV)baseuv; - int n = 0; - - for (; power; base *= base, n++) { - /* Do I look like I trust gcc with long longs here? - Do I hell. */ - UV bit = (UV)1 << (UV)n; - if (power & bit) { - result *= base; - /* Only bother to clear the bit if it is set. */ - power -= bit; - /* Avoid squaring base again if we're done. */ - if (power == 0) break; - } - } + + if (power & 1) { + result *= base; + } + while (power >>= 1) { + base *= base; + if (power & 1) { + result *= base; + } + } SP--; SETn( result ); SvIV_please(TOPs); RETURN; } else { register unsigned int highbit = 8 * sizeof(UV); - register unsigned int lowbit = 0; - register unsigned int diff; - bool odd_power = (bool)(power & 1); - while ((diff = (highbit - lowbit) >> 1)) { - if (baseuv & ~((1 << (lowbit + diff)) - 1)) - lowbit += diff; - else - highbit -= diff; + register unsigned int diff = 8 * sizeof(UV); + while (diff >>= 1) { + highbit -= diff; + if (baseuv >> highbit) { + highbit += diff; + } } /* we now have baseuv < 2 ** highbit */ if (power * highbit <= 8 * sizeof(UV)) { @@ -990,13 +998,14 @@ PP(pp_pow) on same algorithm as above */ register UV result = 1; register UV base = baseuv; - register int n = 0; - for (; power; base *= base, n++) { - register UV bit = (UV)1 << (UV)n; - if (power & bit) { + const bool odd_power = (bool)(power & 1); + if (odd_power) { + result *= base; + } + while (power >>= 1) { + base *= base; + if (power & 1) { result *= base; - power -= bit; - if (power == 0) break; } } SP--; @@ -1022,7 +1031,47 @@ PP(pp_pow) #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); @@ -1033,7 +1082,7 @@ PP(pp_pow) PP(pp_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1055,7 +1104,7 @@ PP(pp_multiply) if (auvok) { alow = SvUVX(TOPm1s); } else { - IV aiv = SvIVX(TOPm1s); + const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { alow = aiv; auvok = TRUE; /* effectively it's a UV now */ @@ -1066,7 +1115,7 @@ PP(pp_multiply) if (buvok) { blow = SvUVX(TOPs); } else { - IV biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); if (biv >= 0) { blow = biv; buvok = TRUE; /* effectively it's a UV now */ @@ -1081,12 +1130,13 @@ PP(pp_multiply) 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--; @@ -1151,7 +1201,7 @@ PP(pp_multiply) 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 @@ -1187,7 +1237,7 @@ PP(pp_divide) right = SvUVX(TOPs); } else { - IV biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); if (biv >= 0) { right = biv; right_non_neg = TRUE; /* effectively it's a UV now */ @@ -1208,7 +1258,7 @@ PP(pp_divide) left = SvUVX(TOPm1s); } else { - IV aiv = SvIVX(TOPm1s); + const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { left = aiv; left_non_neg = TRUE; /* effectively it's a UV now */ @@ -1234,7 +1284,7 @@ PP(pp_divide) #endif ) { /* Integer division can't overflow, but it can be imprecise. */ - UV result = left / right; + const UV result = left / right; if (result * right == left) { SP--; /* result is valid */ if (left_non_neg == right_non_neg) { @@ -1266,7 +1316,7 @@ PP(pp_divide) PP(pp_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left = 0; UV right = 0; @@ -1283,7 +1333,7 @@ PP(pp_modulo) if (!right_neg) { right = SvUVX(POPs); } else { - IV biv = SvIVX(POPs); + const IV biv = SvIVX(POPs); if (biv >= 0) { right = biv; right_neg = FALSE; /* effectively it's a UV now */ @@ -1315,7 +1365,7 @@ PP(pp_modulo) if (!left_neg) { left = SvUVX(POPs); } else { - IV aiv = SvIVX(POPs); + const IV aiv = SvIVX(POPs); if (aiv >= 0) { left = aiv; left_neg = FALSE; /* effectively it's a UV now */ @@ -1394,21 +1444,20 @@ PP(pp_modulo) PP(pp_repeat) { - dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register IV count; dPOPss; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvIOKp(sv)) { if (SvUOK(sv)) { - UV uv = SvUV(sv); + const UV uv = SvUV(sv); if (uv > IV_MAX) count = IV_MAX; /* The best we can do? */ else count = uv; } else { - IV iv = SvIV(sv); + const IV iv = SvIV(sv); if (iv < 0) count = 0; else @@ -1416,7 +1465,7 @@ PP(pp_repeat) } } else if (SvNOKp(sv)) { - NV nv = SvNV(sv); + const NV nv = SvNV(sv); if (nv < 0.0) count = 0; else @@ -1426,12 +1475,10 @@ PP(pp_repeat) count = SvIVx(sv); if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; - I32 items = SP - MARK; - I32 max; - static const char oom_list_extend[] = - "Out of memory during list extend"; + static const char oom_list_extend[] = "Out of memory during list extend"; + const I32 items = SP - MARK; + const I32 max = items * count; - max = items * count; MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); /* Did the max computation overflow? */ if (items > 0 && max > 0 && (max < items || max < count)) @@ -1477,7 +1524,7 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr = POPs; + SV * const tmpstr = POPs; STRLEN len; bool isutf; static const char oom_string_extend[] = @@ -1490,7 +1537,7 @@ PP(pp_repeat) 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); @@ -1522,7 +1569,7 @@ PP(pp_repeat) 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 @@ -1547,7 +1594,7 @@ PP(pp_subtract) if ((auvok = SvUOK(TOPm1s))) auv = SvUVX(TOPm1s); else { - register IV aiv = SvIVX(TOPm1s); + register const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ @@ -1567,7 +1614,7 @@ PP(pp_subtract) if (buvok) buv = SvUVX(TOPs); else { - register IV biv = SvIVX(TOPs); + register const IV biv = SvIVX(TOPs); if (biv >= 0) { buv = biv; buvok = 1; @@ -1639,15 +1686,15 @@ PP(pp_subtract) PP(pp_left_shift) { - dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - IV shift = POPi; + 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; @@ -1656,15 +1703,15 @@ PP(pp_left_shift) PP(pp_right_shift) { - dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - IV shift = POPi; + 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; @@ -1673,7 +1720,7 @@ PP(pp_right_shift) PP(pp_lt) { - dSP; tryAMAGICbinSET(lt,0); + dVAR; dSP; tryAMAGICbinSET(lt,0); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1683,16 +1730,16 @@ PP(pp_lt) bool buvok = SvUOK(TOPs); if (!auvok && !buvok) { /* ## IV < IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); + const IV aiv = SvIVX(TOPm1s); + const IV biv = SvIVX(TOPs); SP--; SETs(boolSV(aiv < biv)); RETURN; } if (auvok && buvok) { /* ## UV < UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); + const UV auv = SvUVX(TOPm1s); + const UV buv = SvUVX(TOPs); SP--; SETs(boolSV(auv < buv)); @@ -1700,9 +1747,7 @@ PP(pp_lt) } if (auvok) { /* ## UV < IV ## */ UV auv; - IV biv; - - biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); SP--; if (biv < 0) { /* As (a) is a UV, it's >=0, so it cannot be < */ @@ -1714,10 +1759,9 @@ PP(pp_lt) RETURN; } { /* ## IV < UV ## */ - IV aiv; + const IV aiv = SvIVX(TOPm1s); UV buv; - aiv = SvIVX(TOPm1s); if (aiv < 0) { /* As (b) is a UV, it's >=0, so it must be < */ SP--; @@ -1743,15 +1787,22 @@ PP(pp_lt) } #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)) { @@ -1761,16 +1812,16 @@ PP(pp_gt) bool buvok = SvUOK(TOPs); if (!auvok && !buvok) { /* ## IV > IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); - + const IV aiv = SvIVX(TOPm1s); + const IV biv = SvIVX(TOPs); + SP--; SETs(boolSV(aiv > biv)); RETURN; } if (auvok && buvok) { /* ## UV > UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); + const UV auv = SvUVX(TOPm1s); + const UV buv = SvUVX(TOPs); SP--; SETs(boolSV(auv > buv)); @@ -1778,9 +1829,8 @@ PP(pp_gt) } if (auvok) { /* ## UV > IV ## */ UV auv; - IV biv; - - biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); + SP--; if (biv < 0) { /* As (a) is a UV, it's >=0, so it must be > */ @@ -1792,10 +1842,9 @@ PP(pp_gt) RETURN; } { /* ## IV > UV ## */ - IV aiv; + const IV aiv = SvIVX(TOPm1s); UV buv; - aiv = SvIVX(TOPm1s); if (aiv < 0) { /* As (b) is a UV, it's >=0, so it cannot be > */ SP--; @@ -1821,15 +1870,22 @@ PP(pp_gt) } #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)) { @@ -1839,8 +1895,8 @@ PP(pp_le) bool buvok = SvUOK(TOPs); if (!auvok && !buvok) { /* ## IV <= IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); + const IV aiv = SvIVX(TOPm1s); + const IV biv = SvIVX(TOPs); SP--; SETs(boolSV(aiv <= biv)); @@ -1856,9 +1912,8 @@ PP(pp_le) } if (auvok) { /* ## UV <= IV ## */ UV auv; - IV biv; - - biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); + SP--; if (biv < 0) { /* As (a) is a UV, it's >=0, so a cannot be <= */ @@ -1870,10 +1925,9 @@ PP(pp_le) RETURN; } { /* ## IV <= UV ## */ - IV aiv; + const IV aiv = SvIVX(TOPm1s); UV buv; - - aiv = SvIVX(TOPm1s); + if (aiv < 0) { /* As (b) is a UV, it's >=0, so a must be <= */ SP--; @@ -1899,15 +1953,22 @@ PP(pp_le) } #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)) { @@ -1917,26 +1978,25 @@ PP(pp_ge) bool buvok = SvUOK(TOPs); if (!auvok && !buvok) { /* ## IV >= IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); - + const IV aiv = SvIVX(TOPm1s); + const IV biv = SvIVX(TOPs); + SP--; SETs(boolSV(aiv >= biv)); RETURN; } if (auvok && buvok) { /* ## UV >= UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); - + const UV auv = SvUVX(TOPm1s); + const UV buv = SvUVX(TOPs); + SP--; SETs(boolSV(auv >= buv)); RETURN; } if (auvok) { /* ## UV >= IV ## */ UV auv; - IV biv; - - biv = SvIVX(TOPs); + const IV biv = SvIVX(TOPs); + SP--; if (biv < 0) { /* As (a) is a UV, it's >=0, so it must be >= */ @@ -1948,10 +2008,9 @@ PP(pp_ge) RETURN; } { /* ## IV >= UV ## */ - IV aiv; + const IV aiv = SvIVX(TOPm1s); UV buv; - - aiv = SvIVX(TOPm1s); + if (aiv < 0) { /* As (b) is a UV, it's >=0, so a cannot be >= */ SP--; @@ -1977,15 +2036,22 @@ PP(pp_ge) } #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--; @@ -1998,8 +2064,8 @@ PP(pp_ne) if (SvIOK(TOPs)) { SvIV_please(TOPm1s); if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); + const bool auvok = SvUOK(TOPm1s); + const bool buvok = SvUOK(TOPs); if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ /* Casting IV to UV before comparison isn't going to matter @@ -2008,9 +2074,9 @@ PP(pp_ne) differ from normal zero. As I understand it. (Need to check - is negative zero implementation defined behaviour anyway?). NWC */ - UV buv = SvUVX(POPs); - UV auv = SvUVX(TOPs); - + const UV buv = SvUVX(POPs); + const UV auv = SvUVX(TOPs); + SETs(boolSV(auv != buv)); RETURN; } @@ -2046,19 +2112,26 @@ PP(pp_ne) } #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)) { - UV right = PTR2UV(SvRV(POPs)); - UV left = PTR2UV(SvRV(TOPs)); + const UV right = PTR2UV(SvRV(POPs)); + const UV left = PTR2UV(SvRV(TOPs)); SETi((left > right) - (left < right)); RETURN; } @@ -2069,12 +2142,12 @@ PP(pp_ncmp) if (SvIOK(TOPs)) { SvIV_please(TOPm1s); if (SvIOK(TOPm1s)) { - bool leftuvok = SvUOK(TOPm1s); - bool rightuvok = SvUOK(TOPs); + const bool leftuvok = SvUOK(TOPm1s); + const bool rightuvok = SvUOK(TOPs); I32 value; if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ - IV leftiv = SvIVX(TOPm1s); - IV rightiv = SvIVX(TOPs); + const IV leftiv = SvIVX(TOPm1s); + const IV rightiv = SvIVX(TOPs); if (leftiv > rightiv) value = 1; @@ -2083,8 +2156,8 @@ PP(pp_ncmp) else value = 0; } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ - UV leftuv = SvUVX(TOPm1s); - UV rightuv = SvUVX(TOPs); + const UV leftuv = SvUVX(TOPm1s); + const UV rightuv = SvUVX(TOPs); if (leftuv > rightuv) value = 1; @@ -2093,15 +2166,12 @@ PP(pp_ncmp) else value = 0; } else if (leftuvok) { /* ## UV <=> IV ## */ - UV leftuv; - IV rightiv; - - rightiv = SvIVX(TOPs); + const IV rightiv = SvIVX(TOPs); if (rightiv < 0) { /* As (a) is a UV, it's >=0, so it cannot be < */ value = 1; } else { - leftuv = SvUVX(TOPm1s); + const UV leftuv = SvUVX(TOPm1s); if (leftuv > (UV)rightiv) { value = 1; } else if (leftuv < (UV)rightiv) { @@ -2111,15 +2181,12 @@ PP(pp_ncmp) } } } else { /* ## IV <=> UV ## */ - IV leftiv; - UV rightuv; - - leftiv = SvIVX(TOPm1s); + const IV leftiv = SvIVX(TOPm1s); if (leftiv < 0) { /* As (b) is a UV, it's >=0, so it must be < */ value = -1; } else { - rightuv = SvUVX(TOPs); + const UV rightuv = SvUVX(TOPs); if ((UV)leftiv > rightuv) { value = 1; } else if ((UV)leftiv < rightuv) { @@ -2162,61 +2229,47 @@ PP(pp_ncmp) } } -PP(pp_slt) +PP(pp_sle) { - dSP; tryAMAGICbinSET(slt,0); - { - dPOPTOPssrl; - int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale(left, right) - : sv_cmp(left, right)); - SETs(boolSV(cmp < 0)); - RETURN; - } -} + dVAR; dSP; -PP(pp_sgt) -{ - dSP; tryAMAGICbinSET(sgt,0); - { - dPOPTOPssrl; - int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale(left, right) - : sv_cmp(left, right)); - SETs(boolSV(cmp > 0)); - RETURN; - } -} + int amg_type = sle_amg; + int multiplier = 1; + int rhs = 1; -PP(pp_sle) -{ - dSP; tryAMAGICbinSET(sle,0); - { - dPOPTOPssrl; - int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale(left, right) - : sv_cmp(left, right)); - SETs(boolSV(cmp <= 0)); - RETURN; + switch (PL_op->op_type) { + case OP_SLT: + amg_type = slt_amg; + /* cmp < 0 */ + rhs = 0; + break; + case OP_SGT: + amg_type = sgt_amg; + /* cmp > 0 */ + multiplier = -1; + rhs = 0; + break; + case OP_SGE: + amg_type = sge_amg; + /* cmp >= 0 */ + multiplier = -1; + break; } -} -PP(pp_sge) -{ - dSP; tryAMAGICbinSET(sge,0); + tryAMAGICbinSET_var(amg_type,0); { dPOPTOPssrl; - int cmp = (IN_LOCALE_RUNTIME + const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) : sv_cmp(left, right)); - SETs(boolSV(cmp >= 0)); + SETs(boolSV(cmp * multiplier < rhs)); RETURN; } } PP(pp_seq) { - dSP; tryAMAGICbinSET(seq,0); + dVAR; dSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -2226,7 +2279,7 @@ PP(pp_seq) PP(pp_sne) { - dSP; tryAMAGICbinSET(sne,0); + dVAR; dSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -2236,10 +2289,10 @@ PP(pp_sne) PP(pp_scmp) { - dSP; dTARGET; tryAMAGICbin(scmp,0); + dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; - int cmp = (IN_LOCALE_RUNTIME + const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETi( cmp ); @@ -2249,43 +2302,18 @@ PP(pp_scmp) PP(pp_bit_and) { - dSP; dATARGET; tryAMAGICbin(band,opASSIGN); - { - dPOPTOPssrl; - if (SvGMAGICAL(left)) mg_get(left); - if (SvGMAGICAL(right)) mg_get(right); - if (SvNIOKp(left) || SvNIOKp(right)) { - if (PL_op->op_private & HINT_INTEGER) { - IV i = SvIV_nomg(left) & SvIV_nomg(right); - SETi(i); - } - else { - UV u = SvUV_nomg(left) & SvUV_nomg(right); - SETu(u); - } - } - else { - do_vop(PL_op->op_type, TARG, left, right); - SETTARG; - } - RETURN; - } -} - -PP(pp_bit_xor) -{ - dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; - if (SvGMAGICAL(left)) mg_get(left); - if (SvGMAGICAL(right)) mg_get(right); + SvGETMAGIC(left); + SvGETMAGIC(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); + const IV i = SvIV_nomg(left) & SvIV_nomg(right); SETi(i); } else { - UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); + const UV u = SvUV_nomg(left) & SvUV_nomg(right); SETu(u); } } @@ -2299,23 +2327,30 @@ PP(pp_bit_xor) 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; - if (SvGMAGICAL(left)) mg_get(left); - if (SvGMAGICAL(right)) mg_get(right); + SvGETMAGIC(left); + SvGETMAGIC(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - 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 { - 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; @@ -2324,12 +2359,11 @@ PP(pp_bit_or) PP(pp_negate) { - dSP; dTARGET; tryAMAGICun(neg); + dVAR; dSP; dTARGET; tryAMAGICun(neg); { dTOPss; - int flags = SvFLAGS(sv); - if (SvGMAGICAL(sv)) - mg_get(sv); + const int flags = SvFLAGS(sv); + SvGETMAGIC(sv); if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ oops_its_an_int: @@ -2359,7 +2393,7 @@ PP(pp_negate) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; - char *s = SvPV(sv, len); + const char * const s = SvPV_const(sv, len); if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); @@ -2395,25 +2429,24 @@ PP(pp_negate) 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; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = ~SvIV_nomg(sv); + const IV i = ~SvIV_nomg(sv); SETi(i); } else { - UV u = ~SvUV_nomg(sv); + const UV u = ~SvUV_nomg(sv); SETu(u); } } @@ -2422,23 +2455,23 @@ PP(pp_complement) register I32 anum; STRLEN len; - (void)SvPV_nomg(sv,len); /* force check for uninit var */ + (void)SvPV_nomg_const(sv,len); /* force check for uninit var */ sv_setsv_nomg(TARG, sv); tmps = (U8*)SvPV_force(TARG, len); anum = len; 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) { - 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) @@ -2446,33 +2479,39 @@ PP(pp_complement) } /* Now rewind strings and write them. */ - tmps -= len; + tmps = origtmps; if (nwide) { - Newz(0, result, targlen + 1, U8); + U8 *result; + U8 *p; + + Newx(result, targlen + 1, U8); + p = result; while (tmps < send) { - 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 { - Newz(0, result, nchar + 1, U8); + U8 *result; + U8 *p; + + Newx(result, nchar + 1, U8); + p = result; while (tmps < send) { - 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; } @@ -2482,7 +2521,7 @@ PP(pp_complement) 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; } @@ -2500,7 +2539,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -2510,12 +2549,19 @@ PP(pp_i_multiply) 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; } @@ -2530,7 +2576,11 @@ PP(pp_i_modulo_0) 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; } } @@ -2542,12 +2592,16 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dVAR; 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; } } @@ -2563,7 +2617,7 @@ PP(pp_i_modulo) /* The assumption is to use hereafter the old vanilla version... */ PL_op->op_ppaddr = PL_ppaddr[OP_I_MODULO] = - &Perl_pp_i_modulo_0; + Perl_pp_i_modulo_0; /* .. but if we have glibc, we might have a buggy _moddi3 * (at least glicb 2.2.5 is known to have this bug), in other * words our integer modulus with negative quad as the second @@ -2588,14 +2642,18 @@ PP(pp_i_modulo) } } #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 ); @@ -2605,7 +2663,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl_ul; SETi( left - right ); @@ -2615,7 +2673,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dSP; tryAMAGICbinSET(lt,0); + dVAR; dSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -2625,7 +2683,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dSP; tryAMAGICbinSET(gt,0); + dVAR; dSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -2635,7 +2693,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dSP; tryAMAGICbinSET(le,0); + dVAR; dSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -2645,7 +2703,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dSP; tryAMAGICbinSET(ge,0); + dVAR; dSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -2655,7 +2713,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dSP; tryAMAGICbinSET(eq,0); + dVAR; dSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -2665,7 +2723,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dSP; tryAMAGICbinSET(ne,0); + dVAR; dSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -2675,7 +2733,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -2693,7 +2751,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dSP; dTARGET; tryAMAGICun(neg); + dVAR; dSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -2702,7 +2760,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dSP; dTARGET; tryAMAGICbin(atan2,0); + dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(Perl_atan2(left, right)); @@ -2712,24 +2770,43 @@ PP(pp_atan2) PP(pp_sin) { - dSP; dTARGET; tryAMAGICun(sin); - { - NV value; - value = POPn; - value = Perl_sin(value); - XPUSHn(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); { - NV value; - value = POPn; - value = Perl_cos(value); - XPUSHn(value); + const NV value = POPn; + 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; } } @@ -2751,7 +2828,7 @@ extern double drand48 (void); PP(pp_rand) { - dSP; dTARGET; + dVAR; dSP; dTARGET; NV value; if (MAXARG < 1) value = 1.0; @@ -2770,68 +2847,19 @@ PP(pp_rand) PP(pp_srand) { - dSP; - UV anum; - if (MAXARG < 1) - anum = seed(); - else - anum = POPu; + dVAR; dSP; + const UV anum = (MAXARG < 1) ? seed() : POPu; (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } -PP(pp_exp) +PP(pp_int) { - dSP; dTARGET; tryAMAGICun(exp); + dVAR; dSP; dTARGET; tryAMAGICun(int); { - NV value; - value = POPn; - value = Perl_exp(value); - XPUSHn(value); - RETURN; - } -} - -PP(pp_log) -{ - dSP; dTARGET; tryAMAGICun(log); - { - NV value; - value = POPn; - if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take log of %"NVgf, value); - } - value = Perl_log(value); - XPUSHn(value); - RETURN; - } -} - -PP(pp_sqrt) -{ - dSP; dTARGET; tryAMAGICun(sqrt); - { - NV value; - value = POPn; - if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take sqrt of %"NVgf, value); - } - value = Perl_sqrt(value); - XPUSHn(value); - RETURN; - } -} - -PP(pp_int) -{ - dSP; dTARGET; tryAMAGICun(int); - { - NV value; - IV iv = TOPi; /* attempt to convert to IV if possible. */ + const IV iv = TOPi; /* attempt to convert to IV if possible. */ /* XXX it's arguable that compiler casting to IV might be subtly different from modf (for numbers inside (IV_MIN,UV_MAX)) in which else preferring IV has introduced a subtle behaviour change bug. OTOH @@ -2841,12 +2869,12 @@ PP(pp_int) SETu(0); else if (SvIOK(TOPs)) { if (SvIsUV(TOPs)) { - UV uv = TOPu; + const UV uv = TOPu; SETu(uv); } else SETi(iv); } else { - value = TOPn; + const NV value = TOPn; if (value >= 0.0) { if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); @@ -2868,10 +2896,10 @@ PP(pp_int) PP(pp_abs) { - dSP; dTARGET; tryAMAGICun(abs); + dVAR; dSP; dTARGET; tryAMAGICun(abs); { /* This will cache the NV value if string isn't actually integer */ - IV iv = TOPi; + const IV iv = TOPi; if (!SvOK(TOPs)) SETu(0); @@ -2893,72 +2921,47 @@ PP(pp_abs) } } } else{ - NV value = TOPn; + const NV value = TOPn; if (value < 0.0) - value = -value; - SETn(value); + SETn(-value); + else + SETn(value); } } RETURN; } - -PP(pp_hex) -{ - dSP; dTARGET; - const char *tmps; - I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; - STRLEN len; - NV result_nv; - UV result_uv; - SV* sv = POPs; - - tmps = (SvPVx_const(sv, len)); - if (DO_UTF8(sv)) { - /* If Unicode, try to downgrade - * If not possible, croak. */ - SV* tsv = sv_2mortal(newSVsv(sv)); - - SvUTF8_on(tsv); - sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); - } - 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; NV result_nv; UV result_uv; - SV* sv = POPs; + SV* const sv = POPs; - tmps = (SvPVx_const(sv, len)); + tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { /* If Unicode, try to downgrade * If not possible, croak. */ - SV* tsv = sv_2mortal(newSVsv(sv)); + SV* const tsv = sv_2mortal(newSVsv(sv)); SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); + 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 @@ -2977,10 +2980,25 @@ PP(pp_oct) PP(pp_length) { - dSP; dTARGET; - SV *sv = TOPs; + dVAR; dSP; dTARGET; + SV * const sv = TOPs; + + if (SvAMAGIC(sv)) { + /* For an overloaded scalar, we can't know in advance if it's going to + be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to + cache the length. Maybe that should be a documented feature of it. + */ + 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); - if (DO_UTF8(sv)) + } + else if (DO_UTF8(sv)) SETi(sv_len_utf8(sv)); else SETi(sv_len(sv)); @@ -2989,7 +3007,7 @@ PP(pp_length) PP(pp_substr) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SV *sv; I32 len = 0; STRLEN curlen; @@ -2999,11 +3017,11 @@ PP(pp_substr) 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; - int num_args = PL_op->op_private & 7; + const int num_args = PL_op->op_private & 7; bool repl_need_utf8_upgrade = FALSE; bool repl_is_utf8 = FALSE; @@ -3012,7 +3030,7 @@ PP(pp_substr) if (num_args > 2) { if (num_args > 3) { repl_sv = POPs; - repl = SvPV(repl_sv, repl_len); + repl = SvPV_const(repl_sv, repl_len); repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); } len = POPi; @@ -3080,8 +3098,8 @@ PP(pp_substr) RETPUSHUNDEF; } else { - I32 upos = pos; - I32 urem = rem; + const I32 upos = pos; + const I32 urem = rem; if (utf8_curlen) sv_pos_u2b(sv, &pos, &rem); tmps += pos; @@ -3110,7 +3128,7 @@ PP(pp_substr) if (repl_need_utf8_upgrade) { repl_sv_copy = newSVsv(repl_sv); sv_utf8_upgrade(repl_sv_copy); - repl = SvPV(repl_sv_copy, repl_len); + repl = SvPV_const(repl_sv_copy, repl_len); repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); } sv_insert(sv, pos, rem, repl, repl_len); @@ -3122,13 +3140,14 @@ PP(pp_substr) else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { - STRLEN n_a; - SvPV_force(sv,n_a); + SvPV_force_nolen(sv); if (ckWARN(WARN_SUBSTR)) 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 */ @@ -3136,16 +3155,14 @@ PP(pp_substr) 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; @@ -3158,11 +3175,11 @@ PP(pp_substr) PP(pp_vec) { - dSP; dTARGET; - register IV size = POPi; - register IV offset = POPi; - register SV *src = POPs; - I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; + dVAR; dSP; dTARGET; + register const IV size = POPi; + register const IV offset = POPi; + register SV * const src = POPs; + const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ @@ -3170,13 +3187,13 @@ PP(pp_vec) 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; @@ -3189,143 +3206,134 @@ PP(pp_vec) 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; - char *tmps; - char *tmps2; - STRLEN biglen; - 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 *bytes = little_utf8 ? big : little; - STRLEN len; - char *p = SvPV(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(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; - char *tmps; - char *tmps2; - 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 *bytes = little_utf8 ? big : little; - STRLEN len; - char *p = SvPV(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(little, llen); - tmps = SvPV(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)); - if (DO_UTF8(*(MARK+1))) - SvUTF8_on(TARG); SP = ORIGMARK; PUSHTARG; RETURN; @@ -3333,14 +3341,14 @@ PP(pp_sprintf) PP(pp_ord) { - dSP; dTARGET; + dVAR; dSP; dTARGET; + SV *argsv = POPs; STRLEN len; - const U8 *s = (U8*)SvPVx_const(argsv, len); - SV *tmpsv; + const U8 *s = (U8*)SvPV_const(argsv, len); 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; } @@ -3354,7 +3362,7 @@ PP(pp_ord) PP(pp_chr) { - dSP; dTARGET; + dVAR; dSP; dTARGET; char *tmps; UV value; @@ -3376,7 +3384,7 @@ PP(pp_chr) if (value > 255 && !IN_BYTES) { SvGROW(TARG, (STRLEN)UNISKIP(value)+1); tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); - SvCUR_set(TARG, tmps - SvPVX(TARG)); + SvCUR_set(TARG, tmps - SvPVX_const(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); @@ -3390,20 +3398,21 @@ PP(pp_chr) *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; } @@ -3411,21 +3420,20 @@ PP(pp_chr) PP(pp_crypt) { #ifdef HAS_CRYPT - dSP; dTARGET; + dVAR; dSP; dTARGET; dPOPTOPssrl; - STRLEN n_a; STRLEN len; - char *tmps = SvPV(left, len); + const char *tmps = SvPV_const(left, len); if (DO_UTF8(left)) { /* If Unicode, try to downgrade. * If not possible, croak. * Yes, we made this up. */ - SV* tsv = sv_2mortal(newSVsv(left)); + SV* const tsv = sv_2mortal(newSVsv(left)); SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); + tmps = SvPV_const(tsv, len); } # ifdef USE_ITHREADS # ifdef HAS_CRYPT_R @@ -3446,9 +3454,9 @@ PP(pp_crypt) # endif /* HAS_CRYPT_R */ # endif /* USE_ITHREADS */ # ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); + sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); # else - sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif SETs(TARG); RETURN; @@ -3460,318 +3468,340 @@ PP(pp_crypt) PP(pp_ucfirst) { + dVAR; dSP; - SV *sv = TOPs; - register 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 = (U8*)SvPV_nomg(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); - toTITLE_utf8(s, tmpbuf, &tculen); - utf8_to_uvchr(tmpbuf, 0); + 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); + + SETs(dest); + + inplace = FALSE; + } - if (!SvPADTMP(sv) || SvREADONLY(sv)) { - dTARGET; + 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. - * tculen is the byte length of the freshly titlecased - * Unicode character stored as UTF-8 at tmpbuf. - * We first set the result to be the titlecased character, - * and then append the rest of the SV data. */ - sv_setpvn(TARG, (char*)tmpbuf, tculen); + * tculen is the byte length of the freshly titlecased (or + * 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(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 { - if (!SvPADTMP(sv) || SvREADONLY(sv)) { - dTARGET; - SvUTF8_off(TARG); /* decontaminate */ - sv_setsv_nomg(TARG, sv); - sv = TARG; - SETs(sv); - } - s = (U8*)SvPV_force_nomg(sv, slen); if (*s) { if (IN_LOCALE_RUNTIME) { TAINT; - SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + SvTAINTED_on(dest); + *d = (op_type == OP_UCFIRST) + ? toUPPER_LC(*s) : toLOWER_LC(*s); } else - *s = toUPPER(*s); + *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s); + } else { + /* See bug #39028 */ + *d = *s; } - } - SvSETMAGIC(sv); - RETURN; -} -PP(pp_lcfirst) -{ - dSP; - SV *sv = TOPs; - register U8 *s; - STRLEN slen; - - SvGETMAGIC(sv); - if (DO_UTF8(sv) && - (s = (U8*)SvPV_nomg(sv, slen)) && slen && - UTF8_IS_START(*s)) { - STRLEN ulen; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - U8 *tend; - UV uv; + if (SvUTF8(source)) + SvUTF8_on(dest); - toLOWER_utf8(s, tmpbuf, &ulen); - uv = utf8_to_uvchr(tmpbuf, 0); - tend = uvchr_to_utf8(tmpbuf, uv); - - if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { - dTARGET; - sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); - if (slen > ulen) - sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); - SvUTF8_on(TARG); - SETs(TARG); - } - else { - s = (U8*)SvPV_force_nomg(sv, slen); - Copy(tmpbuf, s, ulen, U8); - } - } - else { - if (!SvPADTMP(sv) || SvREADONLY(sv)) { - dTARGET; - SvUTF8_off(TARG); /* decontaminate */ - sv_setsv_nomg(TARG, sv); - sv = TARG; - SETs(sv); - } - s = (U8*)SvPV_force_nomg(sv, slen); - if (*s) { - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(sv); - *s = toLOWER_LC(*s); - } - else - *s = toLOWER(*s); + 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; - register U8 *s; + 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; - U8 *send; - U8 tmpbuf[UTF8_MAXBYTES+1]; - s = (U8*)SvPV_nomg(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. */ - UV o = d - (U8*)SvPVX(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(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 { - 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 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; - register U8 *s; + 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; - U8 *send; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - s = (U8*)SvPV_nomg(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) { - STRLEN u = UTF8SKIP(s); - 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. */ - UV o = d - (U8*)SvPVX(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(TARG)); - SETs(TARG); - } - } - else { - 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 U8 *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; - SV *sv = TOPs; + dVAR; dSP; dTARGET; + SV * const sv = TOPs; STRLEN len; - const register char *s = SvPV_const(sv,len); - register char *d; + register const char *s = SvPV_const(sv,len); SvUTF8_off(TARG); /* decontaminate */ if (len) { + register char *d; SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); @@ -3802,7 +3832,7 @@ PP(pp_quotemeta) } } *d = '\0'; - SvCUR_set(TARG, d - SvPVX(TARG)); + SvCUR_set(TARG, d - SvPVX_const(TARG)); (void)SvPOK_only_UTF8(TARG); } else @@ -3817,18 +3847,17 @@ PP(pp_quotemeta) PP(pp_aslice) { - dSP; dMARK; dORIGMARK; - register SV** svp; - register AV* av = (AV*)POPs; - register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); - I32 arybase = PL_curcop->cop_arybase; - I32 elem; + 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 = CopARYBASE_get(PL_curcop); if (lval && PL_op->op_private & OPpLVAL_INTRO) { + register SV **svp; I32 max = -1; for (svp = MARK + 1; svp <= SP; svp++) { - elem = SvIVx(*svp); + const I32 elem = SvIVx(*svp); if (elem > max) max = elem; } @@ -3836,7 +3865,8 @@ PP(pp_aslice) av_extend(av, max); } while (++MARK <= SP) { - elem = SvIVx(*MARK); + register SV **svp; + I32 elem = SvIVx(*MARK); if (elem > 0) elem -= arybase; @@ -3862,8 +3892,9 @@ PP(pp_aslice) PP(pp_each) { + dVAR; dSP; - HV *hash = (HV*)POPs; + HV * hash = (HV*)POPs; HE *entry; const I32 gimme = GIMME_V; @@ -3874,7 +3905,7 @@ PP(pp_each) EXTEND(SP, 2); if (entry) { - SV* sv = hv_iterkeysv(entry); + SV* const sv = hv_iterkeysv(entry); PUSHs(sv); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { SV *val; @@ -3891,39 +3922,27 @@ PP(pp_each) RETURN; } -PP(pp_values) -{ - return do_kv(); -} - -PP(pp_keys) -{ - return do_kv(); -} - PP(pp_delete) { + dVAR; dSP; const I32 gimme = GIMME_V; const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; - SV *sv; - HV *hv; if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; - U32 hvtype; - hv = (HV*)POPs; - hvtype = SvTYPE(hv); + HV * const hv = (HV*)POPs; + const U32 hvtype = SvTYPE(hv); if (hvtype == SVt_PVHV) { /* hash element */ while (++MARK <= SP) { - sv = hv_delete_ent(hv, *MARK, discard, 0); + SV * const sv = hv_delete_ent(hv, *MARK, discard, 0); *MARK = sv ? sv : &PL_sv_undef; } } else if (hvtype == SVt_PVAV) { /* array element */ if (PL_op->op_flags & OPf_SPECIAL) { while (++MARK <= SP) { - sv = av_delete((AV*)hv, SvIV(*MARK), discard); + SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard); *MARK = sv ? sv : &PL_sv_undef; } } @@ -3943,7 +3962,8 @@ PP(pp_delete) } else { SV *keysv = POPs; - hv = (HV*)POPs; + HV * const hv = (HV*)POPs; + SV *sv; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); else if (SvTYPE(hv) == SVt_PVAV) { @@ -3964,15 +3984,15 @@ PP(pp_delete) PP(pp_exists) { + dVAR; dSP; SV *tmpsv; HV *hv; if (PL_op->op_private & OPpEXISTS_SUB) { GV *gv; - CV *cv; - SV *sv = POPs; - cv = sv_2cv(sv, &hv, &gv, FALSE); + SV * const sv = POPs; + CV * const cv = sv_2cv(sv, &hv, &gv, 0); if (cv) RETPUSHYES; if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) @@ -3999,10 +4019,10 @@ PP(pp_exists) PP(pp_hslice) { - dSP; dMARK; dORIGMARK; - register HV *hv = (HV*)POPs; - register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); - bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE; + 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; bool other_magic = FALSE; if (localizing) { @@ -4020,7 +4040,7 @@ PP(pp_hslice) } while (++MARK <= SP) { - SV *keysv = *MARK; + SV * const keysv = *MARK; SV **svp; HE *he; bool preeminent = FALSE; @@ -4035,16 +4055,21 @@ PP(pp_hslice) 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; @@ -4061,7 +4086,7 @@ PP(pp_hslice) PP(pp_list) { - dSP; dMARK; + dVAR; dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ @@ -4074,21 +4099,20 @@ PP(pp_list) PP(pp_lslice) { + dVAR; dSP; - SV **lastrelem = PL_stack_sp; - SV **lastlelem = PL_stack_base + POPMARK; - SV **firstlelem = PL_stack_base + POPMARK + 1; - register SV **firstrelem = lastlelem + 1; - I32 arybase = PL_curcop->cop_arybase; - I32 lval = PL_op->op_flags & OPf_MOD; - I32 is_something_there = lval; - - register I32 max = lastrelem - lastlelem; + 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 = CopARYBASE_get(PL_curcop); + I32 is_something_there = FALSE; + + register const I32 max = lastrelem - lastlelem; register SV **lelem; - register I32 ix; if (GIMME != G_ARRAY) { - ix = SvIVx(*lastlelem); + I32 ix = SvIVx(*lastlelem); if (ix < 0) ix += max; else @@ -4107,7 +4131,7 @@ PP(pp_lslice) } for (lelem = firstlelem; lelem <= lastlelem; lelem++) { - ix = SvIVx(*lelem); + I32 ix = SvIVx(*lelem); if (ix < 0) ix += max; else @@ -4129,22 +4153,23 @@ PP(pp_lslice) PP(pp_anonlist) { - dSP; dMARK; dORIGMARK; - I32 items = SP - MARK; - SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); + dVAR; dSP; dMARK; dORIGMARK; + const I32 items = SP - MARK; + 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* hv = (HV*)sv_2mortal((SV*)newHV()); + dVAR; dSP; dMARK; dORIGMARK; + HV* const hv = newHV(); while (MARK < SP) { - SV* key = *++MARK; - SV *val = NEWSV(46, 0); + SV * const key = *++MARK; + SV * const val = newSV(0); if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_MISC)) @@ -4152,7 +4177,8 @@ PP(pp_anonhash) (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; } @@ -4168,10 +4194,9 @@ PP(pp_splice) I32 newlen; I32 after; I32 diff; - SV **tmparyval = 0; - MAGIC *mg; + const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); - if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { + if (mg) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -4189,7 +4214,7 @@ PP(pp_splice) 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) { @@ -4229,13 +4254,14 @@ PP(pp_splice) /* make new elements SVs now: avoid problems if they're from the array */ for (dst = MARK, i = newlen; i; i--) { - SV *h = *dst; + SV * const h = *dst; *dst++ = newSVsv(h); } if (diff < 0) { /* shrinking the area */ + SV **tmparyval = NULL; if (newlen) { - New(451, tmparyval, newlen, SV*); /* so remember insertion */ + Newx(tmparyval, newlen, SV*); /* so remember insertion */ Copy(MARK, tmparyval, newlen, SV*); } @@ -4272,7 +4298,7 @@ PP(pp_splice) *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 { @@ -4294,22 +4320,21 @@ PP(pp_splice) } } else { /* no, expanding (or same) */ + SV** tmparyval = NULL; if (length) { - New(452, tmparyval, length, SV*); /* so remember deletion */ + 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; } @@ -4343,7 +4368,6 @@ PP(pp_splice) dst++; } } - Safefree(tmparyval); } MARK += length - 1; } @@ -4354,10 +4378,10 @@ PP(pp_splice) while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } - Safefree(tmparyval); } else *MARK = &PL_sv_undef; + Safefree(tmparyval); } SP = MARK; RETURN; @@ -4366,11 +4390,10 @@ PP(pp_splice) PP(pp_push) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register AV *ary = (AV*)*++MARK; - register SV *sv = &PL_sv_undef; - MAGIC *mg; + register AV * const ary = (AV*)*++MARK; + const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); - if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { + if (mg) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -4378,40 +4401,30 @@ PP(pp_push) call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; + SP = ORIGMARK; + PUSHi( AvFILL(ary) + 1 ); } else { - /* Why no pre-extend of ary here ? */ for (++MARK; MARK <= SP; MARK++) { - sv = NEWSV(51, 0); + SV * const sv = newSV(0); if (*MARK) sv_setsv(sv, *MARK); - av_push(ary, sv); + av_store(ary, AvFILLp(ary)+1, sv); } + SP = ORIGMARK; + PUSHi( AvFILLp(ary) + 1 ); } - SP = ORIGMARK; - PUSHi( AvFILL(ary) + 1 ); - RETURN; -} - -PP(pp_pop) -{ - dSP; - AV *av = (AV*)POPs; - SV *sv = av_pop(av); - if (AvREAL(av)) - (void)sv_2mortal(sv); - PUSHs(sv); RETURN; } PP(pp_shift) { + dVAR; dSP; - AV *av = (AV*)POPs; - SV *sv = av_shift(av); + AV * const av = (AV*)POPs; + 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); @@ -4422,11 +4435,9 @@ PP(pp_unshift) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; - register SV *sv; - register I32 i = 0; - MAGIC *mg; + const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); - if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { + if (mg) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -4436,9 +4447,10 @@ PP(pp_unshift) SPAGAIN; } else { + register I32 i = 0; av_unshift(ary, SP - MARK); while (MARK < SP) { - sv = newSVsv(*++MARK); + SV * const sv = newSVsv(*++MARK); (void)av_store(ary, i++, sv); } } @@ -4449,14 +4461,13 @@ PP(pp_unshift) PP(pp_reverse) { - dSP; dMARK; - register SV *tmp; - SV **oldsp = SP; + dVAR; dSP; dMARK; + SV ** const oldsp = SP; if (GIMME == G_ARRAY) { MARK++; while (MARK < SP) { - tmp = *MARK; + register SV * const tmp = *MARK; *MARK++ = *SP; *SP-- = tmp; } @@ -4469,7 +4480,7 @@ PP(pp_reverse) register I32 tmp; dTARGET; STRLEN len; - I32 padoff_du; + PADOFFSET padoff_du; SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) @@ -4478,13 +4489,14 @@ PP(pp_reverse) 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) { if (DO_UTF8(TARG)) { /* first reverse each character */ U8* s = (U8*)SvPVX(TARG); - U8* send = (U8*)(s + len); + const U8* send = (U8*)(s + len); while (s < send) { if (UTF8_IS_INVARIANT(*s)) { s++; @@ -4525,28 +4537,27 @@ PP(pp_split) dVAR; dSP; dTARG; AV *ary; register IV limit = POPi; /* note, negative is forever */ - SV *sv = POPs; + SV * const sv = POPs; STRLEN len; register const char *s = SvPV_const(sv, len); - bool do_utf8 = DO_UTF8(sv); + const bool do_utf8 = DO_UTF8(sv); const char *strend = s + len; register PMOP *pm; register REGEXP *rx; 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; - I32 i; const char *orig; - I32 origlimit = limit; + const I32 origlimit = limit; I32 realarray = 0; I32 base; const I32 gimme = GIMME_V; 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*); @@ -4572,7 +4583,7 @@ PP(pp_split) 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; @@ -4585,6 +4596,7 @@ PP(pp_split) } else { if (!AvREAL(ary)) { + I32 i; AvREAL_on(ary); AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) @@ -4598,7 +4610,11 @@ PP(pp_split) 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++; } @@ -4616,10 +4632,23 @@ PP(pp_split) 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; @@ -4630,17 +4659,29 @@ PP(pp_split) (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) { - /*SUPPRESS 530*/ - for (m = s; m < strend && *m != '\n'; m++) ; + for (m = s; m < strend && *m != '\n'; m++) + ; m++; if (m >= strend) break; @@ -4653,20 +4694,19 @@ PP(pp_split) 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)) { - int tail = (rx->reganch & RE_INTUIT_TAIL); - SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); - - len = rx->minlen; - if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { - STRLEN n_a; - char c = *SvPV(csv, n_a); + 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->minlenret; + if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) { + const char c = *SvPV_nolen_const(csv); while (--limit) { - /*SUPPRESS 530*/ - for (m = s; m < strend && *m != c; m++) ; + for (m = s; m < strend && *m != c; m++) + ; if (m >= strend) break; dstr = newSVpvn(s, m-s); @@ -4707,11 +4747,12 @@ PP(pp_split) maxiters += slen * rx->nparens; while (s < strend && --limit) { + I32 rex_return; PUTBACK; - i = 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 (i == 0) + if (rex_return == 0) break; TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { @@ -4729,6 +4770,7 @@ PP(pp_split) (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { + I32 i; for (i = 1; i <= (I32)rx->nparens; i++) { s = rx->startp[i] + orig; m = rx->endp[i] + orig; @@ -4758,7 +4800,7 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - STRLEN l = strend - s; + const STRLEN l = strend - s; dstr = newSVpvn(s, l); if (make_mortal) sv_2mortal(dstr); @@ -4800,6 +4842,7 @@ PP(pp_split) LEAVE; SPAGAIN; if (gimme == G_ARRAY) { + I32 i; /* EXTEND should not be needed - we just popped them */ EXTEND(SP, iters); for (i=0; i < iters; i++) { @@ -4822,6 +4865,7 @@ PP(pp_split) PP(pp_lock) { + dVAR; dSP; dTOPss; SV *retsv = sv; @@ -4834,9 +4878,12 @@ PP(pp_lock) RETURN; } -PP(pp_threadsv) + +PP(unimplemented_op) { - DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); + dVAR; + DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op), + PL_op->op_type); } /*