X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=b3a6eedea7d867669e7f8c9b8dce1e1bbfa17b03;hb=c7de4c6618c94666be04e5ac0b48fa329c22560b;hp=a0729e972a26e00067e9bf4932453c722b5ee70e;hpb=6fdb5f96460dfb69dad11dd7111abf8ec1263bb1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index a0729e9..b3a6eed 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. @@ -15,6 +15,9 @@ #include "EXTERN.h" #define PERL_IN_PP_C #include "perl.h" +#include "keywords.h" + +#include "reentr.h" /* variations on pp_null */ @@ -61,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; } @@ -365,6 +368,8 @@ PP(pp_prototype) I32 oa; char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ + if (code == -KEY_chop || code == -KEY_chomp) + goto set; while (i < MAXO) { /* The slow way. */ if (strEQ(s + 6, PL_op_name[i]) || strEQ(s + 6, PL_op_desc[i])) @@ -516,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); } @@ -759,8 +764,7 @@ PP(pp_undef) if (!sv) RETPUSHUNDEF; - if (SvTHINKFIRST(sv)) - sv_force_normal(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -773,7 +777,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: @@ -815,10 +819,10 @@ PP(pp_undef) PP(pp_predec) { dSP; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MIN) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -832,11 +836,11 @@ PP(pp_predec) PP(pp_postinc) { dSP; dTARGET; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MAX) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -853,11 +857,11 @@ PP(pp_postinc) PP(pp_postdec) { dSP; dTARGET; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MIN) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -874,10 +878,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; } } @@ -1003,7 +1097,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 @@ -1074,9 +1168,13 @@ PP(pp_divide) #else /* Otherwise we only attempt it if either or both operands would not be preserved by an NV. If both fit in NVs - we fall through to the NV divide code below. */ - && ((left > ((UV)1 << NV_PRESERVES_UV_BITS)) - || (right > ((UV)1 << NV_PRESERVES_UV_BITS))) + we fall through to the NV divide code below. However, + as left >= right to ensure integer result here, we know that + we can skip the test on the right operand - right big + enough not to be preserved can't get here unless left is + also too big. */ + + && (left > ((UV)1 << NV_PRESERVES_UV_BITS)) #endif ) { /* Integer division can't overflow, but it can be imprecise. */ @@ -1090,7 +1188,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 ); @@ -1116,8 +1214,8 @@ PP(pp_modulo) { UV left = 0; UV right = 0; - bool left_neg; - bool right_neg; + bool left_neg = FALSE; + bool right_neg = FALSE; bool use_double = FALSE; bool dright_valid = FALSE; NV dright = 0.0; @@ -1252,10 +1350,33 @@ PP(pp_repeat) MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { +#if 0 + /* This code was intended to fix 20010809.028: + + $x = 'abcd'; + for (($x =~ /./g) x 2) { + print chop; # "abcdabcd" expected as output. + } + + * but that change (#11635) broke this code: + + $x = [("foo")x2]; # only one "foo" ended up in the anonlist. + + * I can't think of a better fix that doesn't introduce + * an efficiency hit by copying the SVs. The stack isn't + * refcounted, and mortalisation obviously doesn't + * Do The Right Thing when the stack has more than + * one pointer to the same mortal value. + * .robin. + */ if (*SP) { *SP = sv_2mortal(newSVsv(*SP)); SvREADONLY_on(*SP); } +#else + if (*SP) + SvTEMP_off((*SP)); +#endif SP--; } MARK++; @@ -1359,7 +1480,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) @@ -1494,11 +1615,6 @@ PP(pp_lt) RETURN; } auv = SvUVX(TOPs); - if (auv >= (UV) IV_MAX) { - /* As (b) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_no); - RETURN; - } SETs(boolSV(auv < (UV)biv)); RETURN; } @@ -1515,17 +1631,22 @@ PP(pp_lt) } buv = SvUVX(TOPs); SP--; - if (buv > (UV) IV_MAX) { - /* As (a) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_yes); - RETURN; - } SETs(boolSV((UV)aiv < buv)); RETURN; } } } #endif +#ifndef NV_PRESERVES_UV +#ifdef PERL_PRESERVE_IVUV + else +#endif + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); + RETURN; + } +#endif { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1572,11 +1693,6 @@ PP(pp_gt) RETURN; } auv = SvUVX(TOPs); - if (auv > (UV) IV_MAX) { - /* As (b) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_yes); - RETURN; - } SETs(boolSV(auv > (UV)biv)); RETURN; } @@ -1593,17 +1709,22 @@ PP(pp_gt) } buv = SvUVX(TOPs); SP--; - if (buv >= (UV) IV_MAX) { - /* As (a) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_no); - RETURN; - } SETs(boolSV((UV)aiv > buv)); RETURN; } } } #endif +#ifndef NV_PRESERVES_UV +#ifdef PERL_PRESERVE_IVUV + else +#endif + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); + RETURN; + } +#endif { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1650,11 +1771,6 @@ PP(pp_le) RETURN; } auv = SvUVX(TOPs); - if (auv > (UV) IV_MAX) { - /* As (b) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_no); - RETURN; - } SETs(boolSV(auv <= (UV)biv)); RETURN; } @@ -1671,17 +1787,22 @@ PP(pp_le) } buv = SvUVX(TOPs); SP--; - if (buv >= (UV) IV_MAX) { - /* As (a) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_yes); - RETURN; - } SETs(boolSV((UV)aiv <= buv)); RETURN; } } } #endif +#ifndef NV_PRESERVES_UV +#ifdef PERL_PRESERVE_IVUV + else +#endif + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); + RETURN; + } +#endif { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1728,11 +1849,6 @@ PP(pp_ge) RETURN; } auv = SvUVX(TOPs); - if (auv >= (UV) IV_MAX) { - /* As (b) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_yes); - RETURN; - } SETs(boolSV(auv >= (UV)biv)); RETURN; } @@ -1749,17 +1865,22 @@ PP(pp_ge) } buv = SvUVX(TOPs); SP--; - if (buv > (UV) IV_MAX) { - /* As (a) is an IV, it cannot be > IV_MAX */ - SETs(&PL_sv_no); - RETURN; - } SETs(boolSV((UV)aiv >= buv)); RETURN; } } } #endif +#ifndef NV_PRESERVES_UV +#ifdef PERL_PRESERVE_IVUV + else +#endif + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); + RETURN; + } +#endif { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1772,7 +1893,8 @@ PP(pp_ne) dSP; tryAMAGICbinSET(ne,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && SvROK(TOPm1s)) { - SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s))); + SP--; + SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); RETURN; } #endif @@ -1784,19 +1906,16 @@ PP(pp_ne) bool auvok = SvUOK(TOPm1s); bool buvok = SvUOK(TOPs); - if (!auvok && !buvok) { /* ## IV <=> IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); - - SP--; - SETs(boolSV(aiv != biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV != UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); + if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ + /* Casting IV to UV before comparison isn't going to matter + on 2s complement. On 1s complement or sign&magnitude + (if we have any of them) it could make negative zero + 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); - SP--; SETs(boolSV(auv != buv)); RETURN; } @@ -1825,11 +1944,6 @@ PP(pp_ne) } uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ } - /* we know iv is >= 0 */ - if (uv > (UV) IV_MAX) { - SETs(&PL_sv_yes); - RETURN; - } SETs(boolSV((UV)iv != uv)); RETURN; } @@ -1848,7 +1962,9 @@ PP(pp_ncmp) dSP; dTARGET; tryAMAGICbin(ncmp,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && SvROK(TOPm1s)) { - SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s))); + UV right = PTR2UV(SvRV(POPs)); + UV left = PTR2UV(SvRV(TOPs)); + SETi((left > right) - (left < right)); RETURN; } #endif @@ -1891,10 +2007,7 @@ PP(pp_ncmp) value = 1; } else { leftuv = SvUVX(TOPm1s); - if (leftuv > (UV) IV_MAX) { - /* As (b) is an IV, it cannot be > IV_MAX */ - value = 1; - } else if (leftuv > (UV)rightiv) { + if (leftuv > (UV)rightiv) { value = 1; } else if (leftuv < (UV)rightiv) { value = -1; @@ -1912,12 +2025,9 @@ PP(pp_ncmp) value = -1; } else { rightuv = SvUVX(TOPs); - if (rightuv > (UV) IV_MAX) { - /* As (a) is an IV, it cannot be > IV_MAX */ - value = -1; - } else if (leftiv > (UV)rightuv) { + if ((UV)leftiv > rightuv) { value = 1; - } else if (leftiv < (UV)rightuv) { + } else if ((UV)leftiv < rightuv) { value = -1; } else { value = 0; @@ -2157,15 +2267,22 @@ PP(pp_negate) sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } - else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) { - sv_setpvn(TARG, "-", 1); - sv_catsv(TARG, sv); + else if (DO_UTF8(sv)) { + SvIV_please(sv); + if (SvIOK(sv)) + goto oops_its_an_int; + if (SvNOK(sv)) + sv_setnv(TARG, -SvNV(sv)); + else { + sv_setpvn(TARG, "-", 1); + sv_catsv(TARG, sv); + } } else { - SvIV_please(sv); - if (SvIOK(sv)) - goto oops_its_an_int; - sv_setnv(TARG, -SvNV(sv)); + SvIV_please(sv); + if (SvIOK(sv)) + goto oops_its_an_int; + sv_setnv(TARG, -SvNV(sv)); } SETTARG; } @@ -2232,7 +2349,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; @@ -2566,7 +2683,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); @@ -2601,7 +2718,7 @@ PP(pp_log) value = POPn; if (value <= 0.0) { SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take log of %g", value); + DIE(aTHX_ "Can't take log of %"NVgf, value); } value = Perl_log(value); XPUSHn(value); @@ -2617,7 +2734,7 @@ PP(pp_sqrt) value = POPn; if (value < 0.0) { SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take sqrt of %g", value); + DIE(aTHX_ "Can't take sqrt of %"NVgf, value); } value = Perl_sqrt(value); XPUSHn(value); @@ -2625,6 +2742,28 @@ PP(pp_sqrt) } } +/* + * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2. + * These need to be revisited when a newer toolchain becomes available. + */ +#if defined(__sparc64__) && defined(__GNUC__) +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96) +# undef SPARC64_MODF_WORKAROUND +# define SPARC64_MODF_WORKAROUND 1 +# endif +#endif + +#if defined(SPARC64_MODF_WORKAROUND) +static NV +sparc64_workaround_modf(NV theVal, NV *theIntRes) +{ + NV res, ret; + ret = Perl_modf(theVal, &res); + *theIntRes = res; + return ret; +} +#endif + PP(pp_int) { dSP; dTARGET; tryAMAGICun(int); @@ -2648,21 +2787,25 @@ PP(pp_int) if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); } else { -#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) -# ifdef HAS_MODFL_POW32_BUG +#if defined(SPARC64_MODF_WORKAROUND) + (void)sparc64_workaround_modf(value, &value); +#else +# 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; } -# else +# else (void)Perl_modf(value, &value); -# endif -#else +# endif +# else double tmp = (double)value; (void)Perl_modf(tmp, &tmp); value = (NV)tmp; +# endif #endif SETn(value); } @@ -2739,8 +2882,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); @@ -2759,8 +2912,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') @@ -2884,7 +3047,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 { @@ -2920,7 +3083,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 ? */ @@ -3001,7 +3164,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))) @@ -3042,7 +3205,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))) @@ -3073,8 +3236,18 @@ PP(pp_ord) SV *argsv = POPs; STRLEN len; U8 *s = (U8*)SvPVx(argsv, len); + SV *tmpsv; + + if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { + tmpsv = sv_2mortal(newSVsv(argsv)); + s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); + argsv = tmpsv; + } + + XPUSHu(DO_UTF8(argsv) ? + utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) : + (*s & 0xff)); - XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff)); RETURN; } @@ -3087,8 +3260,8 @@ PP(pp_chr) (void)SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { - SvGROW(TARG, UNISKIP(value)+1); - tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value); + 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'; (void)SvPOK_only(TARG); @@ -3100,46 +3273,45 @@ 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) + sv_recode_to_utf8(TARG, PL_encoding); XPUSHs(TARG); RETURN; } PP(pp_crypt) { - dSP; dTARGET; dPOPTOPssrl; - STRLEN n_a; + dSP; dTARGET; #ifdef HAS_CRYPT + dPOPTOPssrl; + 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; - } -#ifdef FCRYPT + /* 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 +# else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); -#endif - Safefree(t); +# endif + SETs(TARG); + RETURN; #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif - SETs(TARG); - RETURN; } PP(pp_ucfirst) @@ -3150,7 +3322,7 @@ PP(pp_ucfirst) STRLEN slen; if (DO_UTF8(sv)) { - U8 tmpbuf[UTF8_MAXLEN*2+1]; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; STRLEN ulen; STRLEN tculen; @@ -3205,7 +3377,7 @@ PP(pp_lcfirst) if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN*2+1]; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; U8 *tend; UV uv; @@ -3214,7 +3386,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); @@ -3262,7 +3434,7 @@ PP(pp_uc) STRLEN ulen; register U8 *d; U8 *send; - U8 tmpbuf[UTF8_MAXLEN*2+1]; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; s = (U8*)SvPV(sv,len); if (!len) { @@ -3271,8 +3443,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; @@ -3329,7 +3503,7 @@ PP(pp_lc) STRLEN ulen; register U8 *d; U8 *send; - U8 tmpbuf[UTF8_MAXLEN*2+1]; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; s = (U8*)SvPV(sv,len); if (!len) { @@ -3338,8 +3512,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; @@ -3506,22 +3682,21 @@ PP(pp_each) HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; - I32 realhv = (SvTYPE(hash) == SVt_PVHV); PUTBACK; /* might clobber stack_sp */ - entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); + entry = hv_iternext(hash); SPAGAIN; 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; /* might clobber stack_sp */ - val = realhv ? - hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); + val = hv_iterval(hash, entry); SPAGAIN; PUSHs(val); } @@ -3561,19 +3736,13 @@ PP(pp_delete) *MARK = sv ? sv : &PL_sv_undef; } } - else if (hvtype == SVt_PVAV) { - if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ - while (++MARK <= SP) { - sv = av_delete((AV*)hv, SvIV(*MARK), discard); - *MARK = sv ? sv : &PL_sv_undef; - } - } - else { /* pseudo-hash element */ - while (++MARK <= SP) { - sv = avhv_delete_ent((AV*)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); + *MARK = sv ? sv : &PL_sv_undef; + } + } } else DIE(aTHX_ "Not a HASH reference"); @@ -3594,7 +3763,7 @@ PP(pp_delete) if (PL_op->op_flags & OPf_SPECIAL) sv = av_delete((AV*)hv, SvIV(keysv), discard); else - sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); + DIE(aTHX_ "panic: avhv_delete no longer supported"); } else DIE(aTHX_ "Not a HASH reference"); @@ -3634,8 +3803,6 @@ PP(pp_exists) if (av_exists((AV*)hv, SvIV(tmpsv))) RETPUSHYES; } - else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ - RETPUSHYES; } else { DIE(aTHX_ "Not a HASH reference"); @@ -3648,42 +3815,53 @@ PP(pp_hslice) dSP; dMARK; dORIGMARK; 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)); + } + + while (++MARK <= SP) { + SV *keysv = *MARK; + SV **svp; + HE *he; + bool preeminent = FALSE; + + if (localizing) { + preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : + hv_exists_ent(hv, keysv, 0); + } - if (!realhv && PL_op->op_private & OPpLVAL_INTRO) - DIE(aTHX_ "Can't localize pseudo-hash element"); + he = hv_fetch_ent(hv, keysv, lval, 0); + svp = he ? &HeVAL(he) : 0; - 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); - if (realhv) { - HE *he = hv_fetch_ent(hv, keysv, lval, 0); - svp = he ? &HeVAL(he) : 0; - } - else { - svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); - } - if (lval) { - if (!svp || *svp == &PL_sv_undef) { - STRLEN n_a; - DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); - } - if (PL_op->op_private & OPpLVAL_INTRO) { - if (preeminent) - save_helem(hv, keysv, svp); - else { - STRLEN keylen; - char *key = SvPV(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), keylen); - } + if (lval) { + if (!svp || *svp == &PL_sv_undef) { + STRLEN n_a; + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + } + if (localizing) { + if (preeminent) + save_helem(hv, keysv, svp); + else { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + SAVEDELETE(hv, savepvn(key,keylen), keylen); } - } - *MARK = svp ? *svp : &PL_sv_undef; - } + } + } + *MARK = svp ? *svp : &PL_sv_undef; } if (GIMME != G_ARRAY) { MARK = ORIGMARK; @@ -3784,7 +3962,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; @@ -3843,8 +4021,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 */ @@ -4127,7 +4308,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } } } @@ -4137,7 +4318,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } (void)SvPOK_only_UTF8(TARG); } @@ -4367,7 +4548,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; @@ -4409,8 +4590,12 @@ PP(pp_split) iters++; } else if (!origlimit) { - while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) - iters--, SP--; + while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { + if (TOPs && !make_mortal) + sv_2mortal(TOPs); + iters--; + SP--; + } } if (realarray) { @@ -4481,14 +4666,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);