X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=11506977b23410227472389b5ade15247d7e51e6;hb=7df053ec69e901392ae6352566832be0a6917cfe;hp=443eed0a53e9438e19f082a47c48df45eb945ad1;hpb=971a9dd36d83520d7040365d2791ad56b6d39411;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 443eed0..1150697 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,6 @@ /* pp.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, 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. @@ -28,37 +28,6 @@ static double UV_MAX_cxux = ((double)UV_MAX); #endif /* - * Types used in bitwise operations. - * - * Normally we'd just use IV and UV. However, some hardware and - * software combinations (e.g. Alpha and current OSF/1) don't have a - * floating-point type to use for NV that has adequate bits to fully - * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).) - * - * It just so happens that "int" is the right size almost everywhere. - */ -typedef int IBW; -typedef unsigned UBW; - -/* - * Mask used after bitwise operations. - * - * There is at least one realm (Cray word machines) that doesn't - * have an integral type (except char) small enough to be represented - * in a double without loss; that is, it has no 32-bit type. - */ -#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP) -# define BW_BITS 32 -# define BW_MASK ((1 << BW_BITS) - 1) -# define BW_SIGN (1 << (BW_BITS - 1)) -# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK)) -# define BWu(u) ((u) & BW_MASK) -#else -# define BWi(i) (i) -# define BWu(u) (u) -#endif - -/* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, @@ -86,7 +55,7 @@ typedef unsigned UBW; # define PERL_NATINT_PACK #endif -#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) +#if LONGSIZE > 4 && defined(_CRAY) # if BYTEORDER == 0x12345678 # define OFF16(p) (char*)(p) # define OFF32(p) (char*)(p) @@ -113,10 +82,6 @@ typedef unsigned UBW; /* variations on pp_null */ -#ifdef I_UNISTD -#include -#endif - /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. --AD 2/20/1998 @@ -209,7 +174,7 @@ PP(pp_padany) PP(pp_rv2gv) { - djSP; dTOPss; + djSP; dTOPss; if (SvROK(sv)) { wasref: @@ -229,52 +194,56 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } - if (!SvOK(sv)) { - /* If this is a 'my' scalar and flag is set then vivify + if (!SvOK(sv) && sv != &PL_sv_undef) { + /* If this is a 'my' scalar and flag is set then vivify * NI-S 1999/05/07 - */ + */ if (PL_op->op_private & OPpDEREF) { - GV *gv = (GV *) newSV(0); - STRLEN len = 0; - char *name = ""; - if (cUNOP->op_first->op_type == OP_PADSV) { - SV **namep = av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4); - if (namep && *namep) { - name = SvPV(*namep,len); - if (!name) { - name = ""; - len = 0; - } - } + char *name; + GV *gv; + if (cUNOP->op_targ) { + STRLEN len; + SV *namesv = PL_curpad[cUNOP->op_targ]; + name = SvPV(namesv, len); + gv = (GV*)NEWSV(0,0); + gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } - gv_init(gv, CopSTASH(PL_curcop), name, len, 0); - sv_upgrade(sv, SVt_RV); - SvRV(sv) = (SV *) gv; + else { + name = CopSTASHPV(PL_curcop); + gv = newGVgen(name); + } + if (SvTYPE(sv) < SVt_RV) + sv_upgrade(sv, SVt_RV); + SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); goto wasref; - } + } if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); - if (!sv) + if (!sv + && (!is_gv_magical(sym,len,0) + || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -308,7 +277,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; - STRLEN n_a; + STRLEN len; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -321,16 +290,20 @@ PP(pp_rv2sv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv, len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -390,7 +363,7 @@ PP(pp_pos) mg = mg_find(sv, 'g'); if (mg && mg->mg_len >= 0) { I32 i = mg->mg_len; - if (IN_UTF8) + if (DO_UTF8(sv)) sv_pos_b2u(sv, &i); PUSHi(i + PL_curcop->cop_arybase); RETURN; @@ -412,8 +385,12 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + if ((PL_op->op_private & OPpLVAL_INTRO)) { + if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) + cv = GvCV(gv); + if (!CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } } else cv = (CV*)&PL_sv_undef; @@ -434,7 +411,7 @@ PP(pp_prototype) char *s = SvPVX(TOPs); if (strnEQ(s, "CORE::", 6)) { int code; - + code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) @@ -454,13 +431,13 @@ PP(pp_prototype) found: oa = PL_opargs[i] >> OASHIFT; while (oa) { - if (oa & OA_OPTIONAL) { + if (oa & OA_OPTIONAL && !seen_question) { seen_question = 1; str[n++] = ';'; } - else if (seen_question) + else if (n && str[0] == ';' && seen_question) goto set; /* XXXX system, exec */ - if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { str[n++] = '\\'; } @@ -585,9 +562,13 @@ PP(pp_bless) else { SV *ssv = POPs; STRLEN len; - char *ptr = SvPV(ssv,len); - if (ckWARN(WARN_UNSAFE) && len == 0) - Perl_warner(aTHX_ WARN_UNSAFE, + char *ptr; + + if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) + Perl_croak(aTHX_ "Attempt to bless into a reference"); + ptr = SvPV(ssv,len); + if (ckWARN(WARN_MISC) && len == 0) + Perl_warner(aTHX_ WARN_MISC, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -604,7 +585,7 @@ PP(pp_gelem) char *elem; djSP; STRLEN n_a; - + sv = POPs; elem = SvPV(sv, n_a); gv = (GV*)POPs; @@ -623,6 +604,9 @@ PP(pp_gelem) case 'F': if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ tmpRef = (SV*)GvIOp(gv); + else + if (strEQ(elem, "FORMAT")) + tmpRef = (SV*)GvFORM(gv); break; case 'G': if (strEQ(elem, "GLOB")) @@ -833,8 +817,8 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv)) - Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined", + if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) + Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: @@ -937,7 +921,7 @@ PP(pp_pow) djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; - SETn( pow( left, right) ); + SETn( Perl_pow( left, right) ); RETURN; } } @@ -945,6 +929,114 @@ PP(pp_pow) PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); + const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); + UV alow; + UV ahigh; + UV blow; + UV bhigh; + + if (auvok) { + alow = SvUVX(TOPm1s); + } else { + IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + alow = aiv; + auvok = TRUE; /* effectively it's a UV now */ + } else { + alow = -aiv; /* abs, auvok == false records sign */ + } + } + if (buvok) { + blow = SvUVX(TOPs); + } else { + IV biv = SvIVX(TOPs); + if (biv >= 0) { + blow = biv; + buvok = TRUE; /* effectively it's a UV now */ + } else { + blow = -biv; /* abs, buvok == false records sign */ + } + } + + /* If this does sign extension on unsigned it's time for plan B */ + ahigh = alow >> (4 * sizeof (UV)); + alow &= botmask; + bhigh = blow >> (4 * sizeof (UV)); + blow &= botmask; + if (ahigh && bhigh) { + /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 + which is overflow. Drop to NVs below. */ + } else if (!ahigh && !bhigh) { + /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 + so the unsigned multiply cannot overflow. */ + UV product = alow * blow; + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product ); + RETURN; + } else if (product <= (UV)IV_MIN) { + /* 2s complement assumption that (UV)-IV_MIN is correct. */ + /* -ve result, which could overflow an IV */ + SP--; + SETi( -product ); + RETURN; + } /* else drop to NVs below. */ + } else { + /* One operand is large, 1 small */ + UV product_middle; + if (bhigh) { + /* swap the operands */ + ahigh = bhigh; + bhigh = blow; /* bhigh now the temp var for the swap */ + blow = alow; + alow = bhigh; + } + /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) + multiplies can't overflow. shift can, add can, -ve can. */ + product_middle = ahigh * blow; + if (!(product_middle & topmask)) { + /* OK, (ahigh * blow) won't lose bits when we shift it. */ + UV product_low; + product_middle <<= (4 * sizeof (UV)); + product_low = alow * blow; + + /* as for pp_add, UV + something mustn't get smaller. + IIRC ANSI mandates this wrapping *behaviour* for + unsigned whatever the actual representation*/ + product_low += product_middle; + if (product_low >= product_middle) { + /* didn't overflow */ + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product_low ); + RETURN; + } else if (product_low <= (UV)IV_MIN) { + /* 2s complement assumption again */ + /* -ve result, which could overflow an IV */ + SP--; + SETi( -product_low ); + RETURN; + } /* else drop to NVs below. */ + } + } /* product_middle too large */ + } /* ahigh && bhigh */ + } /* SvIOK(TOPm1s) */ + } /* SvIOK(TOPs) */ +#endif { dPOPTOPnnrl; SETn( left * right ); @@ -993,7 +1085,7 @@ PP(pp_modulo) NV dright; NV dleft; - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); right = (right_neg = (i < 0)) ? -i : i; } @@ -1005,7 +1097,7 @@ PP(pp_modulo) dright = -dright; } - if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); left = (left_neg = (i < 0)) ? -i : i; } @@ -1042,8 +1134,8 @@ PP(pp_modulo) #endif /* Backward-compatibility clause: */ - dright = floor(dright + 0.5); - dleft = floor(dleft + 0.5); + dright = Perl_floor(dright + 0.5); + dleft = Perl_floor(dleft + 0.5); if (!dright) DIE(aTHX_ "Illegal modulus zero"); @@ -1085,7 +1177,7 @@ PP(pp_repeat) { djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { - register I32 count = POPi; + register IV count = POPi; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; @@ -1108,10 +1200,10 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr; + SV *tmpstr = POPs; STRLEN len; + bool isutf = DO_UTF8(tmpstr); - tmpstr = POPs; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); if (count != 1) { @@ -1124,7 +1216,10 @@ PP(pp_repeat) } *SvEND(TARG) = '\0'; } - (void)SvPOK_only(TARG); + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -1133,11 +1228,146 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + if (!useleft) { + /* left operand is undef, treat as zero. + 0 is identity. */ + if (SvUOK(TOPs)) { + dPOPuv; /* Scary macros. Lets put a sequence point (;) here */ + if (value <= (UV)IV_MIN) { + /* 2s complement assumption. */ + SETi(-(IV)value); + RETURN; + } /* else drop through into NVs below */ + } else { + dPOPiv; + SETu((UV)-value); + RETURN; + } + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV - IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + IV result = aiv - biv; + + if (biv >= 0 ? (result < aiv) : (result >= aiv)) { + SP--; + SETi( result ); + RETURN; + } + /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */ + /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */ + /* -ve - +ve can only overflow too negative. */ + /* leaving +ve - -ve, which will go UV */ + if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */ + /* 2s complement assumption for IV_MIN */ + UV result = (UV)aiv + (UV)-biv; + /* UV + UV must get bigger. +ve IV + +ve IV +1 can't + overflow UV (2s complement assumption */ + assert (result >= (UV) aiv); + SP--; + SETu( result ); + RETURN; + } + /* Overflow, drop through to NVs */ + } else if (auvok && buvok) { /* ## UV - UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result; + + if (auv >= buv) { + SP--; + SETu( auv - buv ); + RETURN; + } + /* Blatant 2s complement assumption. */ + result = (IV)(auv - buv); + if (result < 0) { + SP--; + SETi( result ); + RETURN; + } + /* Overflow on IV - IV, drop through to NVs */ + } else if (auvok) { /* ## Mixed UV - IV ## */ + UV auv = SvUVX(TOPm1s); + IV biv = SvIVX(TOPs); + + if (biv < 0) { + /* 2s complement assumptions for IV_MIN */ + UV result = auv + ((UV)-biv); + /* UV + UV can only get bigger... */ + if (result >= auv) { + SP--; + SETu( result ); + RETURN; + } + /* and if it gets too big for UV then it's NV time. */ + } else if (auv > (UV)IV_MAX) { + /* I think I'm making an implicit 2s complement + assumption that IV_MIN == -IV_MAX - 1 */ + /* biv is >= 0 */ + UV result = auv - (UV)biv; + assert (result <= auv); + SP--; + SETu( result ); + RETURN; + } else { + /* biv is >= 0 */ + IV result = (IV)auv - biv; + assert (result <= (IV)auv); + SP--; + SETi( result ); + RETURN; + } + } else { /* ## Mixed IV - UV ## */ + IV aiv = SvIVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result = aiv - (IV)buv; /* 2s complement assumption. */ + + /* result must not get larger. */ + if (result <= aiv) { + SP--; + SETi( result ); + RETURN; + } /* end of IV-IV / UV-UV / UV-IV / IV-UV */ + } + } + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left - right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero - value */ + SETn(-value); + RETURN; + } + SETn( TOPn - value ); + RETURN; } } @@ -1145,16 +1375,14 @@ PP(pp_left_shift) { djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) << shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i << shift); } else { - UBW u = TOPu; - u <<= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u << shift); } RETURN; } @@ -1164,16 +1392,14 @@ PP(pp_right_shift) { djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) >> shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i >> shift); } else { - UBW u = TOPu; - u >>= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u >> shift); } RETURN; } @@ -1182,6 +1408,74 @@ PP(pp_right_shift) PP(pp_lt) { djSP; tryAMAGICbinSET(lt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + 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); + + SP--; + SETs(boolSV(auv < buv)); + RETURN; + } + if (auvok) { /* ## UV < IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + SETs(&PL_sv_no); + 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; + } + { /* ## IV < UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + 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 { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1192,6 +1486,74 @@ PP(pp_lt) PP(pp_gt) { djSP; tryAMAGICbinSET(gt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + 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); + + SP--; + SETs(boolSV(auv > buv)); + RETURN; + } + if (auvok) { /* ## UV > IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be > */ + SETs(&PL_sv_yes); + 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; + } + { /* ## IV > UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it cannot be > */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + 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 { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1202,6 +1564,74 @@ PP(pp_gt) PP(pp_le) { djSP; tryAMAGICbinSET(le,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + 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); + + SP--; + SETs(boolSV(auv <= buv)); + RETURN; + } + if (auvok) { /* ## UV <= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so a cannot be <= */ + SETs(&PL_sv_no); + 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; + } + { /* ## IV <= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a must be <= */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + 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 { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1212,6 +1642,74 @@ PP(pp_le) PP(pp_ge) { djSP; tryAMAGICbinSET(ge,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + 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); + + SP--; + SETs(boolSV(auv >= buv)); + RETURN; + } + if (auvok) { /* ## UV >= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be >= */ + SETs(&PL_sv_yes); + 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; + } + { /* ## IV >= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a cannot be >= */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + 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 { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1222,6 +1720,66 @@ PP(pp_ge) PP(pp_ne) { djSP; tryAMAGICbinSET(ne,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + 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); + + SP--; + SETs(boolSV(auv != buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* != is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + 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; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1232,10 +1790,95 @@ PP(pp_ne) PP(pp_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); +#ifdef PERL_PRESERVE_IVUV + /* Fortunately it seems NaN isn't IOK */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool leftuvok = SvUOK(TOPm1s); + bool rightuvok = SvUOK(TOPs); + I32 value; + if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ + IV leftiv = SvIVX(TOPm1s); + IV rightiv = SvIVX(TOPs); + + if (leftiv > rightiv) + value = 1; + else if (leftiv < rightiv) + value = -1; + else + value = 0; + } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ + UV leftuv = SvUVX(TOPm1s); + UV rightuv = SvUVX(TOPs); + + if (leftuv > rightuv) + value = 1; + else if (leftuv < rightuv) + value = -1; + else + value = 0; + } else if (leftuvok) { /* ## UV <=> IV ## */ + UV leftuv; + IV rightiv; + + rightiv = SvIVX(TOPs); + if (rightiv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + 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) { + value = 1; + } else if (leftuv < (UV)rightiv) { + value = -1; + } else { + value = 0; + } + } + } else { /* ## IV <=> UV ## */ + IV leftiv; + UV rightuv; + + leftiv = SvIVX(TOPm1s); + if (leftiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + 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) { + value = 1; + } else if (leftiv < (UV)rightuv) { + value = -1; + } else { + value = 0; + } + } + } + SP--; + SETi(value); + RETURN; + } + } +#endif { dPOPTOPnnrl; I32 value; +#ifdef Perl_isnan + if (Perl_isnan(left) || Perl_isnan(right)) { + SETs(&PL_sv_undef); + RETURN; + } + value = (left > right) - (left < right); +#else if (left == right) value = 0; else if (left < right) @@ -1246,6 +1889,7 @@ PP(pp_ncmp) SETs(&PL_sv_undef); RETURN; } +#endif SETi(value); RETURN; } @@ -1343,12 +1987,12 @@ PP(pp_bit_and) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = SvIV(left) & SvIV(right); - SETi(BWi(value)); + IV i = SvIV(left) & SvIV(right); + SETi(i); } else { - UBW value = SvUV(left) & SvUV(right); - SETu(BWu(value)); + UV u = SvUV(left) & SvUV(right); + SETu(u); } } else { @@ -1366,12 +2010,12 @@ PP(pp_bit_xor) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi(BWi(value)); + IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi(i); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); - SETu(BWu(value)); + UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(u); } } else { @@ -1389,12 +2033,12 @@ PP(pp_bit_or) dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi(BWi(value)); + IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi(i); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); - SETu(BWu(value)); + UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(u); } } else { @@ -1410,11 +2054,35 @@ PP(pp_negate) djSP; dTARGET; tryAMAGICun(neg); { dTOPss; + int flags = SvFLAGS(sv); if (SvGMAGICAL(sv)) mg_get(sv); - if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN) - SETi(-SvIVX(sv)); - else if (SvNIOKp(sv)) + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_an_int: + if (SvIsUV(sv)) { + if (SvIVX(sv) == IV_MIN) { + /* 2s complement assumption. */ + SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ + RETURN; + } + else if (SvUVX(sv) <= IV_MAX) { + SETi(-SvIVX(sv)); + RETURN; + } + } + else if (SvIVX(sv) != IV_MIN) { + SETi(-SvIVX(sv)); + RETURN; + } +#ifdef PERL_PRESERVE_IVUV + else { + SETu((UV)IV_MIN); + RETURN; + } +#endif + } + if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; @@ -1427,12 +2095,16 @@ PP(pp_negate) sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } - else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { + else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } - else - sv_setnv(TARG, -SvNV(sv)); + else { + SvIV_please(sv); + if (SvIOK(sv)) + goto oops_its_an_int; + sv_setnv(TARG, -SvNV(sv)); + } SETTARG; } else @@ -1455,30 +2127,81 @@ PP(pp_complement) dTOPss; if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = ~SvIV(sv); - SETi(BWi(value)); + IV i = ~SvIV(sv); + SETi(i); } else { - UBW value = ~SvUV(sv); - SETu(BWu(value)); + UV u = ~SvUV(sv); + SETu(u); } } else { - register char *tmps; - register long *tmpl; + register U8 *tmps; register I32 anum; STRLEN len; SvSetSV(TARG, sv); - tmps = SvPV_force(TARG, len); + tmps = (U8*)SvPV_force(TARG, len); anum = len; + if (SvUTF8(TARG)) { + /* Calculate exact length, let's not estimate. */ + STRLEN targlen = 0; + U8 *result; + U8 *send; + STRLEN l; + UV nchar = 0; + UV nwide = 0; + + send = tmps + len; + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + targlen += UNISKIP(~c); + nchar++; + if (c > 0xff) + nwide++; + } + + /* Now rewind strings and write them. */ + tmps -= len; + + if (nwide) { + Newz(0, result, targlen + 1, U8); + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + result = uv_to_utf8(result, ~c); + } + *result = '\0'; + result -= targlen; + sv_setpvn(TARG, (char*)result, targlen); + SvUTF8_on(TARG); + } + else { + Newz(0, result, nchar + 1, U8); + while (tmps < send) { + U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY); + tmps += UTF8SKIP(tmps); + *result++ = ~c; + } + *result = '\0'; + result -= nchar; + sv_setpvn(TARG, (char*)result, nchar); + } + Safefree(result); + SETs(TARG); + RETURN; + } #ifdef LIBERAL - for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) - *tmps = ~*tmps; - tmpl = (long*)tmps; - for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) - *tmpl = ~*tmpl; - tmps = (char*)tmpl; + { + register long *tmpl; + for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) + *tmps = ~*tmps; + tmpl = (long*)tmps; + for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) + *tmpl = ~*tmpl; + tmps = (U8*)tmpl; + } #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; @@ -1516,7 +2239,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1530,7 +2253,7 @@ PP(pp_i_add) { djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left + right ); RETURN; } @@ -1540,7 +2263,7 @@ PP(pp_i_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left - right ); RETURN; } @@ -1740,7 +2463,6 @@ S_seed(pTHX) #define SEED_C3 269 #define SEED_C5 26107 - dTHR; #ifndef PERL_NO_DEV_RANDOM int fd; #endif @@ -1789,7 +2511,7 @@ S_seed(pTHX) u = (U32)SEED_C1 * when; # endif #endif - u += SEED_C3 * (U32)getpid(); + 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); @@ -1816,7 +2538,7 @@ PP(pp_log) NV value; value = POPn; if (value <= 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } value = Perl_log(value); @@ -1832,7 +2554,7 @@ PP(pp_sqrt) NV value; value = POPn; if (value < 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } value = Perl_sqrt(value); @@ -1845,25 +2567,49 @@ PP(pp_int) { djSP; dTARGET; { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { - iv = SvIVX(TOPs); - SETi(iv); - } - else { - if (value >= 0.0) - (void)Perl_modf(value, &value); - else { - (void)Perl_modf(-value, &value); - value = -value; - } - iv = I_V(value); - if (iv == value) - SETi(iv); - else - SETn(value); + NV value; + IV iv = TOPi; /* attempt to convert to IV if possible. */ + /* XXX it's arguable that compiler casting to IV might be subtly + different from modf (for numbers inside (IV_MIN,UV_MAX)) in which + else preferring IV has introduced a subtle behaviour change bug. OTOH + relying on floating point to be accurate is a bug. */ + + if (SvIOK(TOPs)) { + if (SvIsUV(TOPs)) { + UV uv = TOPu; + SETu(uv); + } else + SETi(iv); + } else { + value = TOPn; + if (value >= 0.0) { + if (value < (NV)UV_MAX + 0.5) { + SETu(U_V(value)); + } else { +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(value, &value); +#else + double tmp = (double)value; + (void)Perl_modf(tmp, &tmp); + value = (NV)tmp; +#endif + } + } + else { + if (value > (NV)IV_MIN - 0.5) { + SETi(I_V(value)); + } else { +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(-value, &value); + value = -value; +#else + double tmp = (double)value; + (void)Perl_modf(-tmp, &tmp); + value = -(NV)tmp; +#endif + SETn(value); + } + } } } RETURN; @@ -1873,18 +2619,30 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && - (iv = SvIVX(TOPs)) != IV_MIN) { - if (iv < 0) - iv = -iv; - SETi(iv); - } - else { + /* This will cache the NV value if string isn't actually integer */ + IV iv = TOPi; + + if (SvIOK(TOPs)) { + /* IVX is precise */ + if (SvIsUV(TOPs)) { + SETu(TOPu); /* force it to be numeric only */ + } else { + if (iv >= 0) { + SETi(iv); + } else { + if (iv != IV_MIN) { + SETi(-iv); + } else { + /* 2s complement assumption. Also, not really needed as + IV_MIN and -IV_MIN should both be %100...00 and NV-able */ + SETu(IV_MIN); + } + } + } + } else{ + NV value = TOPn; if (value < 0.0) - value = -value; + value = -value; SETn(value); } } @@ -1895,10 +2653,11 @@ PP(pp_hex) { djSP; dTARGET; char *tmps; - I32 argtype; + STRLEN argtype; STRLEN n_a; tmps = POPpx; + argtype = 1; /* allow underscores */ XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1907,7 +2666,7 @@ PP(pp_oct) { djSP; dTARGET; NV value; - I32 argtype; + STRLEN argtype; char *tmps; STRLEN n_a; @@ -1916,6 +2675,7 @@ PP(pp_oct) tmps++; if (*tmps == '0') tmps++; + argtype = 1; /* allow underscores */ if (*tmps == 'x') value = scan_hex(++tmps, 99, &argtype); else if (*tmps == 'b') @@ -1931,13 +2691,12 @@ PP(pp_oct) PP(pp_length) { djSP; dTARGET; + SV *sv = TOPs; - if (IN_UTF8) { - SETi( sv_len_utf8(TOPs) ); - RETURN; - } - - SETi( sv_len(TOPs) ); + if (DO_UTF8(sv)) + SETi(sv_len_utf8(sv)); + else + SETi(sv_len(sv)); RETURN; } @@ -1958,6 +2717,7 @@ PP(pp_substr) STRLEN repl_len; SvTAINTED_off(TARG); /* decontaminate */ + SvUTF8_off(TARG); /* decontaminate */ if (MAXARG > 2) { if (MAXARG > 3) { sv = POPs; @@ -1969,7 +2729,7 @@ PP(pp_substr) sv = POPs; PUTBACK; tmps = SvPV(sv, curlen); - if (IN_UTF8) { + if (DO_UTF8(sv)) { utfcurlen = sv_len_utf8(sv); if (utfcurlen == curlen) utfcurlen = 0; @@ -2013,16 +2773,22 @@ PP(pp_substr) rem -= pos; } if (fail < 0) { - if (ckWARN(WARN_SUBSTR) || lvalue || repl) + if (lvalue || repl) + Perl_croak(aTHX_ "substr outside of string"); + if (ckWARN(WARN_SUBSTR)) Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { - if (utfcurlen) + if (utfcurlen) sv_pos_u2b(sv, &pos, &rem); tmps += pos; sv_setpvn(TARG, tmps, rem); - if (lvalue) { /* it's an lvalue! */ + if (utfcurlen) + SvUTF8_on(TARG); + if (repl) + sv_insert(sv, pos, rem, repl, repl_len); + else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { STRLEN n_a; @@ -2032,7 +2798,7 @@ PP(pp_substr) "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only(sv); + (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } @@ -2051,8 +2817,6 @@ PP(pp_substr) LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } - else if (repl) - sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -2062,8 +2826,8 @@ PP(pp_substr) PP(pp_vec) { djSP; dTARGET; - register I32 size = POPi; - register I32 offset = POPi; + register IV size = POPi; + register IV offset = POPi; register SV *src = POPs; I32 lvalue = PL_op->op_flags & OPf_MOD; @@ -2107,7 +2871,7 @@ PP(pp_index) little = POPs; big = POPs; tmps = SvPV(big, biglen); - if (IN_UTF8 && offset > 0) + if (offset > 0 && DO_UTF8(big)) sv_pos_u2b(big, &offset, 0); if (offset < 0) offset = 0; @@ -2118,7 +2882,7 @@ PP(pp_index) retval = -1; else retval = tmps2 - tmps; - if (IN_UTF8 && retval > 0) + if (retval > 0 && DO_UTF8(big)) sv_pos_b2u(big, &retval); PUSHi(retval + arybase); RETURN; @@ -2146,7 +2910,7 @@ PP(pp_rindex) if (MAXARG < 3) offset = blen; else { - if (IN_UTF8 && offset > 0) + if (offset > 0 && DO_UTF8(big)) sv_pos_u2b(big, &offset, 0); offset = offset - arybase + llen; } @@ -2159,7 +2923,7 @@ PP(pp_rindex) retval = -1; else retval = tmps2 - tmps; - if (IN_UTF8 && retval > 0) + if (retval > 0 && DO_UTF8(big)) sv_pos_b2u(big, &retval); PUSHi(retval + arybase); RETURN; @@ -2178,16 +2942,11 @@ PP(pp_sprintf) PP(pp_ord) { djSP; dTARGET; - UV value; - STRLEN n_a; - U8 *tmps = (U8*)POPpx; - I32 retlen; + SV *argsv = POPs; + STRLEN len; + U8 *s = (U8*)SvPVx(argsv, len); - if (IN_UTF8 && (*tmps & 0x80)) - value = utf8_to_uv(tmps, &retlen); - else - value = (UV)(*tmps & 255); - XPUSHu(value); + XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff)); RETURN; } @@ -2195,17 +2954,18 @@ PP(pp_chr) { djSP; dTARGET; char *tmps; - U32 value = POPu; + UV value = POPu; (void)SvUPGRADE(TARG,SVt_PV); - if (IN_UTF8 && value >= 128) { - SvGROW(TARG,8); + if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) { + SvGROW(TARG, UTF8_MAXLEN+1); tmps = SvPVX(TARG); tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); + SvUTF8_on(TARG); XPUSHs(TARG); RETURN; } @@ -2232,7 +2992,7 @@ PP(pp_crypt) sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else - DIE(aTHX_ + DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); @@ -2246,11 +3006,11 @@ PP(pp_ucfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[10]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2262,10 +3022,11 @@ PP(pp_ucfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + SvUTF8_on(TARG); SETs(TARG); } else { @@ -2274,8 +3035,9 @@ PP(pp_ucfirst) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2303,11 +3065,11 @@ PP(pp_lcfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[10]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2319,10 +3081,11 @@ PP(pp_lcfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + SvUTF8_on(TARG); SETs(TARG); } else { @@ -2331,8 +3094,9 @@ PP(pp_lcfirst) } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2347,7 +3111,6 @@ PP(pp_lcfirst) else *s = toLOWER(*s); } - SETs(sv); } if (SvSMAGICAL(sv)) mg_set(sv); @@ -2361,14 +3124,15 @@ PP(pp_uc) register U8 *s; STRLEN len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; s = (U8*)SvPV(sv,len); if (!len) { + SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } @@ -2382,7 +3146,7 @@ PP(pp_uc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2393,13 +3157,15 @@ PP(pp_uc) } } *d = '\0'; + SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2432,14 +3198,15 @@ PP(pp_lc) register U8 *s; STRLEN len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; s = (U8*)SvPV(sv,len); if (!len) { + SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } @@ -2453,7 +3220,7 @@ PP(pp_lc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2464,13 +3231,15 @@ PP(pp_lc) } } *d = '\0'; + SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } } else { - if (!SvPADTMP(sv)) { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2505,11 +3274,12 @@ PP(pp_quotemeta) register char *s = SvPV(sv,len); register char *d; + SvUTF8_off(TARG); /* decontaminate */ if (len) { (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); - if (IN_UTF8) { + if (DO_UTF8(sv)) { while (len) { if (*s & 0x80) { STRLEN ulen = UTF8SKIP(s); @@ -2526,6 +3296,7 @@ PP(pp_quotemeta) len--; } } + SvUTF8_on(TARG); } else { while (len--) { @@ -2536,7 +3307,7 @@ PP(pp_quotemeta) } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } else sv_setpvn(TARG, s, len); @@ -2648,13 +3419,28 @@ PP(pp_delete) U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); - while (++MARK <= SP) { - if (hvtype == SVt_PVHV) + if (hvtype == SVt_PVHV) { /* hash element */ + while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); - else - DIE(aTHX_ "Not a HASH reference"); - *MARK = sv ? sv : &PL_sv_undef; + *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 + DIE(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { @@ -2668,6 +3454,12 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) { + 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); + } else DIE(aTHX_ "Not a HASH reference"); if (!sv) @@ -2681,14 +3473,32 @@ PP(pp_delete) PP(pp_exists) { djSP; - SV *tmpsv = POPs; - HV *hv = (HV*)POPs; + SV *tmpsv; + HV *hv; + + if (PL_op->op_private & OPpEXISTS_SUB) { + GV *gv; + CV *cv; + SV *sv = POPs; + cv = sv_2cv(sv, &hv, &gv, FALSE); + if (cv) + RETPUSHYES; + if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) + RETPUSHYES; + RETPUSHNO; + } + tmpsv = POPs; + hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { - if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + if (av_exists((AV*)hv, SvIV(tmpsv))) + RETPUSHYES; + } + else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ RETPUSHYES; } else { @@ -2711,6 +3521,7 @@ PP(pp_hslice) while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; + I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; @@ -2723,8 +3534,15 @@ PP(pp_hslice) STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } - if (PL_op->op_private & OPpLVAL_INTRO) - save_helem(hv, keysv, svp); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (preeminent) + save_helem(hv, keysv, svp); + else { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + save_delete(hv, key, keylen); + } + } } *MARK = svp ? *svp : &PL_sv_undef; } @@ -2790,7 +3608,7 @@ PP(pp_lslice) ix = SvIVx(*lelem); if (ix < 0) ix += max; - else + else ix -= arybase; if (ix < 0 || ix >= max) *lelem = &PL_sv_undef; @@ -2827,8 +3645,8 @@ PP(pp_anonhash) SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); + else if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -2851,7 +3669,7 @@ PP(pp_splice) SV **tmparyval = 0; MAGIC *mg; - if (mg = SvTIED_mg((SV*)ary, 'P')) { + if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -3045,7 +3863,7 @@ PP(pp_push) register SV *sv = &PL_sv_undef; MAGIC *mg; - if (mg = SvTIED_mg((SV*)ary, 'P')) { + if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -3101,7 +3919,7 @@ PP(pp_unshift) register I32 i = 0; MAGIC *mg; - if (mg = SvTIED_mg((SV*)ary, 'P')) { + if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; @@ -3136,6 +3954,7 @@ PP(pp_reverse) *MARK++ = *SP; *SP-- = tmp; } + /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { @@ -3145,13 +3964,14 @@ PP(pp_reverse) dTARGET; STRLEN len; + SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) do_join(TARG, &PL_sv_no, MARK, SP); else sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); up = SvPV_force(TARG, len); if (len > 1) { - if (IN_UTF8) { /* first reverse each character */ + if (DO_UTF8(TARG)) { /* first reverse each character */ U8* s = (U8*)SvPVX(TARG); U8* send = (U8*)(s + len); while (s < send) { @@ -3184,7 +4004,7 @@ PP(pp_reverse) *up++ = *down; *down-- = tmp; } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } SP = MARK + 1; SETTARG; @@ -3236,7 +4056,7 @@ PP(pp_unpack) { djSP; dPOPPOPssrl; - SV **oldsp = SP; + I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; SV *sv; STRLEN llen; @@ -3249,18 +4069,19 @@ PP(pp_unpack) I32 datumtype; register I32 len; register I32 bits; + register char *str; /* These must not be in registers: */ - I16 ashort; + short ashort; int aint; - I32 along; -#ifdef Quad_t + long along; +#ifdef HAS_QUAD Quad_t aquad; #endif U16 aushort; unsigned int auint; U32 aulong; -#ifdef Quad_t +#ifdef HAS_QUAD Uquad_t auquad; #endif char *aptr; @@ -3335,8 +4156,8 @@ PP(pp_unpack) default: DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (commas++ == 0 && ckWARN(WARN_UNPACK)) + Perl_warner(aTHX_ WARN_UNPACK, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': @@ -3364,7 +4185,7 @@ PP(pp_unpack) s += len; break; case '/': - if (oldsp >= SP) + if (start_sp_offset >= SP - PL_stack_base) DIE(aTHX_ "/ must follow a numeric type"); datumtype = *pat++; if (*pat == '*') @@ -3444,8 +4265,7 @@ PP(pp_unpack) sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { @@ -3453,7 +4273,7 @@ PP(pp_unpack) bits >>= 1; else bits = *s++; - *pat++ = '0' + (bits & 1); + *str++ = '0' + (bits & 1); } } else { @@ -3463,11 +4283,10 @@ PP(pp_unpack) bits <<= 1; else bits = *s++; - *pat++ = '0' + ((bits & 128) != 0); + *str++ = '0' + ((bits & 128) != 0); } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': @@ -3477,8 +4296,7 @@ PP(pp_unpack) sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { @@ -3486,7 +4304,7 @@ PP(pp_unpack) bits >>= 4; else bits = *s++; - *pat++ = PL_hexdigit[bits & 15]; + *str++ = PL_hexdigit[bits & 15]; } } else { @@ -3496,11 +4314,10 @@ PP(pp_unpack) bits <<= 4; else bits = *s++; - *pat++ = PL_hexdigit[(bits >> 4) & 15]; + *str++ = PL_hexdigit[(bits >> 4) & 15]; } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': @@ -3553,7 +4370,9 @@ PP(pp_unpack) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; if (checksum > 32) cdouble += (NV)auint; @@ -3565,7 +4384,9 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; sv = NEWSV(37, 0); sv_setuv(sv, (UV)auint); @@ -3806,7 +4627,6 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3820,6 +4640,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -3838,7 +4661,6 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3851,6 +4673,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -3984,7 +4809,7 @@ PP(pp_unpack) char *t; STRLEN n_a; - sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -4018,7 +4843,7 @@ PP(pp_unpack) sv_setpvn(sv, aptr, len); PUSHs(sv_2mortal(sv)); break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': along = (strend - s) / sizeof(Quad_t); if (len > along) @@ -4119,9 +4944,9 @@ PP(pp_unpack) */ if (PL_uudmap['M'] == 0) { int i; - + for (i = 0; i < sizeof(PL_uuemap); i += 1) - PL_uudmap[PL_uuemap[i]] = i; + PL_uudmap[(U8)PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. @@ -4138,22 +4963,22 @@ PP(pp_unpack) char hunk[4]; hunk[3] = '\0'; - len = PL_uudmap[*s++] & 077; + len = PL_uudmap[*(U8*)s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) - a = PL_uudmap[*s++] & 077; + a = PL_uudmap[*(U8*)s++] & 077; else a = 0; if (s < strend && ISUUCHAR(*s)) - b = PL_uudmap[*s++] & 077; + b = PL_uudmap[*(U8*)s++] & 077; else b = 0; if (s < strend && ISUUCHAR(*s)) - c = PL_uudmap[*s++] & 077; + c = PL_uudmap[*(U8*)s++] & 077; else c = 0; if (s < strend && ISUUCHAR(*s)) - d = PL_uudmap[*s++] & 077; + d = PL_uudmap[*(U8*)s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); @@ -4204,7 +5029,7 @@ PP(pp_unpack) checksum = 0; } } - if (SP == oldsp && gimme == G_SCALAR) + if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) PUSHs(&PL_sv_undef); RETURN; } @@ -4321,6 +5146,7 @@ PP(pp_pack) register I32 items; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); + char *patcopy; register char *patend = pat + fromlen; register I32 len; I32 datumtype; @@ -4336,7 +5162,7 @@ PP(pp_pack) unsigned int auint; I32 along; U32 aulong; -#ifdef Quad_t +#ifdef HAS_QUAD Quad_t aquad; Uquad_t auquad; #endif @@ -4351,6 +5177,7 @@ PP(pp_pack) items = SP - MARK; MARK++; sv_setpvn(cat, "", 0); + patcopy = pat; while (pat < patend) { SV *lengthcode = Nullsv; #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) @@ -4358,8 +5185,12 @@ PP(pp_pack) #ifdef PERL_NATINT_PACK natint = 0; #endif - if (isSPACE(datumtype)) + if (isSPACE(datumtype)) { + patcopy++; continue; + } + if (datumtype == 'U' && pat == patcopy+1) + SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') pat++; @@ -4393,17 +5224,18 @@ PP(pp_pack) len = 1; if (*pat == '/') { ++pat; - if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*') + if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 - ? *MARK : &PL_sv_no))); + ? *MARK : &PL_sv_no) + + (*pat == 'Z' ? 1 : 0))); } switch(datumtype) { default: DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (commas++ == 0 && ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': @@ -4468,15 +5300,14 @@ PP(pp_pack) case 'B': case 'b': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); @@ -4487,7 +5318,7 @@ PP(pp_pack) items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { - items |= *pat++ & 1; + items |= *str++ & 1; if (len & 7) items <<= 1; else { @@ -4498,7 +5329,7 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (*pat++ & 1) + if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; @@ -4515,26 +5346,24 @@ PP(pp_pack) items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; case 'H': case 'h': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); @@ -4545,10 +5374,10 @@ PP(pp_pack) items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= ((*pat++ & 15) + 9) & 15; + if (isALPHA(*str)) + items |= ((*str++ & 15) + 9) & 15; else - items |= *pat++ & 15; + items |= *str++ & 15; if (len & 1) items <<= 4; else { @@ -4559,10 +5388,10 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= (((*pat++ & 15) + 9) & 15) << 4; + if (isALPHA(*str)) + items |= (((*str++ & 15) + 9) & 15) << 4; else - items |= (*pat++ & 15) << 4; + items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { @@ -4573,11 +5402,10 @@ PP(pp_pack) } if (aint & 1) *aptr++ = items & 0xff; - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; @@ -4594,7 +5422,7 @@ PP(pp_pack) while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); - SvGROW(cat, SvCUR(cat) + 10); + SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) - SvPVX(cat)); } @@ -4698,14 +5526,14 @@ PP(pp_pack) DIE(aTHX_ "Cannot compress negative numbers"); if ( -#ifdef BW_BITS - adouble <= BW_MASK +#if UVSIZE > 4 && UVSIZE >= NVSIZE + adouble <= 0xffffffff #else -#ifdef CXUX_BROKEN_CONSTANT_CONVERT +# ifdef CXUX_BROKEN_CONSTANT_CONVERT adouble <= UV_MAX_cxux -#else +# else adouble <= UV_MAX -#endif +# endif #endif ) { @@ -4748,8 +5576,9 @@ PP(pp_pack) do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; - if (--in < buf) /* this cannot happen ;-) */ + if (in <= buf) /* this cannot happen ;-) */ DIE(aTHX_ "Cannot compress integer"); + in--; adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ @@ -4828,7 +5657,7 @@ PP(pp_pack) } } break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'Q': while (len-- > 0) { fromstr = NEXTFROM; @@ -4843,7 +5672,7 @@ PP(pp_pack) sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; -#endif /* Quad_t */ +#endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ @@ -4859,9 +5688,13 @@ PP(pp_pack) * of pack() (and all copies of the result) are * gone. */ - if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) + || (SvPADTMP(fromstr) + && !SvREADONLY(fromstr)))) + { + Perl_warner(aTHX_ WARN_PACK, "Attempt to pack pointer to temporary value"); + } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else @@ -4904,8 +5737,9 @@ PP(pp_split) { djSP; dTARG; AV *ary; - register I32 limit = POPi; /* note, negative is forever */ + register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; + bool do_utf8 = DO_UTF8(sv); STRLEN len; register char *s = SvPV(sv, len); char *strend = s + len; @@ -4914,7 +5748,8 @@ PP(pp_split) register SV *dstr; register char *m; I32 iters = 0; - I32 maxiters = (strend - s) + 10; + STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); + I32 maxiters = slen + 10; I32 i; char *orig; I32 origlimit = limit; @@ -4932,7 +5767,7 @@ PP(pp_split) pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE(aTHX_ "panic: do_split"); + DIE(aTHX_ "panic: pp_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && @@ -4959,7 +5794,7 @@ PP(pp_split) av_extend(ary,0); av_clear(ary); SPAGAIN; - if (mg = SvTIED_mg((SV*)ary, 'P')) { + if ((mg = SvTIED_mg((SV*)ary, 'P'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)ary, mg)); } @@ -5008,6 +5843,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m + 1; @@ -5028,6 +5865,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m; } @@ -5037,11 +5876,11 @@ PP(pp_split) && !(rx->reganch & ROPT_ANCH)) { int tail = (rx->reganch & RE_INTUIT_TAIL); SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); - char c; len = rx->minlen; if (len == 1 && !tail) { - c = *SvPV(csv,len); + STRLEN n_a; + char c = *SvPV(csv, n_a); while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != c; m++) ; @@ -5051,8 +5890,12 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + 1; + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + s = m + (do_utf8 ? SvCUR(csv) : len); } } else { @@ -5066,15 +5909,19 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + len; /* Fake \n at the end */ + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + s = m + (do_utf8 ? SvCUR(csv) : len); /* Fake \n at the end */ } } } else { - maxiters += (strend - s) * rx->nparens; + maxiters += slen * rx->nparens; while (s < strend && --limit -/* && (!rx->check_substr +/* && (!rx->check_substr || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, 0, NULL)))) */ && CALLREGEXEC(aTHX_ rx, s, strend, orig, @@ -5093,6 +5940,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { @@ -5106,6 +5955,8 @@ PP(pp_split) dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); } } @@ -5120,10 +5971,13 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - dstr = NEWSV(34, strend-s); - sv_setpvn(dstr, s, strend-s); + STRLEN l = strend - s; + dstr = NEWSV(34, l); + sv_setpvn(dstr, s, l); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); iters++; } @@ -5180,7 +6034,6 @@ PP(pp_split) void Perl_unlock_condpair(pTHX_ void *svv) { - dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) @@ -5202,24 +6055,7 @@ PP(pp_lock) dTOPss; SV *retsv = sv; #ifdef USE_THREADS - MAGIC *mg; - - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } + sv_lock(sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { @@ -5231,8 +6067,8 @@ PP(pp_lock) PP(pp_threadsv) { - djSP; #ifdef USE_THREADS + djSP; EXTEND(SP, 1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(PL_op->op_targ));