X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=6746aa599434218fcdf6b74e66d12f0d23a3e6ed;hb=d8b46c1bb1e2856c8ae13cfa7f0b032537c8f918;hp=a42c611edb0138c223670080c1cc5651a47f38cc;hpb=097ee67dff1c60f201bc09435bc6eaeeafcd8123;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index a42c611..6746aa5 100644 --- a/pp.c +++ b/pp.c @@ -406,6 +406,8 @@ 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)) + Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; @@ -528,6 +530,12 @@ S_refto(pTHX_ SV *sv) else (void)SvREFCNT_inc(sv); } + else if (SvTYPE(sv) == SVt_PVAV) { + if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) + av_reify((AV*)sv); + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } else if (SvPADTMP(sv)) sv = newSVsv(sv); else { @@ -900,7 +908,7 @@ PP(pp_postinc) PP(pp_postdec) { djSP; dTARGET; - if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) Perl_croak(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -943,15 +951,15 @@ PP(pp_divide) djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; - double value; + NV value; if (right == 0.0) DIE(aTHX_ "Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { IV k; - if ((double)I_V(left) == left && - (double)I_V(right) == right && + 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; } @@ -976,8 +984,8 @@ PP(pp_modulo) bool left_neg; bool right_neg; bool use_double = 0; - double dright; - double dleft; + NV dright; + NV dleft; if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); @@ -1007,7 +1015,7 @@ PP(pp_modulo) } if (use_double) { - double dans; + NV dans; #if 1 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ @@ -1034,7 +1042,7 @@ PP(pp_modulo) if (!dright) DIE(aTHX_ "Illegal modulus zero"); - dans = fmod(dleft, dright); + dans = Perl_fmod(dleft, dright); if ((left_neg != right_neg) && dans) dans = dright - dans; if (right_neg) @@ -1057,7 +1065,7 @@ PP(pp_modulo) if (ans <= ~((UV)IV_MAX)+1) sv_setiv(TARG, ~ans+1); else - sv_setnv(TARG, -(double)ans); + sv_setnv(TARG, -(NV)ans); } else sv_setuv(TARG, ans); @@ -1624,7 +1632,7 @@ PP(pp_atan2) djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; - SETn(atan2(left, right)); + SETn(Perl_atan2(left, right)); RETURN; } } @@ -1633,9 +1641,9 @@ PP(pp_sin) { djSP; dTARGET; tryAMAGICun(sin); { - double value; + NV value; value = POPn; - value = sin(value); + value = Perl_sin(value); XPUSHn(value); RETURN; } @@ -1645,9 +1653,9 @@ PP(pp_cos) { djSP; dTARGET; tryAMAGICun(cos); { - double value; + NV value; value = POPn; - value = cos(value); + value = Perl_cos(value); XPUSHn(value); RETURN; } @@ -1671,7 +1679,7 @@ extern double drand48 (void); PP(pp_rand) { djSP; dTARGET; - double value; + NV value; if (MAXARG < 1) value = 1.0; else @@ -1776,9 +1784,9 @@ S_seed(pTHX) # endif #endif u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ - u += SEED_C5 * (U32)(UV)&when; + u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } @@ -1787,9 +1795,9 @@ PP(pp_exp) { djSP; dTARGET; tryAMAGICun(exp); { - double value; + NV value; value = POPn; - value = exp(value); + value = Perl_exp(value); XPUSHn(value); RETURN; } @@ -1799,13 +1807,13 @@ PP(pp_log) { djSP; dTARGET; tryAMAGICun(log); { - double value; + NV value; value = POPn; if (value <= 0.0) { RESTORE_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } - value = log(value); + value = Perl_log(value); XPUSHn(value); RETURN; } @@ -1815,13 +1823,13 @@ PP(pp_sqrt) { djSP; dTARGET; tryAMAGICun(sqrt); { - double value; + NV value; value = POPn; if (value < 0.0) { RESTORE_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } - value = sqrt(value); + value = Perl_sqrt(value); XPUSHn(value); RETURN; } @@ -1831,7 +1839,7 @@ PP(pp_int) { djSP; dTARGET; { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { @@ -1840,9 +1848,9 @@ PP(pp_int) } else { if (value >= 0.0) - (void)modf(value, &value); + (void)Perl_modf(value, &value); else { - (void)modf(-value, &value); + (void)Perl_modf(-value, &value); value = -value; } iv = I_V(value); @@ -1859,7 +1867,7 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && @@ -1885,14 +1893,14 @@ PP(pp_hex) STRLEN n_a; tmps = POPpx; - XPUSHu(scan_hex(tmps, 99, &argtype)); + XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { djSP; dTARGET; - UV value; + NV value; I32 argtype; char *tmps; STRLEN n_a; @@ -1908,7 +1916,7 @@ PP(pp_oct) value = scan_bin(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - XPUSHu(value); + XPUSHn(value); RETURN; } @@ -2052,74 +2060,24 @@ PP(pp_vec) register I32 offset = POPi; register SV *src = POPs; I32 lvalue = PL_op->op_flags & OPf_MOD; - STRLEN srclen; - unsigned char *s = (unsigned char*)SvPV(src, srclen); - unsigned long retnum; - I32 len; - SvTAINTED_off(TARG); /* decontaminate */ - offset *= size; /* turn into bit offset */ - len = (offset + size + 7) / 8; - if (offset < 0 || size < 1) - retnum = 0; - else { - if (lvalue) { /* it's an lvalue! */ - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, 'v', Nullch, 0); - } - - LvTYPE(TARG) = 'v'; - if (LvTARG(TARG) != src) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(src); - } - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; - } - if (len > srclen) { - if (size <= 8) - retnum = 0; - else { - offset >>= 3; - if (size == 16) { - if (offset >= srclen) - retnum = 0; - else - retnum = (unsigned long) s[offset] << 8; - } - else if (size == 32) { - if (offset >= srclen) - retnum = 0; - else if (offset + 1 >= srclen) - retnum = (unsigned long) s[offset] << 24; - else if (offset + 2 >= srclen) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16); - else - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8); - } - } + SvTAINTED_off(TARG); /* decontaminate */ + if (lvalue) { /* it's an lvalue! */ + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, 'v', Nullch, 0); } - else if (size < 8) - retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); - else { - offset >>= 3; - if (size == 8) - retnum = s[offset]; - else if (size == 16) - retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; - else if (size == 32) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8) + s[offset+3]; + LvTYPE(TARG) = 'v'; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); } + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; } - sv_setuv(TARG, (UV)retnum); + sv_setuv(TARG, do_vecget(src, offset, size)); PUSHs(TARG); RETURN; } @@ -2308,26 +2266,27 @@ PP(pp_ucfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toUPPER_LC(*s); + } + else + *s = toUPPER(*s); } - else - *s = toUPPER(*s); } - + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2364,27 +2323,28 @@ PP(pp_lcfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toLOWER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else - *s = toLOWER(*s); + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toLOWER_LC(*s); + } + else + *s = toLOWER(*s); + } + SETs(sv); } - - SETs(sv); + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2405,56 +2365,57 @@ PP(pp_uc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toUPPER_utf8( s )); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toUPPER_utf8( s )); + s += UTF8SKIP(s); + } } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; - - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else { - for (; s < send; s++) - *s = toUPPER(*s); + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; + + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toUPPER_LC(*s); + } + else { + for (; s < send; s++) + *s = toUPPER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2475,56 +2436,58 @@ PP(pp_lc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toLOWER_utf8(s)); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toLOWER_utf8(s)); + s += UTF8SKIP(s); + } } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } + else { + if (!SvPADTMP(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toLOWER_LC(*s); - } - else { - for (; s < send; s++) - *s = toLOWER(*s); + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toLOWER_LC(*s); + } + else { + for (; s < send; s++) + *s = toLOWER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2572,6 +2535,8 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETs(TARG); + if (SvSMAGICAL(TARG)) + mg_set(TARG); RETURN; } @@ -2624,7 +2589,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2639,12 +2604,13 @@ PP(pp_each) if (entry) { PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { + SV *val; PUTBACK; /* might clobber stack_sp */ - sv_setsv(TARG, realhv ? - hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); + val = realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); SPAGAIN; - PUSHs(TARG); + PUSHs(val); } } else if (gimme == G_SCALAR) @@ -3192,7 +3158,9 @@ PP(pp_reverse) s += UTF8SKIP(s); down = (char*)(s - 1); if (s > send || !((*down & 0xc0) == 0x80)) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, + "Malformed UTF-8 character"); break; } while (down > up) { @@ -3294,7 +3262,7 @@ PP(pp_unpack) double adouble; I32 checksum = 0; register U32 culong; - double cdouble; + NV cdouble; int commas = 0; #ifdef PERL_NATINT_PACK int natint; /* native integer */ @@ -3340,8 +3308,11 @@ PP(pp_unpack) } else if (isDIGIT(*pat)) { len = *pat++ - '0'; - while (isDIGIT(*pat)) + while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); + if (len < 0) + Perl_croak(aTHX_ "Repeat count in unpack overflows"); + } } else len = (datumtype != '@'); @@ -3376,6 +3347,18 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; + case '#': + if (oldsp >= SP) + DIE(aTHX_ "# must follow a numeric type"); + if (*pat != 'a' && *pat != 'A' && *pat != 'Z') + DIE(aTHX_ "# must be followed by a, A or Z"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "# cannot take a count" ); + len = POPi; + /* drop through */ case 'A': case 'Z': case 'a': @@ -3558,7 +3541,7 @@ PP(pp_unpack) auint = utf8_to_uv((U8*)s, &along); s += along; if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3586,6 +3569,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3612,6 +3596,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3651,6 +3636,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (unatint) { + unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); @@ -3680,6 +3666,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (unatint) { + unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); @@ -3718,7 +3705,7 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) - cdouble += (double)aint; + cdouble += (NV)aint; else culong += aint; } @@ -3769,7 +3756,7 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3804,11 +3791,12 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { + long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3824,7 +3812,7 @@ PP(pp_unpack) #endif s += SIZE32; if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3835,6 +3823,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { + long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3874,11 +3863,12 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (unatint) { + unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3898,7 +3888,7 @@ PP(pp_unpack) aulong = vtohl(aulong); #endif if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3909,6 +3899,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (unatint) { + unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); @@ -4030,7 +4021,7 @@ PP(pp_unpack) if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else - sv_setnv(sv, (double)aquad); + sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } break; @@ -4051,7 +4042,7 @@ PP(pp_unpack) if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else - sv_setnv(sv, (double)auquad); + sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -4076,7 +4067,7 @@ PP(pp_unpack) Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); - sv_setnv(sv, (double)afloat); + sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } @@ -4100,7 +4091,7 @@ PP(pp_unpack) Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); - sv_setnv(sv, (double)adouble); + sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } @@ -4168,7 +4159,7 @@ PP(pp_unpack) sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > 32 && strchr("iIlLNU", datumtype)) ) { - double trouble; + NV trouble; adouble = 1.0; while (checksum >= 16) { @@ -4184,7 +4175,7 @@ PP(pp_unpack) along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; - cdouble = modf(cdouble / adouble, &trouble) * adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { @@ -4346,7 +4337,8 @@ PP(pp_pack) MARK++; sv_setpvn(cat, "", 0); while (pat < patend) { -#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no) + SV *lengthcode = Nullsv; +#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; @@ -4371,17 +4363,28 @@ PP(pp_pack) } else if (isDIGIT(*pat)) { len = *pat++ - '0'; - while (isDIGIT(*pat)) + while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); + if (len < 0) + Perl_croak(aTHX_ "Repeat count in pack overflows"); + } } else len = 1; + if (*pat == '#') { + ++pat; + 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))); + } switch(datumtype) { default: Perl_croak(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, "Invalid type in pack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE(aTHX_ "%% may only be used in unpack"); @@ -4635,6 +4638,8 @@ PP(pp_pack) case 's': #if SHORTSIZE != SIZE16 if (natint) { + short ashort; + while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); @@ -4661,7 +4666,7 @@ PP(pp_pack) case 'w': while (len-- > 0) { fromstr = NEXTFROM; - adouble = floor(SvNV(fromstr)); + adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) Perl_croak(aTHX_ "Cannot compress negative numbers"); @@ -4758,6 +4763,8 @@ PP(pp_pack) case 'L': #if LONGSIZE != SIZE32 if (natint) { + unsigned long aulong; + while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); @@ -4777,6 +4784,8 @@ PP(pp_pack) case 'l': #if LONGSIZE != SIZE32 if (natint) { + long along; + while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); @@ -4797,7 +4806,7 @@ PP(pp_pack) case 'Q': while (len-- > 0) { fromstr = NEXTFROM; - auquad = (Uquad_t)SvIV(fromstr); + auquad = (Uquad_t)SvUV(fromstr); sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; @@ -4926,6 +4935,7 @@ PP(pp_split) else { if (!AvREAL(ary)) { AvREAL_on(ary); + AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } @@ -4991,17 +5001,19 @@ PP(pp_split) s = m; } } - else if (rx->check_substr && !rx->nparens + else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { - int tail = SvTAIL(rx->check_substr) != 0; + int tail = (rx->reganch & RE_INTUIT_TAIL); + SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); + char c; - i = SvCUR(rx->check_substr); - if (i == 1 && !tail) { - i = *SvPVX(rx->check_substr); + len = rx->minlen; + if (len == 1 && !tail) { + c = *SvPV(csv,len); while (--limit) { /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); @@ -5015,8 +5027,8 @@ PP(pp_split) else { #ifndef lint while (s < strend && --limit && - (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) ) + (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, + csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) #endif { dstr = NEWSV(31, m-s); @@ -5024,14 +5036,18 @@ PP(pp_split) if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); - s = m + i - tail; /* Fake \n at the end */ + s = m + len; /* Fake \n at the end */ } } } else { maxiters += (strend - s) * rx->nparens; - while (s < strend && --limit && - CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0)) + 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)) { TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { @@ -5171,7 +5187,7 @@ PP(pp_lock) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV