X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/864dbfa3ca8032ef66f7aa86961933b19b962357..f2b5be74500fffd3dc232fca7cb3c51bc3b9abf9:/pp.c?ds=sidebyside diff --git a/pp.c b/pp.c index fed72bb..c7fd585 100644 --- a/pp.c +++ b/pp.c @@ -186,12 +186,12 @@ PP(pp_padhv) RETURN; gimme = GIMME_V; if (gimme == G_ARRAY) { - RETURNOP(do_kv(ARGS)); + RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); if (HvFILL((HV*)TARG)) - sv_setpvf(sv, "%ld/%ld", + Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); else sv_setiv(sv, 0); @@ -202,7 +202,7 @@ PP(pp_padhv) PP(pp_padany) { - DIE("NOT IMPL LINE %d",__LINE__); + DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); } /* Translations. */ @@ -224,7 +224,7 @@ PP(pp_rv2gv) sv = (SV*) gv; } else if (SvTYPE(sv) != SVt_PVGV) - DIE("Not a GLOB reference"); + DIE(aTHX_ "Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { @@ -257,9 +257,9 @@ PP(pp_rv2gv) } if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "a symbol"); + DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -272,7 +272,7 @@ PP(pp_rv2gv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a symbol"); + DIE(aTHX_ PL_no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } @@ -296,7 +296,7 @@ PP(pp_rv2sv) case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: - DIE("Not a SCALAR reference"); + DIE(aTHX_ "Not a SCALAR reference"); } } else { @@ -313,9 +313,9 @@ PP(pp_rv2sv) if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "a SCALAR"); + DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -328,7 +328,7 @@ PP(pp_rv2sv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a SCALAR"); + DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); } } @@ -467,7 +467,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - croak("Can't find an opnumber for \"%s\"", s+6); + Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -516,7 +516,7 @@ PP(pp_refgen) } STATIC SV* -refto(pTHX_ SV *sv) +S_refto(pTHX_ SV *sv) { SV* rv; @@ -573,7 +573,7 @@ PP(pp_bless) STRLEN len; char *ptr = SvPV(ssv,len); if (ckWARN(WARN_UNSAFE) && len == 0) - warner(WARN_UNSAFE, + Perl_warner(aTHX_ WARN_UNSAFE, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -689,7 +689,7 @@ PP(pp_study) snext = PL_screamnext; if (!sfirst || !snext) - DIE("do_study: out of memory"); + DIE(aTHX_ "do_study: out of memory"); for (ch = 256; ch; --ch) *sfirst++ = -1; @@ -820,7 +820,7 @@ PP(pp_undef) break; case SVt_PVCV: if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv)) - warner(WARN_UNSAFE, "Constant subroutine %s undefined", + Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: @@ -863,7 +863,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -880,7 +880,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -901,7 +901,7 @@ PP(pp_postdec) { djSP; dTARGET; if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -943,15 +943,15 @@ PP(pp_divide) djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; - double value; + NV value; if (right == 0.0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { IV k; - if ((double)I_V(left) == left && - (double)I_V(right) == right && + if ((NV)I_V(left) == left && + (NV)I_V(right) == right && (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; } @@ -976,8 +976,8 @@ PP(pp_modulo) bool left_neg; bool right_neg; bool use_double = 0; - double dright; - double dleft; + NV dright; + NV dleft; if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); @@ -1007,7 +1007,7 @@ PP(pp_modulo) } if (use_double) { - double dans; + NV dans; #if 1 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ @@ -1032,9 +1032,9 @@ PP(pp_modulo) dleft = floor(dleft + 0.5); if (!dright) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); - dans = fmod(dleft, dright); + dans = Perl_fmod(dleft, dright); if ((left_neg != right_neg) && dans) dans = dright - dans; if (right_neg) @@ -1046,7 +1046,7 @@ PP(pp_modulo) do_uv: if (!right) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); ans = left % right; if ((left_neg != right_neg) && ans) @@ -1057,7 +1057,7 @@ PP(pp_modulo) if (ans <= ~((UV)IV_MAX)+1) sv_setiv(TARG, ~ans+1); else - sv_setnv(TARG, -(double)ans); + sv_setnv(TARG, -(NV)ans); } else sv_setuv(TARG, ans); @@ -1493,7 +1493,7 @@ PP(pp_i_divide) { dPOPiv; if (value == 0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); value = POPi / value; PUSHi( value ); RETURN; @@ -1506,7 +1506,7 @@ PP(pp_i_modulo) { dPOPTOPiirl; if (!right) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); SETi( left % right ); RETURN; } @@ -1624,7 +1624,7 @@ PP(pp_atan2) djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; - SETn(atan2(left, right)); + SETn(Perl_atan2(left, right)); RETURN; } } @@ -1633,9 +1633,9 @@ PP(pp_sin) { djSP; dTARGET; tryAMAGICun(sin); { - double value; + NV value; value = POPn; - value = sin(value); + value = Perl_sin(value); XPUSHn(value); RETURN; } @@ -1645,9 +1645,9 @@ PP(pp_cos) { djSP; dTARGET; tryAMAGICun(cos); { - double value; + NV value; value = POPn; - value = cos(value); + value = Perl_cos(value); XPUSHn(value); RETURN; } @@ -1671,7 +1671,7 @@ extern double drand48 (void); PP(pp_rand) { djSP; dTARGET; - double value; + NV value; if (MAXARG < 1) value = 1.0; else @@ -1702,7 +1702,7 @@ PP(pp_srand) } STATIC U32 -seed(pTHX) +S_seed(pTHX) { /* * This is really just a quick hack which grabs various garbage @@ -1787,9 +1787,9 @@ PP(pp_exp) { djSP; dTARGET; tryAMAGICun(exp); { - double value; + NV value; value = POPn; - value = exp(value); + value = Perl_exp(value); XPUSHn(value); RETURN; } @@ -1799,13 +1799,13 @@ PP(pp_log) { djSP; dTARGET; tryAMAGICun(log); { - double value; + NV value; value = POPn; if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take log of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take log of %g", value); } - value = log(value); + value = Perl_log(value); XPUSHn(value); RETURN; } @@ -1815,13 +1815,13 @@ PP(pp_sqrt) { djSP; dTARGET; tryAMAGICun(sqrt); { - double value; + NV value; value = POPn; if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take sqrt of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take sqrt of %g", value); } - value = sqrt(value); + value = Perl_sqrt(value); XPUSHn(value); RETURN; } @@ -1831,7 +1831,7 @@ PP(pp_int) { djSP; dTARGET; { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { @@ -1840,9 +1840,9 @@ PP(pp_int) } else { if (value >= 0.0) - (void)modf(value, &value); + (void)Perl_modf(value, &value); else { - (void)modf(-value, &value); + (void)Perl_modf(-value, &value); value = -value; } iv = I_V(value); @@ -1859,7 +1859,7 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && @@ -2000,7 +2000,7 @@ PP(pp_substr) } if (fail < 0) { if (ckWARN(WARN_SUBSTR) || lvalue || repl) - warner(WARN_SUBSTR, "substr outside of string"); + Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { @@ -2014,7 +2014,7 @@ PP(pp_substr) STRLEN n_a; SvPV_force(sv,n_a); if (ckWARN(WARN_SUBSTR)) - warner(WARN_SUBSTR, + Perl_warner(aTHX_ WARN_SUBSTR, "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ @@ -2204,12 +2204,6 @@ PP(pp_rindex) PP(pp_sprintf) { djSP; dMARK; dORIGMARK; dTARGET; -#ifdef USE_LOCALE_NUMERIC - if (PL_op->op_private & OPpLOCALE) - SET_NUMERIC_LOCAL(); - else - SET_NUMERIC_STANDARD(); -#endif do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; @@ -2274,7 +2268,7 @@ PP(pp_crypt) sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else - DIE( + DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); @@ -2314,26 +2308,27 @@ PP(pp_ucfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toUPPER_LC(*s); + } + else + *s = toUPPER(*s); } - else - *s = toUPPER(*s); } - + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2370,27 +2365,28 @@ PP(pp_lcfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toLOWER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else - *s = toLOWER(*s); + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toLOWER_LC(*s); + } + else + *s = toLOWER(*s); + } + SETs(sv); } - - SETs(sv); + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2411,56 +2407,57 @@ PP(pp_uc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toUPPER_utf8( s )); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toUPPER_utf8( s )); + s += UTF8SKIP(s); + } } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; - - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else { - for (; s < send; s++) - *s = toUPPER(*s); + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; + + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toUPPER_LC(*s); + } + else { + for (; s < send; s++) + *s = toUPPER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2481,56 +2478,58 @@ PP(pp_lc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toLOWER_utf8(s)); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toLOWER_utf8(s)); + s += UTF8SKIP(s); + } } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toLOWER_LC(*s); - } - else { - for (; s < send; s++) - *s = toLOWER(*s); + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toLOWER_LC(*s); + } + else { + for (; s < send; s++) + *s = toLOWER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2578,6 +2577,8 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETs(TARG); + if (SvSMAGICAL(TARG)) + mg_set(TARG); RETURN; } @@ -2611,7 +2612,7 @@ PP(pp_aslice) svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) - DIE(PL_no_aelem, elem); + DIE(aTHX_ PL_no_aelem, elem); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } @@ -2630,7 +2631,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2645,12 +2646,13 @@ PP(pp_each) if (entry) { PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { + SV *val; PUTBACK; /* might clobber stack_sp */ - sv_setsv(TARG, realhv ? - hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); + val = realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); SPAGAIN; - PUSHs(TARG); + PUSHs(val); } } else if (gimme == G_SCALAR) @@ -2661,12 +2663,12 @@ PP(pp_each) PP(pp_values) { - return do_kv(ARGS); + return do_kv(); } PP(pp_keys) { - return do_kv(ARGS); + return do_kv(); } PP(pp_delete) @@ -2686,7 +2688,7 @@ PP(pp_delete) if (hvtype == SVt_PVHV) sv = hv_delete_ent(hv, *MARK, discard, 0); else - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); *MARK = sv ? sv : &PL_sv_undef; } if (discard) @@ -2703,7 +2705,7 @@ PP(pp_delete) if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); else - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); if (!sv) sv = &PL_sv_undef; if (!discard) @@ -2726,7 +2728,7 @@ PP(pp_exists) RETPUSHYES; } else { - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); } RETPUSHNO; } @@ -2739,7 +2741,7 @@ PP(pp_hslice) I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) - DIE("Can't localize pseudo-hash element"); + DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { @@ -2755,7 +2757,7 @@ PP(pp_hslice) if (lval) { if (!svp || *svp == &PL_sv_undef) { STRLEN n_a; - DIE(PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); @@ -2862,7 +2864,7 @@ PP(pp_anonhash) if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Odd number of elements in hash assignment"); + Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -2905,7 +2907,7 @@ PP(pp_splice) else offset -= PL_curcop->cop_arybase; if (offset < 0) - DIE(PL_no_aelem, i); + DIE(aTHX_ PL_no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) { @@ -3198,7 +3200,9 @@ PP(pp_reverse) s += UTF8SKIP(s); down = (char*)(s - 1); if (s > send || !((*down & 0xc0) == 0x80)) { - warn("Malformed UTF-8 character"); + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, + "Malformed UTF-8 character"); break; } while (down > up) { @@ -3225,7 +3229,7 @@ PP(pp_reverse) } STATIC SV * -mul128(pTHX_ SV *sv, U8 m) +S_mul128(pTHX_ SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); @@ -3300,7 +3304,7 @@ PP(pp_unpack) double adouble; I32 checksum = 0; register U32 culong; - double cdouble; + NV cdouble; int commas = 0; #ifdef PERL_NATINT_PACK int natint; /* native integer */ @@ -3336,7 +3340,7 @@ PP(pp_unpack) pat++; } else - croak("'!' allowed only after types %s", natstr); + Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); } if (pat >= patend) len = 1; @@ -3353,10 +3357,10 @@ PP(pp_unpack) len = (datumtype != '@'); switch(datumtype) { default: - croak("Invalid type in unpack: '%c'", (int)datumtype); + Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3369,17 +3373,17 @@ PP(pp_unpack) break; case '@': if (len > strend - strbeg) - DIE("@ outside of string"); + DIE(aTHX_ "@ outside of string"); s = strbeg + len; break; case 'X': if (len > s - strbeg) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); s -= len; break; case 'x': if (len > strend - s) - DIE("x outside of string"); + DIE(aTHX_ "x outside of string"); s += len; break; case 'A': @@ -3564,7 +3568,7 @@ PP(pp_unpack) auint = utf8_to_uv((U8*)s, &along); s += along; if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3724,7 +3728,7 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) - cdouble += (double)aint; + cdouble += (NV)aint; else culong += aint; } @@ -3775,7 +3779,7 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3814,7 +3818,7 @@ PP(pp_unpack) COPYNN(s, &along, sizeof(long)); s += sizeof(long); if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3830,7 +3834,7 @@ PP(pp_unpack) #endif s += SIZE32; if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3884,7 +3888,7 @@ PP(pp_unpack) COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3904,7 +3908,7 @@ PP(pp_unpack) aulong = vtohl(aulong); #endif if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3984,7 +3988,7 @@ PP(pp_unpack) char *t; STRLEN n_a; - sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -4002,7 +4006,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - croak("Unterminated compressed integer"); + Perl_croak(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4036,7 +4040,7 @@ PP(pp_unpack) if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else - sv_setnv(sv, (double)aquad); + sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } break; @@ -4057,7 +4061,7 @@ PP(pp_unpack) if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else - sv_setnv(sv, (double)auquad); + sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -4082,7 +4086,7 @@ PP(pp_unpack) Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); - sv_setnv(sv, (double)afloat); + sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } @@ -4106,7 +4110,7 @@ PP(pp_unpack) Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); - sv_setnv(sv, (double)adouble); + sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } @@ -4174,7 +4178,7 @@ PP(pp_unpack) sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > 32 && strchr("iIlLNU", datumtype)) ) { - double trouble; + NV trouble; adouble = 1.0; while (checksum >= 16) { @@ -4190,7 +4194,7 @@ PP(pp_unpack) along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; - cdouble = modf(cdouble / adouble, &trouble) * adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { @@ -4210,7 +4214,7 @@ PP(pp_unpack) } STATIC void -doencodes(pTHX_ register SV *sv, register char *s, register I32 len) +S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) { char hunk[5]; @@ -4238,7 +4242,7 @@ doencodes(pTHX_ register SV *sv, register char *s, register I32 len) } STATIC SV * -is_an_int(pTHX_ char *s, STRLEN l) +S_is_an_int(pTHX_ char *s, STRLEN l) { STRLEN n_a; SV *result = newSVpvn(s, l); @@ -4288,7 +4292,7 @@ is_an_int(pTHX_ char *s, STRLEN l) /* pnum must be '\0' terminated */ STATIC int -div128(pTHX_ SV *pnum, bool *done) +S_div128(pTHX_ SV *pnum, bool *done) { STRLEN len; char *s = SvPV(pnum, len); @@ -4369,7 +4373,7 @@ PP(pp_pack) pat++; } else - croak("'!' allowed only after types %s", natstr); + Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4384,13 +4388,13 @@ PP(pp_pack) len = 1; switch(datumtype) { default: - croak("Invalid type in pack: '%c'", (int)datumtype); + Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': - DIE("%% may only be used in unpack"); + DIE(aTHX_ "%% may only be used in unpack"); case '@': len -= SvCUR(cat); if (len > 0) @@ -4402,7 +4406,7 @@ PP(pp_pack) case 'X': shrink: if (SvCUR(cat) < len) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); SvCUR(cat) -= len; *SvEND(cat) = '\0'; break; @@ -4667,10 +4671,10 @@ PP(pp_pack) case 'w': while (len-- > 0) { fromstr = NEXTFROM; - adouble = floor(SvNV(fromstr)); + adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - croak("Cannot compress negative numbers"); + Perl_croak(aTHX_ "Cannot compress negative numbers"); if ( #ifdef BW_BITS @@ -4704,7 +4708,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - croak("can compress only unsigned integer"); + Perl_croak(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4724,14 +4728,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - croak ("Cannot compress integer"); + Perl_croak(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else - croak("Cannot compress non integer"); + Perl_croak(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -4831,7 +4835,7 @@ PP(pp_pack) * gone. */ if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) - warner(WARN_UNSAFE, + Perl_warner(aTHX_ WARN_UNSAFE, "Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); @@ -4903,7 +4907,7 @@ PP(pp_split) pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE("panic: do_split"); + DIE(aTHX_ "panic: do_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && @@ -4997,17 +5001,19 @@ PP(pp_split) s = m; } } - else if (rx->check_substr && !rx->nparens + else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { - int tail = SvTAIL(rx->check_substr) != 0; + int tail = (rx->reganch & RE_INTUIT_TAIL); + SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); + char c; - i = SvCUR(rx->check_substr); - if (i == 1 && !tail) { - i = *SvPVX(rx->check_substr); + len = rx->minlen; + if (len == 1 && !tail) { + c = *SvPV(csv,len); while (--limit) { /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); @@ -5021,8 +5027,8 @@ PP(pp_split) else { #ifndef lint while (s < strend && --limit && - (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) ) + (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, + csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) #endif { dstr = NEWSV(31, m-s); @@ -5030,14 +5036,18 @@ PP(pp_split) if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); - s = m + i - tail; /* Fake \n at the end */ + s = m + len; /* Fake \n at the end */ } } } else { maxiters += (strend - s) * rx->nparens; - while (s < strend && --limit && - CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0)) + while (s < strend && --limit +/* && (!rx->check_substr + || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, + 0, NULL)))) +*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig, + 1 /* minend */, sv, NULL, 0)) { TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { @@ -5075,7 +5085,7 @@ PP(pp_split) LEAVE_SCOPE(oldsave); iters = (SP - PL_stack_base) - base; if (iters > maxiters) - DIE("Split loop"); + DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { @@ -5143,10 +5153,10 @@ Perl_unlock_condpair(pTHX_ void *svv) MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) - croak("panic: unlock_condpair unlocking non-mutex"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) - croak("panic: unlock_condpair unlocking mutex that we don't own"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", @@ -5177,7 +5187,7 @@ PP(pp_lock) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(unlock_condpair, sv); + SAVEDESTRUCTOR(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV @@ -5199,6 +5209,6 @@ PP(pp_threadsv) PUSHs(THREADSV(PL_op->op_targ)); RETURN; #else - DIE("tried to access per-thread data in non-threaded perl"); + DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); #endif /* USE_THREADS */ }