X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=757b4f09843faf90ba9916d3552f5a84598b992d;hb=2655a377318baf22d2b1bf2d113f47ce1c4af14d;hp=0ddfefed6bbf6dad47f985a56799e75a9099783a;hpb=dc65699314ca1b70eb400580819ad6d85895755d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 0ddfefe..757b4f0 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,6 @@ /* pp.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -519,7 +519,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 +776,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 +877,98 @@ 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; + } + } + SP--; + SETn( result ); + RETURN; + } + } + } + } + float_it: +#endif + { + dPOPTOPnnrl; + SETn( Perl_pow( left, right) ); + RETURN; } } @@ -1006,7 +1094,7 @@ PP(pp_divide) { dSP; dATARGET; tryAMAGICbin(div,opASSIGN); /* Only try to do UV divide first - if ((SLOPPYDIVIDE is true) or + if ((SLOPPYDIVIDE is true) or (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large to preserve)) The assumption is that it is better to use floating point divide @@ -1389,7 +1477,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) @@ -2258,7 +2346,7 @@ PP(pp_complement) while (tmps < send) { UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); tmps += UTF8SKIP(tmps); - result = uvchr_to_utf8(result, ~c); + result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY); } *result = '\0'; result -= targlen; @@ -2702,7 +2790,7 @@ PP(pp_int) # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) # ifdef HAS_MODFL_POW32_BUG /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */ - { + { NV offset = Perl_modf(value, &value); (void)Perl_modf(offset, &offset); value += offset; @@ -2791,8 +2879,18 @@ PP(pp_hex) STRLEN len; NV result_nv; UV result_uv; + SV* sv = POPs; - tmps = (SvPVx(POPs, len)); + tmps = (SvPVx(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); @@ -2811,8 +2909,18 @@ PP(pp_oct) STRLEN len; NV result_nv; UV result_uv; + SV* sv = POPs; - tmps = (SvPVx(POPs, len)); + tmps = (SvPVx(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); + } while (*tmps && len && isSPACE(*tmps)) tmps++, len--; if (*tmps == '0') @@ -2936,7 +3044,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 { @@ -2972,7 +3080,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 ? */ @@ -3127,14 +3235,14 @@ 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)); - + RETURN; } @@ -3148,7 +3256,7 @@ PP(pp_chr) if (value > 255 && !IN_BYTES) { SvGROW(TARG, UNISKIP(value)+1); - tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value); + tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); @@ -3164,7 +3272,7 @@ PP(pp_chr) *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; } @@ -3177,26 +3285,22 @@ PP(pp_crypt) STRLEN n_a; STRLEN len; char *tmps = SvPV(left, len); - char *t = 0; + if (DO_UTF8(left)) { - /* If Unicode take the crypt() of the low 8 bits - * of the characters of the string. */ - char *s = tmps; - char *send = tmps + len; - STRLEN i = 0; - Newz(688, t, len, char); - while (s < send) { - t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF; - s += UTF8SKIP(s); - } - tmps = t; + /* If Unicode, try to downgrade. + * If not possible, croak. + * Yes, we made this up. */ + SV* tsv = sv_2mortal(newSVsv(left)); + + SvUTF8_on(tsv); + sv_utf8_downgrade(tsv, FALSE); + tmps = SvPVX(tsv); } # ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); # endif - Safefree(t); #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); @@ -3334,8 +3438,10 @@ PP(pp_uc) SETs(TARG); } else { + STRLEN nchar = utf8_length(s, s + len); + (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); + SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; @@ -3401,8 +3507,10 @@ PP(pp_lc) SETs(TARG); } else { + STRLEN nchar = utf8_length(s, s + len); + (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); + SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; @@ -3578,7 +3686,17 @@ PP(pp_each) EXTEND(SP, 2); if (entry) { - PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ + SV* sv = hv_iterkeysv(entry); + if (HvUTF8KEYS((SV*)hash) && !DO_UTF8(sv)) { + STRLEN len, i; + char* s = SvPV(sv, len); + for (i = 0; i < len && NATIVE_IS_INVARIANT(s[i]); i++); + if (i < len) { + sv = newSVsv(sv); + sv_utf8_upgrade(sv); + } + } + PUSHs(sv); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { SV *val; PUTBACK; @@ -3847,7 +3965,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 hash assignment"); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -3906,8 +4024,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 */ @@ -4544,14 +4665,7 @@ PP(pp_lock) dSP; dTOPss; SV *retsv = sv; -#ifdef USE_5005THREADS - sv_lock(sv); -#endif /* USE_5005THREADS */ -#ifdef USE_ITHREADS - shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv); - if(ssv) - Perl_sharedsv_lock(aTHX_ ssv); -#endif /* USE_ITHREADS */ + SvLOCK(sv); if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { retsv = refto(retsv);