X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=2958fba4bf10290bde1e113b85514ad7900e4c88;hb=4522225b0b1dd6f5498ad893469cb9b2e20183b7;hp=e470d1c411e791b0a5241172549685291e6a4375;hpb=d9f424b23bb434af43f899daf2cb6cfe42fe6e1a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index e470d1c..2958fba 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,7 @@ /* pp.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -15,8 +16,9 @@ #include "EXTERN.h" #define PERL_IN_PP_C #include "perl.h" +#include "keywords.h" -/* variations on pp_null */ +#include "reentr.h" /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. @@ -26,6 +28,8 @@ extern Pid_t getpid (void); #endif +/* variations on pp_null */ + PP(pp_stub) { dSP; @@ -44,8 +48,9 @@ PP(pp_scalar) PP(pp_padav) { dSP; dTARGET; + I32 gimme; if (PL_op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PL_curpad[PL_op->op_targ]); + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); @@ -56,12 +61,13 @@ PP(pp_padav) PUSHs(TARG); RETURN; } - if (GIMME == G_ARRAY) { + gimme = GIMME_V; + if (gimme == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; 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; } @@ -71,7 +77,7 @@ PP(pp_padav) } SP += maxarg; } - else { + else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); I32 maxarg = AvFILL((AV*)TARG) + 1; sv_setiv(sv, maxarg); @@ -87,7 +93,7 @@ PP(pp_padhv) XPUSHs(TARG); if (PL_op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PL_curpad[PL_op->op_targ]); + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); if (PL_op->op_flags & OPf_REF) RETURN; else if (LVRET) { @@ -101,6 +107,9 @@ PP(pp_padhv) } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); + if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied)) + Perl_croak(aTHX_ "Can't provide tied hash usage; " + "use keys(%%hash) to test if empty"); if (HvFILL((HV*)TARG)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); @@ -156,7 +165,7 @@ PP(pp_rv2gv) GV *gv; if (cUNOP->op_targ) { STRLEN len; - SV *namesv = PL_curpad[cUNOP->op_targ]; + SV *namesv = PAD_SV(cUNOP->op_targ); name = SvPV(namesv, len); gv = (GV*)NEWSV(0,0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); @@ -206,6 +215,7 @@ PP(pp_rv2gv) PP(pp_rv2sv) { + GV *gv = Nullgv; dSP; dTOPss; if (SvROK(sv)) { @@ -221,9 +231,9 @@ PP(pp_rv2sv) } } else { - GV *gv = (GV*)sv; char *sym; STRLEN len; + gv = (GV*)sv; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -260,8 +270,14 @@ PP(pp_rv2sv) sv = GvSV(gv); } if (PL_op->op_flags & OPf_MOD) { - if (PL_op->op_private & OPpLVAL_INTRO) - sv = save_scalar((GV*)TOPs); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (cUNOP->op_first->op_type == OP_NULL) + sv = save_scalar((GV*)TOPs); + else if (gv) + sv = save_scalar(gv); + else + Perl_croak(aTHX_ PL_no_localize_ref); + } else if (PL_op->op_private & OPpDEREF) vivify_ref(sv, PL_op->op_private & OPpDEREF); } @@ -365,6 +381,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])) @@ -415,7 +433,7 @@ PP(pp_prototype) PP(pp_anoncode) { dSP; - CV* cv = (CV*)PL_curpad[PL_op->op_targ]; + CV* cv = (CV*)PAD_SV(PL_op->op_targ); if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); EXTEND(SP,1); @@ -516,7 +534,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); } @@ -550,8 +568,11 @@ PP(pp_gelem) tmpRef = (SV*)GvCVu(gv); break; case 'F': - if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ + if (strEQ(elem, "FILEHANDLE")) { + /* finally deprecated in 5.8.0 */ + deprecate("*glob{FILEHANDLE}"); tmpRef = (SV*)GvIOp(gv); + } else if (strEQ(elem, "FORMAT")) tmpRef = (SV*)GvFORM(gv); @@ -573,8 +594,12 @@ PP(pp_gelem) sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); break; case 'P': - if (strEQ(elem, "PACKAGE")) - sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + if (strEQ(elem, "PACKAGE")) { + if (HvNAME(GvSTASH(gv))) + sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + else + sv = newSVpv("__ANON__",0); + } break; case 'S': if (strEQ(elem, "SCALAR")) @@ -756,8 +781,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: @@ -770,7 +794,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: @@ -812,10 +836,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); @@ -829,11 +853,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); @@ -841,6 +865,7 @@ PP(pp_postinc) else sv_inc(TOPs); SvSETMAGIC(TOPs); + /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (!SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); @@ -850,11 +875,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); @@ -870,11 +895,134 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + dSP; dATARGET; +#ifdef PERL_PRESERVE_IVUV + bool is_int = 0; +#endif + tryAMAGICbin(pow,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + /* For integer to integer power, we do the calculation by hand wherever + we're sure it is safe; otherwise we call pow() and try to convert to + integer afterwards. */ { - 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. */ + is_int = 1; + + /* foo & (foo - 1) is zero only for a power of 2. */ + if (!(baseuv & (baseuv - 1))) { + /* We are raising power-of-2 to a positive 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; + + 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 ); + SvIV_please(TOPs); + RETURN; + } else { + register unsigned int highbit = 8 * sizeof(UV); + register unsigned int lowbit = 0; + register unsigned int diff; + bool odd_power = (bool)(power & 1); + while ((diff = (highbit - lowbit) >> 1)) { + if (baseuv & ~((1 << (lowbit + diff)) - 1)) + lowbit += diff; + else + highbit -= diff; + } + /* we now have baseuv < 2 ** highbit */ + if (power * highbit <= 8 * sizeof(UV)) { + /* result will definitely fit in UV, so use UV math + on same algorithm as above */ + register UV result = 1; + register UV base = baseuv; + register int n = 0; + for (; power; base *= base, n++) { + register UV bit = (UV)1 << (UV)n; + if (power & bit) { + result *= base; + power -= bit; + if (power == 0) break; + } + } + SP--; + if (baseuok || !odd_power) + /* answer is positive */ + SETu( result ); + else if (result <= (UV)IV_MAX) + /* answer negative, fits in IV */ + SETi( -(IV)result ); + else if (result == (UV)IV_MIN) + /* 2's complement assumption: special case IV_MIN */ + SETi( IV_MIN ); + else + /* answer negative, doesn't fit */ + SETn( -(NV)result ); + RETURN; + } + } + } + } + } + float_it: +#endif + { + dPOPTOPnnrl; + SETn( Perl_pow( left, right) ); +#ifdef PERL_PRESERVE_IVUV + if (is_int) + SvIV_please(TOPs); +#endif + RETURN; } } @@ -999,29 +1147,115 @@ PP(pp_multiply) PP(pp_divide) { dSP; dATARGET; tryAMAGICbin(div,opASSIGN); - { - dPOPPOPnnrl; - NV value; - if (right == 0.0) - DIE(aTHX_ "Illegal division by zero"); + /* Only try to do UV divide first + 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 + whenever possible, only doing integer divide first if we can't be sure. + If NV_PRESERVES_UV is true then we know at compile time that no UV + can be too large to preserve, so don't need to compile the code to + test the size of UVs. */ + #ifdef SLOPPYDIVIDE - /* insure that 20./5. == 4. */ - { - IV k; - 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; - } - else { - value = left / right; - } - } +# define PERL_TRY_UV_DIVIDE + /* ensure that 20./5. == 4. */ #else - value = left / right; +# ifdef PERL_PRESERVE_IVUV +# ifndef NV_PRESERVES_UV +# define PERL_TRY_UV_DIVIDE +# endif +# endif #endif - PUSHn( value ); - RETURN; + +#ifdef PERL_TRY_UV_DIVIDE + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool left_non_neg = SvUOK(TOPm1s); + bool right_non_neg = SvUOK(TOPs); + UV left; + UV right; + + if (right_non_neg) { + right = SvUVX(TOPs); + } + else { + IV biv = SvIVX(TOPs); + if (biv >= 0) { + right = biv; + right_non_neg = TRUE; /* effectively it's a UV now */ + } + else { + right = -biv; + } + } + /* historically undef()/0 gives a "Use of uninitialized value" + warning before dieing, hence this test goes here. + If it were immediately before the second SvIV_please, then + DIE() would be invoked before left was even inspected, so + no inpsection would give no warning. */ + if (right == 0) + DIE(aTHX_ "Illegal division by zero"); + + if (left_non_neg) { + left = SvUVX(TOPm1s); + } + else { + IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + left = aiv; + left_non_neg = TRUE; /* effectively it's a UV now */ + } + else { + left = -aiv; + } + } + + if (left >= right +#ifdef SLOPPYDIVIDE + /* For sloppy divide we always attempt integer division. */ +#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. 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. */ + UV result = left / right; + if (result * right == left) { + SP--; /* result is valid */ + if (left_non_neg == right_non_neg) { + /* signs identical, result is positive. */ + SETu( result ); + RETURN; + } + /* 2s complement assumption */ + if (result <= (UV)IV_MIN) + SETi( -(IV)result ); + else { + /* It's exact but too negative for IV. */ + SETn( -(NV)result ); + } + RETURN; + } /* tried integer divide but it was not an integer result */ + } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ + } /* left wasn't SvIOK */ + } /* right wasn't SvIOK */ +#endif /* PERL_TRY_UV_DIVIDE */ + { + dPOPPOPnnrl; + if (right == 0.0) + DIE(aTHX_ "Illegal division by zero"); + PUSHn( left / right ); + RETURN; } } @@ -1031,64 +1265,93 @@ PP(pp_modulo) { UV left = 0; UV right = 0; - bool left_neg; - bool right_neg; - bool use_double = 0; + bool left_neg = FALSE; + bool right_neg = FALSE; + bool use_double = FALSE; + bool dright_valid = FALSE; NV dright = 0.0; NV dleft = 0.0; - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { - IV i = SvIVX(POPs); - right = (right_neg = (i < 0)) ? -i : i; - } - else { + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + right_neg = !SvUOK(TOPs); + if (!right_neg) { + right = SvUVX(POPs); + } else { + IV biv = SvIVX(POPs); + if (biv >= 0) { + right = biv; + right_neg = FALSE; /* effectively it's a UV now */ + } else { + right = -biv; + } + } + } + else { dright = POPn; - use_double = 1; right_neg = dright < 0; if (right_neg) dright = -dright; + if (dright < UV_MAX_P1) { + right = U_V(dright); + dright_valid = TRUE; /* In case we need to use double below. */ + } else { + use_double = TRUE; + } } - if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { - IV i = SvIVX(POPs); - left = (left_neg = (i < 0)) ? -i : i; - } + /* At this point use_double is only true if right is out of range for + a UV. In range NV has been rounded down to nearest UV and + use_double false. */ + SvIV_please(TOPs); + if (!use_double && SvIOK(TOPs)) { + if (SvIOK(TOPs)) { + left_neg = !SvUOK(TOPs); + if (!left_neg) { + left = SvUVX(POPs); + } else { + IV aiv = SvIVX(POPs); + if (aiv >= 0) { + left = aiv; + left_neg = FALSE; /* effectively it's a UV now */ + } else { + left = -aiv; + } + } + } + } else { dleft = POPn; - if (!use_double) { - use_double = 1; - dright = right; - } left_neg = dleft < 0; if (left_neg) dleft = -dleft; - } + /* This should be exactly the 5.6 behaviour - if left and right are + both in range for UV then use U_V() rather than floor. */ + if (!use_double) { + if (dleft < UV_MAX_P1) { + /* right was in range, so is dleft, so use UVs not double. + */ + left = U_V(dleft); + } + /* left is out of range for UV, right was in range, so promote + right (back) to double. */ + else { + /* The +0.5 is used in 5.6 even though it is not strictly + consistent with the implicit +0 floor in the U_V() + inside the #if 1. */ + dleft = Perl_floor(dleft + 0.5); + use_double = TRUE; + if (dright_valid) + dright = Perl_floor(dright + 0.5); + else + dright = right; + } + } + } if (use_double) { NV dans; -#if 1 -/* Somehow U_V is pessimized even if CASTFLAGS is 0 */ -# if CASTFLAGS & 2 -# define CAST_D2UV(d) U_V(d) -# else -# define CAST_D2UV(d) ((UV)(d)) -# endif - /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE, - * or, in other words, precision of UV more than of NV. - * But in fact the approach below turned out to be an - * optimization - floor() may be slow */ - if (dright <= UV_MAX && dleft <= UV_MAX) { - right = CAST_D2UV(dright); - left = CAST_D2UV(dleft); - goto do_uv; - } -#endif - - /* Backward-compatibility clause: */ - dright = Perl_floor(dright + 0.5); - dleft = Perl_floor(dleft + 0.5); - if (!dright) DIE(aTHX_ "Illegal modulus zero"); @@ -1102,7 +1365,6 @@ PP(pp_modulo) else { UV ans; - do_uv: if (!right) DIE(aTHX_ "Illegal modulus zero"); @@ -1139,10 +1401,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++; @@ -1246,7 +1531,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) @@ -1381,11 +1666,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; } @@ -1402,17 +1682,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)); @@ -1459,11 +1744,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; } @@ -1480,17 +1760,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)); @@ -1537,11 +1822,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; } @@ -1558,17 +1838,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)); @@ -1615,11 +1900,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; } @@ -1636,17 +1916,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)); @@ -1659,7 +1944,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 @@ -1671,19 +1957,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; } @@ -1712,11 +1995,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; } @@ -1735,7 +2013,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 @@ -1778,10 +2058,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; @@ -1799,12 +2076,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; @@ -2044,15 +2318,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; } @@ -2119,7 +2400,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; @@ -2186,16 +2467,76 @@ PP(pp_i_divide) } } +STATIC +PP(pp_i_modulo_0) +{ + /* This is the vanilla old i_modulo. */ + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + SETi( left % right ); + RETURN; + } +} + +#if defined(__GLIBC__) && IVSIZE == 8 +STATIC +PP(pp_i_modulo_1) +{ + /* This is the i_modulo with the workaround for the _moddi3 bug + * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). + * See below for pp_i_modulo. */ + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + SETi( left % PERL_ABS(right) ); + RETURN; + } +} +#endif + PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); - { - dPOPTOPiirl; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - SETi( left % right ); - RETURN; - } + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* The assumption is to use hereafter the old vanilla version... */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + &Perl_pp_i_modulo_0; + /* .. but if we have glibc, we might have a buggy _moddi3 + * (at least glicb 2.2.5 is known to have this bug), in other + * words our integer modulus with negative quad as the second + * argument might be broken. Test for this and re-patch the + * opcode dispatch table if that is the case, remembering to + * also apply the workaround so that this first round works + * right, too. See [perl #9402] for more information. */ +#if defined(__GLIBC__) && IVSIZE == 8 + { + IV l = 3; + IV r = -10; + /* Cannot do this check with inlined IV constants since + * that seems to work correctly even with the buggy glibc. */ + if (l % r == -3) { + /* Yikes, we have the bug. + * Patch in the workaround version. */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + &Perl_pp_i_modulo_1; + /* Make certain we work right this time, too. */ + right = PERL_ABS(right); + } + } +#endif + SETi( left % right ); + RETURN; + } } PP(pp_i_add) @@ -2387,87 +2728,6 @@ PP(pp_srand) RETPUSHYES; } -STATIC U32 -S_seed(pTHX) -{ - /* - * This is really just a quick hack which grabs various garbage - * values. It really should be a real hash algorithm which - * spreads the effect of every input bit onto every output bit, - * if someone who knows about such things would bother to write it. - * Might be a good idea to add that function to CORE as well. - * No numbers below come from careful analysis or anything here, - * except they are primes and SEED_C1 > 1E6 to get a full-width - * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should - * probably be bigger too. - */ -#if RANDBITS > 16 -# define SEED_C1 1000003 -#define SEED_C4 73819 -#else -# define SEED_C1 25747 -#define SEED_C4 20639 -#endif -#define SEED_C2 3 -#define SEED_C3 269 -#define SEED_C5 26107 - -#ifndef PERL_NO_DEV_RANDOM - int fd; -#endif - U32 u; -#ifdef VMS -# include - /* when[] = (low 32 bits, high 32 bits) of time since epoch - * in 100-ns units, typically incremented ever 10 ms. */ - unsigned int when[2]; -#else -# ifdef HAS_GETTIMEOFDAY - struct timeval when; -# else - Time_t when; -# endif -#endif - -/* This test is an escape hatch, this symbol isn't set by Configure. */ -#ifndef PERL_NO_DEV_RANDOM -#ifndef PERL_RANDOM_DEVICE - /* /dev/random isn't used by default because reads from it will block - * if there isn't enough entropy available. You can compile with - * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there - * is enough real entropy to fill the seed. */ -# define PERL_RANDOM_DEVICE "/dev/urandom" -#endif - fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); - if (fd != -1) { - if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) - u = 0; - PerlLIO_close(fd); - if (u) - return u; - } -#endif - -#ifdef VMS - _ckvmssts(sys$gettim(when)); - u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; -#else -# ifdef HAS_GETTIMEOFDAY - gettimeofday(&when,(struct timezone *) 0); - u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; -# else - (void)time(&when); - u = (U32)SEED_C1 * when; -# endif -#endif - u += SEED_C3 * (U32)PerlProc_getpid(); - u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); -#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ - u += SEED_C5 * (U32)PTR2UV(&when); -#endif - return u; -} - PP(pp_exp) { dSP; dTARGET; tryAMAGICun(exp); @@ -2488,7 +2748,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); @@ -2504,7 +2764,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); @@ -2512,6 +2772,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); @@ -2535,21 +2817,15 @@ 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); +#elif defined(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 - (void)Perl_modf(value, &value); -# endif + NV offset = Perl_modf(value, &value); + (void)Perl_modf(offset, &offset); + value += offset; #else - double tmp = (double)value; - (void)Perl_modf(tmp, &tmp); - value = (NV)tmp; + (void)Perl_modf(value, &value); #endif SETn(value); } @@ -2558,24 +2834,17 @@ PP(pp_int) if (value > (NV)IV_MIN - 0.5) { SETi(I_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); +#elif defined(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 - (void)Perl_modf(-value, &value); -# endif - value = -value; + NV offset = Perl_modf(-value, &value); + (void)Perl_modf(offset, &offset); + value += offset; #else - double tmp = (double)value; - (void)Perl_modf(-tmp, &tmp); - value = -(NV)tmp; + (void)Perl_modf(-value, &value); #endif - SETn(value); + SETn(-value); } } } @@ -2617,40 +2886,74 @@ PP(pp_abs) RETURN; } + PP(pp_hex) { dSP; dTARGET; char *tmps; - STRLEN argtype; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; + NV result_nv; + UV result_uv; + SV* sv = POPs; - tmps = (SvPVx(POPs, len)); - argtype = 1; /* allow underscores */ - XPUSHn(scan_hex(tmps, len, &argtype)); + 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); + } + else { + XPUSHu(result_uv); + } RETURN; } PP(pp_oct) { dSP; dTARGET; - NV value; - STRLEN argtype; char *tmps; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 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--; + tmps++, len--; if (*tmps == '0') - tmps++, len--; - argtype = 1; /* allow underscores */ + tmps++, len--; if (*tmps == 'x') - value = scan_hex(++tmps, --len, &argtype); + result_uv = grok_hex (tmps, &len, &flags, &result_nv); else if (*tmps == 'b') - value = scan_bin(++tmps, --len, &argtype); + result_uv = grok_bin (tmps, &len, &flags, &result_nv); else - value = scan_oct(tmps, len, &argtype); - XPUSHn(value); + result_uv = grok_oct (tmps, &len, &flags, &result_nv); + + if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { + XPUSHn(result_nv); + } + else { + XPUSHu(result_uv); + } RETURN; } @@ -2757,7 +3060,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 { @@ -2793,7 +3096,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 ? */ @@ -2802,10 +3105,14 @@ PP(pp_substr) sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } + if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ + TARG = sv_newmortal(); if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); } + else + (void)SvOK_off(TARG); LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { @@ -2832,6 +3139,8 @@ PP(pp_vec) SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ + if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ + TARG = sv_newmortal(); if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0); @@ -2874,7 +3183,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))) @@ -2915,7 +3224,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))) @@ -2946,8 +3255,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; } @@ -2960,8 +3279,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); @@ -2973,30 +3292,75 @@ 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 && !IN_BYTES) { + sv_recode_to_utf8(TARG, PL_encoding); + tmps = SvPVX(TARG); + if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) || + memEQ(tmps, "\xef\xbf\xbd\0", 4)) { + SvGROW(TARG, 3); + tmps = SvPVX(TARG); + SvCUR_set(TARG, 2); + *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value); + *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value); + *tmps = '\0'; + SvUTF8_on(TARG); + } + } XPUSHs(TARG); RETURN; } PP(pp_crypt) { - dSP; dTARGET; dPOPTOPssrl; - STRLEN n_a; + dSP; dTARGET; #ifdef HAS_CRYPT - char *tmps = SvPV(left, n_a); -#ifdef FCRYPT + dPOPTOPssrl; + STRLEN n_a; + STRLEN len; + char *tmps = SvPV(left, len); + + if (DO_UTF8(left)) { + /* 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 USE_ITHREADS +# ifdef HAS_CRYPT_R + if (!PL_reentrant_buffer->_crypt_struct_buffer) { + /* This should be threadsafe because in ithreads there is only + * one thread per interpreter. If this would not be true, + * we would need a mutex to protect this malloc. */ + PL_reentrant_buffer->_crypt_struct_buffer = + (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); +#if defined(__GLIBC__) || defined(__EMX__) + if (PL_reentrant_buffer->_crypt_struct_buffer) { + PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; + /* work around glibc-2.2.5 bug */ + PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; + } +#endif + } +# endif /* HAS_CRYPT_R */ +# endif /* USE_ITHREADS */ +# ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); -#else +# else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); -#endif +# endif + SETs(TARG); + RETURN; #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif - SETs(TARG); - RETURN; } PP(pp_ucfirst) @@ -3006,45 +3370,47 @@ PP(pp_ucfirst) register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + SvGETMAGIC(sv); + if (DO_UTF8(sv) && + (s = (U8*)SvPV_nomg(sv, slen)) && slen && + UTF8_IS_START(*s)) { + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tend; - UV uv; + STRLEN tculen; - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(sv); - uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0)); - } - else { - uv = toTITLE_utf8(s); - ulen = UNISKIP(uv); - } - - tend = uvchr_to_utf8(tmpbuf, uv); + utf8_to_uvchr(s, &ulen); + toTITLE_utf8(s, tmpbuf, &tculen); + utf8_to_uvchr(tmpbuf, 0); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; - sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); - sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + /* slen is the byte length of the whole SV. + * ulen is the byte length of the original Unicode character + * stored as UTF-8 at s. + * tculen is the byte length of the freshly titlecased + * Unicode character stored as UTF-8 at tmpbuf. + * We first set the result to be the titlecased character, + * and then append the rest of the SV data. */ + sv_setpvn(TARG, (char*)tmpbuf, tculen); + if (slen > ulen) + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { - s = (U8*)SvPV_force(sv, slen); - Copy(tmpbuf, s, ulen, U8); + s = (U8*)SvPV_force_nomg(sv, slen); + Copy(tmpbuf, s, tculen, U8); } } else { if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); if (*s) { if (IN_LOCALE_RUNTIME) { TAINT; @@ -3055,8 +3421,7 @@ PP(pp_ucfirst) *s = toUPPER(*s); } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3067,33 +3432,29 @@ PP(pp_lcfirst) register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + SvGETMAGIC(sv); + if (DO_UTF8(sv) && + (s = (U8*)SvPV_nomg(sv, slen)) && slen && + UTF8_IS_START(*s)) { STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN+1]; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; U8 *tend; UV uv; - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(sv); - uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0)); - } - else { - uv = toLOWER_utf8(s); - ulen = UNISKIP(uv); - } - + toLOWER_utf8(s, tmpbuf, &ulen); + uv = utf8_to_uvchr(tmpbuf, 0); 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); + if (slen > ulen) + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); Copy(tmpbuf, s, ulen, U8); } } @@ -3101,11 +3462,11 @@ PP(pp_lcfirst) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); if (*s) { if (IN_LOCALE_RUNTIME) { TAINT; @@ -3116,8 +3477,7 @@ PP(pp_lcfirst) *s = toLOWER(*s); } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3128,37 +3488,33 @@ PP(pp_uc) register U8 *s; STRLEN len; + SvGETMAGIC(sv); if (DO_UTF8(sv)) { dTARGET; STRLEN ulen; register U8 *d; U8 *send; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - s = (U8*)SvPV(sv,len); + s = (U8*)SvPV_nomg(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); 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; - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0))); - s += ulen; - } - } - else { - while (s < send) { - d = uvchr_to_utf8(d, toUPPER_utf8( s )); - s += UTF8SKIP(s); - } + while (s < send) { + toUPPER_utf8(s, tmpbuf, &ulen); + Copy(tmpbuf, d, ulen, U8); + d += ulen; + s += UTF8SKIP(s); } *d = '\0'; SvUTF8_on(TARG); @@ -3170,11 +3526,11 @@ PP(pp_uc) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, len); + s = (U8*)SvPV_force_nomg(sv, len); if (len) { register U8 *send = s + len; @@ -3190,8 +3546,7 @@ PP(pp_uc) } } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3202,37 +3557,50 @@ PP(pp_lc) register U8 *s; STRLEN len; + SvGETMAGIC(sv); if (DO_UTF8(sv)) { dTARGET; STRLEN ulen; register U8 *d; U8 *send; + U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - s = (U8*)SvPV(sv,len); + s = (U8*)SvPV_nomg(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); 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; - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0))); - s += ulen; - } - } - else { - while (s < send) { - d = uvchr_to_utf8(d, toLOWER_utf8(s)); - s += UTF8SKIP(s); + while (s < send) { + UV uv = toLOWER_utf8(s, tmpbuf, &ulen); +#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */ + if (uv == GREEK_CAPITAL_LETTER_SIGMA) { + /* + * Now if the sigma is NOT followed by + * /$ignorable_sequence$cased_letter/; + * and it IS preceded by + * /$cased_letter$ignorable_sequence/; + * where $ignorable_sequence is + * [\x{2010}\x{AD}\p{Mn}]* + * and $cased_letter is + * [\p{Ll}\p{Lo}\p{Lt}] + * then it should be mapped to 0x03C2, + * (GREEK SMALL LETTER FINAL SIGMA), + * instead of staying 0x03A3. + * See lib/unicore/SpecCase.txt. + */ } + Copy(tmpbuf, d, ulen, U8); + d += ulen; + s += UTF8SKIP(s); } *d = '\0'; SvUTF8_on(TARG); @@ -3244,12 +3612,12 @@ PP(pp_lc) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, len); + s = (U8*)SvPV_force_nomg(sv, len); if (len) { register U8 *send = s + len; @@ -3265,8 +3633,7 @@ PP(pp_lc) } } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3374,22 +3741,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); } @@ -3429,19 +3795,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"); @@ -3462,7 +3822,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"); @@ -3502,8 +3862,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"); @@ -3516,42 +3874,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); - - if (!realhv && PL_op->op_private & OPpLVAL_INTRO) - 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); - 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); - } + 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); + } + + he = hv_fetch_ent(hv, keysv, lval, 0); + svp = he ? &HeVAL(he) : 0; + + 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; @@ -3652,7 +4021,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; @@ -3711,8 +4080,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 */ @@ -3995,7 +4367,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } } } @@ -4005,7 +4377,7 @@ PP(pp_reverse) while (down > up) { tmp = *up; *up++ = *down; - *down-- = tmp; + *down-- = (char)tmp; } (void)SvPOK_only_UTF8(TARG); } @@ -4055,21 +4427,17 @@ PP(pp_split) TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); - PL_reg_sv_utf8 = do_utf8; + RX_MATCH_UTF8_set(rx, do_utf8); if (pm->op_pmreplroot) { #ifdef USE_ITHREADS - ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); + ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot))); #else ary = GvAVn((GV*)pm->op_pmreplroot); #endif } else if (gimme != G_ARRAY) -#ifdef USE_THREADS - ary = (AV*)PL_curpad[0]; -#else ary = GvAVn(PL_defgv); -#endif /* USE_THREADS */ else ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { @@ -4091,6 +4459,7 @@ PP(pp_split) } /* temporarily switch stacks */ SWITCHSTACK(PL_curstack, ary); + PL_curstackinfo->si_stack = ary; make_mortal = 0; } } @@ -4106,7 +4475,7 @@ PP(pp_split) s++; } } - if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } @@ -4211,13 +4580,13 @@ PP(pp_split) } else { maxiters += slen * rx->nparens; - 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)) + while (s < strend && --limit) { + PUTBACK; + i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0); + SPAGAIN; + if (i == 0) + break; TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; @@ -4235,7 +4604,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; @@ -4277,13 +4646,18 @@ 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) { if (!mg) { SWITCHSTACK(ary, oldstack); + PL_curstackinfo->si_stack = oldstack; if (SvSMAGICAL(ary)) { PUTBACK; mg_set((SV*)ary); @@ -4317,46 +4691,18 @@ PP(pp_split) if (gimme == G_ARRAY) RETURN; } - if (iters || !pm->op_pmreplroot) { - GETTARGET; - PUSHi(iters); - RETURN; - } - RETPUSHUNDEF; -} -#ifdef USE_THREADS -void -Perl_unlock_condpair(pTHX_ void *svv) -{ - MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex); - - if (!mg) - Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) != thr) - Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); - MgOWNER(mg) = 0; - COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(svv))); - MUTEX_UNLOCK(MgMUTEXP(mg)); + GETTARGET; + PUSHi(iters); + RETURN; } -#endif /* USE_THREADS */ PP(pp_lock) { dSP; dTOPss; SV *retsv = sv; -#ifdef USE_THREADS - sv_lock(sv); -#endif /* USE_THREADS */ -#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); @@ -4367,15 +4713,5 @@ PP(pp_lock) PP(pp_threadsv) { -#ifdef USE_THREADS - dSP; - EXTEND(SP, 1); - if (PL_op->op_private & OPpLVAL_INTRO) - PUSHs(*save_threadsv(PL_op->op_targ)); - else - PUSHs(THREADSV(PL_op->op_targ)); - RETURN; -#else DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); -#endif /* USE_THREADS */ }