X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=6136d21e6030d71786825e849882b23764460a83;hb=ce5e94717f361c3fd6b9b0fb704412d30f3ccf66;hp=304fced051a8fef05ebf87ca498584f0d1ced100;hpb=97aff369fa5580e7a888d4fa4c86be74ab000409;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 304fced..6136d21 100644 --- a/pp.c +++ b/pp.c @@ -138,7 +138,7 @@ PP(pp_rv2gv) 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) @@ -163,7 +163,7 @@ PP(pp_rv2gv) STRLEN len; SV * const namesv = PAD_SV(cUNOP->op_targ); const char * const name = SvPV(namesv, len); - gv = (GV*)NEWSV(0,0); + gv = (GV*)newSV(0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { @@ -172,7 +172,7 @@ PP(pp_rv2gv) } 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); @@ -234,6 +234,8 @@ PP(pp_rv2sv) case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: DIE(aTHX_ "Not a SCALAR reference"); } } @@ -298,7 +300,7 @@ PP(pp_av2arylen) 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, NULL, 0); } @@ -320,7 +322,7 @@ PP(pp_pos) 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; @@ -332,7 +334,7 @@ PP(pp_pos) 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; } } @@ -487,19 +489,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); @@ -607,7 +609,7 @@ PP(pp_gelem) break; case 'S': if (strEQ(second_letter, "CALAR")) - tmpRef = GvSV(gv); + tmpRef = GvSVn(gv); break; } } @@ -637,13 +639,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)) { + /* 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; @@ -771,7 +782,7 @@ PP(pp_undef) 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 */ @@ -788,7 +799,7 @@ PP(pp_undef) gp_free((GV*)sv); Newxz(gp, 1, GP); GvGP(sv) = gp_ref(gp); - GvSV(sv) = NEWSV(72,0); + GvSV(sv) = newSV(0); GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); @@ -987,7 +998,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); @@ -1046,6 +1097,7 @@ PP(pp_multiply) bhigh = blow >> (4 * sizeof (UV)); blow &= botmask; if (ahigh && bhigh) { + /*EMPTY*/; /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 which is overflow. Drop to NVs below. */ } else if (!ahigh && !bhigh) { @@ -1702,8 +1754,15 @@ 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; } } @@ -1778,8 +1837,15 @@ 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; } } @@ -1854,8 +1920,15 @@ 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; } } @@ -1930,8 +2003,15 @@ 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; } } @@ -1999,8 +2079,15 @@ 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; } } @@ -2205,50 +2292,32 @@ PP(pp_bit_and) } } -PP(pp_bit_xor) -{ - dVAR; dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); - { - dPOPTOPssrl; - SvGETMAGIC(left); - SvGETMAGIC(right); - if (SvNIOKp(left) || SvNIOKp(right)) { - if (PL_op->op_private & HINT_INTEGER) { - const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); - SETi(i); - } - else { - const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); - SETu(u); - } - } - else { - do_vop(PL_op->op_type, TARG, left, right); - SETTARG; - } - RETURN; - } -} - PP(pp_bit_or) { - dVAR; dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + dVAR; dSP; dATARGET; + const int op_type = PL_op->op_type; + + tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN); { dPOPTOPssrl; SvGETMAGIC(left); SvGETMAGIC(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right); - SETi(i); + const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); + const IV r = SvIV_nomg(right); + const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETi(result); } else { - const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right); - SETu(u); + const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); + const UV r = SvUV_nomg(right); + const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETu(result); } } else { - do_vop(PL_op->op_type, TARG, left, right); + do_vop(op_type, TARG, left, right); SETTARG; } RETURN; @@ -2360,16 +2429,16 @@ PP(pp_complement) if (SvUTF8(TARG)) { /* Calculate exact length, let's not estimate. */ STRLEN targlen = 0; - U8 *result; - U8 *send; STRLEN l; UV nchar = 0; UV nwide = 0; + U8 * const send = tmps + len; + U8 * const origtmps = tmps; + const UV utf8flags = UTF8_ALLOW_ANYUV; - send = tmps + len; while (tmps < send) { - const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); - tmps += UTF8SKIP(tmps); + const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); + tmps += l; targlen += UNISKIP(~c); nchar++; if (c > 0xff) @@ -2377,33 +2446,39 @@ PP(pp_complement) } /* Now rewind strings and write them. */ - tmps -= len; + tmps = origtmps; if (nwide) { - Newxz(result, targlen + 1, U8); + U8 *result; + U8 *p; + + Newx(result, targlen + 1, U8); + p = result; while (tmps < send) { - const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); - tmps += UTF8SKIP(tmps); - result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY); + const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); + tmps += l; + p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY); } - *result = '\0'; - result -= targlen; - sv_setpvn(TARG, (char*)result, targlen); + *p = '\0'; + sv_usepvn_flags(TARG, (char*)result, targlen, + SV_HAS_TRAILING_NUL); SvUTF8_on(TARG); } else { - Newxz(result, nchar + 1, U8); + U8 *result; + U8 *p; + + Newx(result, nchar + 1, U8); + p = result; while (tmps < send) { - const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY); - tmps += UTF8SKIP(tmps); - *result++ = ~c; + const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); + tmps += l; + *p++ = ~c; } - *result = '\0'; - result -= nchar; - sv_setpvn(TARG, (char*)result, nchar); + *p = '\0'; + sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL); SvUTF8_off(TARG); } - Safefree(result); SETs(TARG); RETURN; } @@ -2441,12 +2516,19 @@ PP(pp_i_multiply) PP(pp_i_divide) { + 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; } @@ -2461,7 +2543,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; } } @@ -2478,7 +2564,11 @@ PP(pp_i_modulo_1) 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; } } @@ -2519,7 +2609,11 @@ 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; } } @@ -2643,20 +2737,43 @@ PP(pp_atan2) PP(pp_sin) { - dVAR; dSP; dTARGET; tryAMAGICun(sin); - { - const NV value = POPn; - XPUSHn(Perl_sin(value)); - RETURN; + dVAR; dSP; dTARGET; + int amg_type = sin_amg; + const char *neg_report = NULL; + NV (*func)(NV) = Perl_sin; + const int op_type = PL_op->op_type; + + switch (op_type) { + case OP_COS: + amg_type = cos_amg; + func = Perl_cos; + break; + case OP_EXP: + amg_type = exp_amg; + func = Perl_exp; + break; + case OP_LOG: + amg_type = log_amg; + func = Perl_log; + neg_report = "log"; + break; + case OP_SQRT: + amg_type = sqrt_amg; + func = Perl_sqrt; + neg_report = "sqrt"; + break; } -} -PP(pp_cos) -{ - dVAR; dSP; dTARGET; tryAMAGICun(cos); + tryAMAGICun_var(amg_type); { const NV value = POPn; - XPUSHn(Perl_cos(value)); + if (neg_report) { + if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { + SET_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value); + } + } + XPUSHn(func(value)); RETURN; } } @@ -2705,46 +2822,6 @@ PP(pp_srand) RETPUSHYES; } -PP(pp_exp) -{ - dVAR; dSP; dTARGET; tryAMAGICun(exp); - { - NV value; - value = POPn; - value = Perl_exp(value); - XPUSHn(value); - RETURN; - } -} - -PP(pp_log) -{ - dVAR; dSP; dTARGET; tryAMAGICun(log); - { - const NV value = POPn; - if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take log of %"NVgf, value); - } - XPUSHn(Perl_log(value)); - RETURN; - } -} - -PP(pp_sqrt) -{ - dVAR; dSP; dTARGET; tryAMAGICun(sqrt); - { - const NV value = POPn; - if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take sqrt of %"NVgf, value); - } - XPUSHn(Perl_sqrt(value)); - RETURN; - } -} - PP(pp_int) { dVAR; dSP; dTARGET; tryAMAGICun(int); @@ -2821,37 +2898,6 @@ PP(pp_abs) RETURN; } - -PP(pp_hex) -{ - dVAR; dSP; dTARGET; - const char *tmps; - I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; - STRLEN len; - NV result_nv; - UV result_uv; - SV* const sv = POPs; - - tmps = (SvPV_const(sv, len)); - if (DO_UTF8(sv)) { - /* If Unicode, try to downgrade - * If not possible, croak. */ - SV* const tsv = sv_2mortal(newSVsv(sv)); - - SvUTF8_on(tsv); - sv_utf8_downgrade(tsv, FALSE); - tmps = SvPV_const(tsv, len); - } - result_uv = grok_hex (tmps, &len, &flags, &result_nv); - if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { - XPUSHn(result_nv); - } - else { - XPUSHu(result_uv); - } - RETURN; -} - PP(pp_oct) { dVAR; dSP; dTARGET; @@ -2872,12 +2918,17 @@ PP(pp_oct) sv_utf8_downgrade(tsv, FALSE); tmps = SvPV_const(tsv, len); } + if (PL_op->op_type == OP_HEX) + goto hex; + while (*tmps && len && isSPACE(*tmps)) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x') + if (*tmps == 'x') { + hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); + } else if (*tmps == 'b') result_uv = grok_bin (tmps, &len, &flags, &result_nv); else @@ -2918,7 +2969,7 @@ 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 = NULL; STRLEN repl_len; @@ -3046,7 +3097,9 @@ PP(pp_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 */ @@ -3063,7 +3116,7 @@ PP(pp_substr) 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; @@ -3094,7 +3147,7 @@ PP(pp_vec) 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; @@ -3111,128 +3164,96 @@ PP(pp_index) SV *big; SV *little; SV *temp = NULL; + STRLEN biglen; + STRLEN llen = 0; I32 offset; I32 retval; const char *tmps; const char *tmps2; - STRLEN biglen; - const I32 arybase = PL_curcop->cop_arybase; - int big_utf8; - int little_utf8; - - if (MAXARG < 3) - offset = 0; - else + const I32 arybase = CopARYBASE_get(PL_curcop); + bool big_utf8; + bool little_utf8; + const bool is_index = PL_op->op_type == OP_INDEX; + + if (MAXARG >= 3) { + /* arybase is in characters, like offset, so combine prior to the + UTF-8 to bytes calculation. */ offset = POPi - arybase; + } little = POPs; big = POPs; big_utf8 = DO_UTF8(big); little_utf8 = DO_UTF8(little); if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ - SV * const bytes = little_utf8 ? big : little; - STRLEN len; - const char * const p = SvPV_const(bytes, len); - - temp = newSVpvn(p, len); + if (little_utf8 && !PL_encoding) { + /* Well, maybe instead we might be able to downgrade the small + string? */ + STRLEN little_len; + const U8 * const little_pv = (U8*) SvPV_const(little, little_len); + char * const pv = (char*)bytes_from_utf8(little_pv, &little_len, + &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); + /* 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, little_len); } else { - sv_utf8_upgrade(temp); - } - if (little_utf8) { - big = temp; - big_utf8 = TRUE; - } else { - little = temp; - } - } - if (big_utf8 && offset > 0) - sv_pos_u2b(big, &offset, 0); - tmps = SvPV_const(big, biglen); - if (offset < 0) - offset = 0; - else if (offset > (I32)biglen) - offset = biglen; - if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, - (unsigned char*)tmps + biglen, little, 0))) - retval = -1; - else - retval = tmps2 - tmps; - if (retval > 0 && big_utf8) - sv_pos_b2u(big, &retval); - if (temp) - SvREFCNT_dec(temp); - PUSHi(retval + arybase); - RETURN; -} - -PP(pp_rindex) -{ - dVAR; dSP; dTARGET; - SV *big; - SV *little; - SV *temp = NULL; - STRLEN blen; - STRLEN llen; - I32 offset; - I32 retval; - const char *tmps; - const char *tmps2; - const I32 arybase = PL_curcop->cop_arybase; - int big_utf8; - int little_utf8; - - if (MAXARG >= 3) - offset = POPi; - little = POPs; - big = POPs; - big_utf8 = DO_UTF8(big); - little_utf8 = DO_UTF8(little); - if (big_utf8 ^ little_utf8) { - /* One needs to be upgraded. */ - SV * const bytes = little_utf8 ? big : little; - STRLEN len; - const char *p = SvPV_const(bytes, len); + SV * const bytes = little_utf8 ? big : little; + STRLEN len; + const char * const p = SvPV_const(bytes, len); - temp = newSVpvn(p, 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 (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; + } } } - tmps2 = SvPV_const(little, llen); - tmps = SvPV_const(big, blen); + /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */ + tmps2 = is_index ? NULL : SvPV_const(little, llen); + tmps = SvPV_const(big, biglen); 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; + 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 (!(tmps2 = is_index + ? fbm_instr((unsigned char*)tmps + offset, + (unsigned char*)tmps + biglen, little, 0) + : rninstr(tmps, tmps + offset, + tmps2, tmps2 + llen))) retval = -1; - else + else { retval = tmps2 - tmps; - if (retval > 0 && big_utf8) - sv_pos_b2u(big, &retval); + if (retval > 0 && big_utf8) + sv_pos_b2u(big, &retval); + } if (temp) SvREFCNT_dec(temp); + fail: PUSHi(retval + arybase); RETURN; } @@ -3410,7 +3431,8 @@ PP(pp_ucfirst) if (slen > ulen) sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); - SETs(TARG); + sv = TARG; + SETs(sv); } else { s = (U8*)SvPV_force_nomg(sv, slen); @@ -3462,7 +3484,8 @@ PP(pp_uc) if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); - SETs(TARG); + sv = TARG; + SETs(sv); } else { STRLEN min = len + 1; @@ -3495,7 +3518,8 @@ PP(pp_uc) *d = '\0'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); - SETs(TARG); + sv = TARG; + SETs(sv); } } else { @@ -3547,7 +3571,8 @@ PP(pp_lc) if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); - SETs(TARG); + sv = TARG; + SETs(sv); } else { STRLEN min = len + 1; @@ -3563,6 +3588,7 @@ PP(pp_lc) #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ if (uv == GREEK_CAPITAL_LETTER_SIGMA) { + /*EMPTY*/ /* * Now if the sigma is NOT followed by * /$ignorable_sequence$cased_letter/; @@ -3599,7 +3625,8 @@ PP(pp_lc) *d = '\0'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); - SETs(TARG); + sv = TARG; + SETs(sv); } } else { @@ -3692,7 +3719,7 @@ PP(pp_aslice) register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); if (SvTYPE(av) == SVt_PVAV) { - const I32 arybase = PL_curcop->cop_arybase; + const I32 arybase = CopARYBASE_get(PL_curcop); if (lval && PL_op->op_private & OPpLVAL_INTRO) { register SV **svp; I32 max = -1; @@ -3898,13 +3925,18 @@ PP(pp_hslice) DIE(aTHX_ PL_no_helem_sv, 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) ? -keylen : keylen); + } + } } } *MARK = svp ? *svp : &PL_sv_undef; @@ -3940,7 +3972,7 @@ PP(pp_lslice) SV ** const lastlelem = PL_stack_base + POPMARK; SV ** const firstlelem = PL_stack_base + POPMARK + 1; register SV ** const firstrelem = lastlelem + 1; - const I32 arybase = PL_curcop->cop_arybase; + const I32 arybase = CopARYBASE_get(PL_curcop); I32 is_something_there = PL_op->op_flags & OPf_MOD; register const I32 max = lastrelem - lastlelem; @@ -4003,7 +4035,7 @@ PP(pp_anonhash) while (MARK < SP) { SV * const key = *++MARK; - SV * const val = NEWSV(46, 0); + SV * const val = newSV(0); if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_MISC)) @@ -4027,7 +4059,6 @@ PP(pp_splice) I32 newlen; I32 after; I32 diff; - SV **tmparyval = NULL; const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); if (mg) { @@ -4048,7 +4079,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) { @@ -4093,6 +4124,7 @@ PP(pp_splice) } if (diff < 0) { /* shrinking the area */ + SV **tmparyval; if (newlen) { Newx(tmparyval, newlen, SV*); /* so remember insertion */ Copy(MARK, tmparyval, newlen, SV*); @@ -4153,15 +4185,14 @@ PP(pp_splice) } } else { /* no, expanding (or same) */ + SV** tmparyval = NULL; if (length) { Newx(tmparyval, length, SV*); /* so remember deletion */ Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); } if (diff > 0) { /* expanding */ - /* push up or down? */ - if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { if (offset) { src = AvARRAY(ary); @@ -4202,7 +4233,6 @@ PP(pp_splice) dst++; } } - Safefree(tmparyval); } MARK += length - 1; } @@ -4213,10 +4243,10 @@ PP(pp_splice) while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } - Safefree(tmparyval); } else *MARK = &PL_sv_undef; + Safefree(tmparyval); } SP = MARK; RETURN; @@ -4241,7 +4271,7 @@ PP(pp_push) } else { for (++MARK; MARK <= SP; MARK++) { - SV * const sv = NEWSV(51, 0); + SV * const sv = newSV(0); if (*MARK) sv_setsv(sv, *MARK); av_store(ary, AvFILLp(ary)+1, sv); @@ -4252,27 +4282,14 @@ PP(pp_push) RETURN; } -PP(pp_pop) -{ - dVAR; - dSP; - AV * const av = (AV*)POPs; - SV * const sv = av_pop(av); - if (AvREAL(av)) - (void)sv_2mortal(sv); - PUSHs(sv); - RETURN; -} - PP(pp_shift) { dVAR; dSP; AV * const av = (AV*)POPs; - SV * const sv = av_shift(av); + SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); EXTEND(SP, 1); - if (!sv) - RETPUSHUNDEF; + assert (sv); if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); @@ -4328,7 +4345,7 @@ PP(pp_reverse) register I32 tmp; dTARGET; STRLEN len; - I32 padoff_du; + PADOFFSET padoff_du; SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) @@ -4337,7 +4354,8 @@ 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) { @@ -4404,7 +4422,7 @@ PP(pp_split) 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*);