X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=7fa9c06933a7c8d9de35e6d30a017628e00a479f;hb=5eb9fe8fe9c9104d4fe0d9127fe7389780f8a479;hp=be6d7233a2457d51fe467b28bd4a9606bca6734f;hpb=3ec562b0bffb8b8b48df56ef7460b59729c19345;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index be6d723..7fa9c06 100644 --- a/pp.c +++ b/pp.c @@ -17,6 +17,8 @@ #include "perl.h" #include "keywords.h" +#include "reentr.h" + /* variations on pp_null */ /* XXX I can't imagine anyone who doesn't have this actually _needs_ @@ -62,7 +64,7 @@ PP(pp_padav) EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { U32 i; - for (i=0; i < maxarg; i++) { + for (i=0; i < (U32)maxarg; i++) { SV **svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } @@ -519,7 +521,7 @@ PP(pp_bless) Perl_croak(aTHX_ "Attempt to bless into a reference"); ptr = SvPV(ssv,len); if (ckWARN(WARN_MISC) && len == 0) - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -776,7 +778,7 @@ PP(pp_undef) break; case SVt_PVCV: if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) - Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined", + Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: @@ -877,10 +879,100 @@ PP(pp_postdec) PP(pp_pow) { dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + /* ** is implemented with pow. pow is floating point. Perl programmers + write 2 ** 31 and expect it to be 2147483648 + pow never made any guarantee to deliver a result to 53 (or whatever) + bits of accuracy. Which is unfortunate, as perl programmers expect it + to, and on some platforms (eg Irix with long doubles) it doesn't in + a very visible case. (2 ** 31, which a regression test uses) + So we'll implement power-of-2 ** +ve integer with multiplies, to avoid + these problems. */ { - dPOPTOPnnrl; - SETn( Perl_pow( left, right) ); - RETURN; + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool baseuok = SvUOK(TOPm1s); + 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 { + IV iv = SvIVX(TOPs); + if (iv >= 0) { + power = iv; + } else { + goto float_it; /* Can't do negative powers this way. */ + } + } + /* now we have integer ** positive integer. + foo & (foo - 1) is zero only for a power of 2. */ + if (!(baseuv & (baseuv - 1))) { + /* We are raising power-of-2 to postive integer. + The logic here will work for any base (even non-integer + bases) but it can be less accurate than + pow (base,power) or exp (power * log (base)) when the + intermediate values start to spill out of the mantissa. + With powers of 2 we know this can't happen. + And powers of 2 are the favourite thing for perl + programmers to notice ** not doing what they mean. */ + NV result = 1.0; + NV base = baseuok ? baseuv : -(NV)baseuv; + int n = 0; + + /* The logic is this. + x ** n === x ** m1 * x ** m2 where n = m1 + m2 + so as 42 is 32 + 8 + 2 + x ** 42 can be written as + x ** 32 * x ** 8 * x ** 2 + I can calculate x ** 2, x ** 4, x ** 8 etc trivially: + x ** 2n is x ** n * x ** n + So I loop round, squaring x each time + (x, x ** 2, x ** 4, x ** 8) and multiply the result + by the x-value whenever that bit is set in the power. + To finish as soon as possible I zero bits in the power + when I've done them, so that power becomes zero when + I clear the last bit (no more to do), and the loop + terminates. */ + 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; + } + } + SP--; + SETn( result ); + RETURN; + } + } + } + } + float_it: +#endif + { + dPOPTOPnnrl; + SETn( Perl_pow( left, right) ); + RETURN; } } @@ -1097,7 +1189,7 @@ PP(pp_divide) } /* 2s complement assumption */ if (result <= (UV)IV_MIN) - SETi( -result ); + SETi( -(IV)result ); else { /* It's exact but too negative for IV. */ SETn( -(NV)result ); @@ -1389,7 +1481,7 @@ PP(pp_subtract) buv = (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, - else "IV" now, independant of how it came in. + else "IV" now, independent of how it came in. if a, b represents positive, A, B negative, a maps to -A etc a - b => (a - b) A - b => -(a + b) @@ -2592,7 +2684,7 @@ S_seed(pTHX) u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY - gettimeofday(&when,(struct timezone *) 0); + PerlProc_gettimeofday(&when,NULL); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else (void)time(&when); @@ -2956,7 +3048,7 @@ PP(pp_substr) if (lvalue || repl) Perl_croak(aTHX_ "substr outside of string"); if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); + Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); RETPUSHUNDEF; } else { @@ -2992,7 +3084,7 @@ PP(pp_substr) STRLEN n_a; SvPV_force(sv,n_a); if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ WARN_SUBSTR, + Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ @@ -3073,7 +3165,7 @@ PP(pp_index) sv_pos_u2b(big, &offset, 0); if (offset < 0) offset = 0; - else if (offset > biglen) + else if (offset > (I32)biglen) offset = biglen; if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, (unsigned char*)tmps + biglen, little, 0))) @@ -3114,7 +3206,7 @@ PP(pp_rindex) } if (offset < 0) offset = 0; - else if (offset > blen) + else if (offset > (I32)blen) offset = blen; if (!(tmps2 = rninstr(tmps, tmps + offset, tmps2, tmps2 + llen))) @@ -3147,13 +3239,15 @@ PP(pp_ord) U8 *s = (U8*)SvPVx(argsv, len); SV *tmpsv; - if (PL_encoding && !DO_UTF8(argsv)) { + if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { tmpsv = sv_2mortal(newSVsv(argsv)); - s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding); + s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); argsv = tmpsv; } - XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff)); + XPUSHu(DO_UTF8(argsv) ? + utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) : + (*s & 0xff)); RETURN; } @@ -3167,7 +3261,7 @@ PP(pp_chr) (void)SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { - SvGROW(TARG, UNISKIP(value)+1); + SvGROW(TARG, (STRLEN)UNISKIP(value)+1); tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; @@ -3180,11 +3274,11 @@ PP(pp_chr) SvGROW(TARG,2); SvCUR_set(TARG, 1); tmps = SvPVX(TARG); - *tmps++ = value; + *tmps++ = (char)value; *tmps = '\0'; (void)SvPOK_only(TARG); if (PL_encoding) - Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding); + sv_recode_to_utf8(TARG, PL_encoding); XPUSHs(TARG); RETURN; } @@ -3213,12 +3307,12 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); # endif + SETs(TARG); + RETURN; #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif - SETs(TARG); - RETURN; } PP(pp_ucfirst) @@ -3293,7 +3387,7 @@ PP(pp_lcfirst) tend = uvchr_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { + if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -3350,8 +3444,10 @@ PP(pp_uc) SETs(TARG); } else { + STRLEN nchar = utf8_length(s, s + len); + (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * UTF8_MAXLEN_UCLC) + 1); + SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; @@ -3417,8 +3513,10 @@ PP(pp_lc) SETs(TARG); } else { + STRLEN nchar = utf8_length(s, s + len); + (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * UTF8_MAXLEN_UCLC) + 1); + SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; @@ -3594,7 +3692,8 @@ PP(pp_each) EXTEND(SP, 2); if (entry) { - PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ + SV* sv = hv_iterkeysv(entry); + PUSHs(sv); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { SV *val; PUTBACK; @@ -3728,17 +3827,38 @@ PP(pp_hslice) register HV *hv = (HV*)POPs; register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 realhv = (SvTYPE(hv) == SVt_PVHV); + bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE; + bool other_magic = FALSE; + + if (localizing) { + MAGIC *mg; + HV *stash; + + other_magic = mg_find((SV*)hv, PERL_MAGIC_env) || + ((mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE)); + } - if (!realhv && PL_op->op_private & OPpLVAL_INTRO) + if (!realhv && localizing) DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; - I32 preeminent = SvRMAGICAL(hv) ? 1 : - realhv ? hv_exists_ent(hv, keysv, 0) - : avhv_exists_ent((AV*)hv, keysv, 0); + bool preeminent = FALSE; + + if (localizing) { + preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : + realhv ? hv_exists_ent(hv, keysv, 0) + : avhv_exists_ent((AV*)hv, keysv, 0); + } + if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; @@ -3751,7 +3871,7 @@ PP(pp_hslice) STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } - if (PL_op->op_private & OPpLVAL_INTRO) { + if (localizing) { if (preeminent) save_helem(hv, keysv, svp); else { @@ -3863,7 +3983,7 @@ PP(pp_anonhash) if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash"); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -3922,8 +4042,11 @@ PP(pp_splice) offset = 0; length = AvMAX(ary) + 1; } - if (offset > AvFILLp(ary) + 1) + if (offset > AvFILLp(ary) + 1) { + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); offset = AvFILLp(ary) + 1; + } after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ length += after; /* offset+length now in array */ @@ -4206,7 +4329,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } } } @@ -4216,7 +4339,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } (void)SvPOK_only_UTF8(TARG); } @@ -4446,7 +4569,7 @@ PP(pp_split) (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { - for (i = 1; i <= rx->nparens; i++) { + for (i = 1; i <= (I32)rx->nparens; i++) { s = rx->startp[i] + orig; m = rx->endp[i] + orig;