X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=30476bd7504a952a36b3bc81e65f32d2547b57a3;hb=71a29c3c6e68e84b4c2fa366c4878918712829a9;hp=786733e1b11395dbfbcb6b4d85f6963221b08bd5;hpb=31351b0411cad332df82232d3c7919b62fb21d0c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 786733e..30476bd 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) @@ -241,25 +210,30 @@ PP(pp_rv2gv) * 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 *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4); - name = SvPV(padname,len); + 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); + } + else { + name = CopSTASHPV(PL_curcop); + gv = newGVgen(name); } - gv_init(gv, PL_curcop->cop_stash, name, len, 0); sv_upgrade(sv, SVt_RV); - SvRV(sv) = (SV *) gv; + 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); @@ -315,7 +289,7 @@ 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); @@ -384,7 +358,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; @@ -406,6 +380,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)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; @@ -450,7 +426,7 @@ PP(pp_prototype) 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 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { @@ -467,7 +443,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -528,6 +504,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 { @@ -567,13 +549,13 @@ PP(pp_bless) HV *stash; if (MAXARG == 1) - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); else { SV *ssv = POPs; STRLEN len; char *ptr = SvPV(ssv,len); - if (ckWARN(WARN_UNSAFE) && len == 0) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_MISC) && len == 0) + Perl_warner(aTHX_ WARN_MISC, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -819,8 +801,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: @@ -840,7 +822,7 @@ PP(pp_undef) Newz(602, gp, 1, GP); GvGP(sv) = gp_ref(gp); GvSV(sv) = NEWSV(72,0); - GvLINE(sv) = PL_curcop->cop_line; + GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); } @@ -863,7 +845,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -880,7 +862,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -900,8 +882,8 @@ PP(pp_postinc) PP(pp_postdec) { djSP; dTARGET; - if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + if (SvREADONLY(TOPs) || 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) @@ -923,7 +905,7 @@ PP(pp_pow) djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; - SETn( pow( left, right) ); + SETn( Perl_pow( left, right) ); RETURN; } } @@ -943,15 +925,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 +958,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 +989,7 @@ PP(pp_modulo) } if (use_double) { - double dans; + NV dans; #if 1 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ @@ -1028,13 +1010,13 @@ 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"); - dans = fmod(dleft, dright); + dans = Perl_fmod(dleft, dright); if ((left_neg != right_neg) && dans) dans = dright - dans; if (right_neg) @@ -1057,7 +1039,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); @@ -1131,16 +1113,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; } @@ -1150,16 +1130,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; } @@ -1221,7 +1199,21 @@ PP(pp_ncmp) { dPOPTOPnnrl; I32 value; +#ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */ +#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +#define Perl_isnan isnanl +#else +#define Perl_isnan isnan +#endif +#endif +#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */ + 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) @@ -1232,6 +1224,7 @@ PP(pp_ncmp) SETs(&PL_sv_undef); RETURN; } +#endif SETi(value); RETURN; } @@ -1329,12 +1322,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 { @@ -1352,12 +1345,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 { @@ -1375,12 +1368,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 { @@ -1398,9 +1391,23 @@ PP(pp_negate) dTOPss; 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 (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { + if (SvIsUV(sv)) { + if (SvIVX(sv) == IV_MIN) { + 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; + } + } + if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; @@ -1413,7 +1420,7 @@ 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); } @@ -1441,12 +1448,12 @@ 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 { @@ -1624,7 +1631,7 @@ PP(pp_atan2) djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; - SETn(atan2(left, right)); + SETn(Perl_atan2(left, right)); RETURN; } } @@ -1633,9 +1640,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 +1652,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 +1678,7 @@ extern double drand48 (void); PP(pp_rand) { djSP; dTARGET; - double value; + NV value; if (MAXARG < 1) value = 1.0; else @@ -1775,10 +1782,10 @@ S_seed(pTHX) u = (U32)SEED_C1 * when; # endif #endif - u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + 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)(UV)&when; + u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } @@ -1787,9 +1794,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 +1806,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 +1822,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 +1838,7 @@ PP(pp_int) { djSP; dTARGET; { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { @@ -1840,9 +1847,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 +1866,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 +1892,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 +1915,7 @@ PP(pp_oct) value = scan_bin(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - XPUSHu(value); + XPUSHn(value); RETURN; } @@ -1917,13 +1924,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; } @@ -1944,6 +1950,7 @@ PP(pp_substr) STRLEN repl_len; SvTAINTED_off(TARG); /* decontaminate */ + SvUTF8_off(TARG); /* decontaminate */ if (MAXARG > 2) { if (MAXARG > 3) { sv = POPs; @@ -1955,7 +1962,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; @@ -1999,16 +2006,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); + SvUTF8_on(TARG); + } tmps += pos; sv_setpvn(TARG, tmps, rem); - if (lvalue) { /* it's an lvalue! */ + 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; @@ -2037,8 +2050,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 */ @@ -2052,74 +2063,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; } @@ -2143,7 +2104,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; @@ -2154,7 +2115,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; @@ -2182,7 +2143,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; } @@ -2195,7 +2156,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; @@ -2216,10 +2177,11 @@ PP(pp_ord) djSP; dTARGET; UV value; STRLEN n_a; - U8 *tmps = (U8*)POPpx; + SV *tmpsv = POPs; + U8 *tmps = (U8*)SvPVx(tmpsv,n_a); I32 retlen; - if (IN_UTF8 && (*tmps & 0x80)) + if ((*tmps & 0x80) && DO_UTF8(tmpsv)) value = utf8_to_uv(tmps, &retlen); else value = (UV)(*tmps & 255); @@ -2235,13 +2197,14 @@ PP(pp_chr) (void)SvUPGRADE(TARG,SVt_PV); - if (IN_UTF8 && value >= 128) { - SvGROW(TARG,8); + if (value > 255 && !IN_BYTE) { + 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; } @@ -2251,6 +2214,7 @@ PP(pp_chr) tmps = SvPVX(TARG); *tmps++ = value; *tmps = '\0'; + SvUTF8_off(TARG); /* decontaminate */ (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; @@ -2282,9 +2246,9 @@ PP(pp_ucfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN]; U8 *tend; UV uv = utf8_to_uv(s, &ulen); @@ -2298,19 +2262,22 @@ 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 { s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - } else { - if (!SvPADTMP(sv)) { + } + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2338,9 +2305,9 @@ PP(pp_lcfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN]; U8 *tend; UV uv = utf8_to_uv(s, &ulen); @@ -2354,19 +2321,22 @@ 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 { s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - } else { - if (!SvPADTMP(sv)) { + } + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2381,7 +2351,6 @@ PP(pp_lcfirst) else *s = toLOWER(*s); } - SETs(sv); } if (SvSMAGICAL(sv)) mg_set(sv); @@ -2395,7 +2364,7 @@ PP(pp_uc) register U8 *s; STRLEN len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { dTARGET; I32 ulen; register U8 *d; @@ -2403,9 +2372,11 @@ PP(pp_uc) s = (U8*)SvPV(sv,len); if (!len) { + SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); - } else { + } + else { (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); (void)SvPOK_only(TARG); @@ -2426,12 +2397,15 @@ PP(pp_uc) } } *d = '\0'; + SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } - } else { - if (!SvPADTMP(sv)) { + } + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2464,7 +2438,7 @@ PP(pp_lc) register U8 *s; STRLEN len; - if (IN_UTF8) { + if (DO_UTF8(sv)) { dTARGET; I32 ulen; register U8 *d; @@ -2472,9 +2446,11 @@ PP(pp_lc) s = (U8*)SvPV(sv,len); if (!len) { + SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); - } else { + } + else { (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); (void)SvPOK_only(TARG); @@ -2495,12 +2471,15 @@ PP(pp_lc) } } *d = '\0'; + SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } - } else { - if (!SvPADTMP(sv)) { + } + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); @@ -2535,11 +2514,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); @@ -2556,6 +2536,7 @@ PP(pp_quotemeta) len--; } } + SvUTF8_on(TARG); } else { while (len--) { @@ -2625,7 +2606,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2640,12 +2621,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) @@ -2677,13 +2659,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) { @@ -2697,6 +2694,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) @@ -2710,14 +2713,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 { @@ -2856,8 +2877,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; @@ -2880,7 +2901,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; @@ -3074,7 +3095,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; @@ -3130,7 +3151,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; @@ -3165,6 +3186,7 @@ PP(pp_reverse) *MARK++ = *SP; *SP-- = tmp; } + /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { @@ -3174,13 +3196,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) { @@ -3193,7 +3216,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) { @@ -3263,7 +3288,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; @@ -3276,6 +3301,7 @@ PP(pp_unpack) I32 datumtype; register I32 len; register I32 bits; + register char *str; /* These must not be in registers: */ I16 ashort; @@ -3295,8 +3321,9 @@ PP(pp_unpack) double adouble; I32 checksum = 0; register U32 culong; - double cdouble; + NV cdouble; int commas = 0; + int star; #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ @@ -3321,6 +3348,11 @@ PP(pp_unpack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -3331,27 +3363,34 @@ PP(pp_unpack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } + star = 0; if (pat >= patend) len = 1; else if (*pat == '*') { len = strend - strbeg; /* long enough */ pat++; + star = 1; } else if (isDIGIT(*pat)) { len = *pat++ - '0'; - while (isDIGIT(*pat)) + while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in unpack overflows"); + } } else len = (datumtype != '@'); + redo_switch: switch(datumtype) { default: - Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); + 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, "Invalid type in unpack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_UNPACK)) + Perl_warner(aTHX_ WARN_UNPACK, + "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3377,6 +3416,17 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; + case '/': + if (start_sp_offset >= SP - PL_stack_base) + DIE(aTHX_ "/ must follow a numeric type"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "/ cannot take a count" ); + len = POPi; + star = 0; + goto redo_switch; case 'A': case 'Z': case 'a': @@ -3407,7 +3457,7 @@ PP(pp_unpack) break; case 'B': case 'b': - if (pat[-1] == '*' || len > (strend - s) * 8) + if (star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { if (!PL_bitcount) { @@ -3447,8 +3497,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++) { @@ -3456,7 +3505,7 @@ PP(pp_unpack) bits >>= 1; else bits = *s++; - *pat++ = '0' + (bits & 1); + *str++ = '0' + (bits & 1); } } else { @@ -3466,22 +3515,20 @@ 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': case 'h': - if (pat[-1] == '*' || len > (strend - s) * 2) + if (star || len > (strend - s) * 2) len = (strend - s) * 2; 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++) { @@ -3489,7 +3536,7 @@ PP(pp_unpack) bits >>= 4; else bits = *s++; - *pat++ = PL_hexdigit[bits & 15]; + *str++ = PL_hexdigit[bits & 15]; } } else { @@ -3499,11 +3546,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': @@ -3559,7 +3605,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; } @@ -3587,6 +3633,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3613,6 +3660,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); @@ -3652,6 +3700,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); @@ -3681,6 +3730,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); @@ -3719,7 +3769,7 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) - cdouble += (double)aint; + cdouble += (NV)aint; else culong += aint; } @@ -3770,7 +3820,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; } @@ -3805,11 +3855,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; } @@ -3825,7 +3876,7 @@ PP(pp_unpack) #endif s += SIZE32; if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3836,6 +3887,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); @@ -3875,11 +3927,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; } @@ -3899,7 +3952,7 @@ PP(pp_unpack) aulong = vtohl(aulong); #endif if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3910,6 +3963,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); @@ -3997,7 +4051,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4031,7 +4085,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; @@ -4052,7 +4106,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; @@ -4077,7 +4131,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)); } } @@ -4101,7 +4155,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)); } } @@ -4116,7 +4170,7 @@ PP(pp_unpack) 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. @@ -4133,22 +4187,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); @@ -4169,7 +4223,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) { @@ -4185,7 +4239,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 { @@ -4199,7 +4253,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; } @@ -4347,13 +4401,19 @@ 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; #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -4364,7 +4424,7 @@ PP(pp_pack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4372,17 +4432,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) + DIE(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); + 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, "Invalid type in pack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, + "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE(aTHX_ "%% may only be used in unpack"); @@ -4414,10 +4485,16 @@ PP(pp_pack) case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); - if (pat[-1] == '*') + if (pat[-1] == '*') { len = fromlen; - if (fromlen > len) + if (datumtype == 'Z') + ++len; + } + if (fromlen >= len) { sv_catpvn(cat, aptr, len); + if (datumtype == 'Z') + *(SvEND(cat)-1) = '\0'; + } else { sv_catpvn(cat, aptr, fromlen); len -= fromlen; @@ -4440,15 +4517,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); @@ -4459,7 +4535,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 { @@ -4470,7 +4546,7 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (*pat++ & 1) + if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; @@ -4487,26 +4563,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); @@ -4517,10 +4591,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 { @@ -4531,10 +4605,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 { @@ -4545,11 +4619,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; @@ -4566,7 +4639,7 @@ PP(pp_pack) while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); - SvGROW(cat, SvCUR(cat) + 10); + SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN); SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) - SvPVX(cat)); } @@ -4636,6 +4709,8 @@ PP(pp_pack) case 's': #if SHORTSIZE != SIZE16 if (natint) { + short ashort; + while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); @@ -4662,21 +4737,17 @@ 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"); + DIE(aTHX_ "Cannot compress negative numbers"); if ( -#ifdef BW_BITS - adouble <= BW_MASK -#else #ifdef CXUX_BROKEN_CONSTANT_CONVERT adouble <= UV_MAX_cxux #else adouble <= UV_MAX #endif -#endif ) { char buf[1 + sizeof(UV)]; @@ -4699,7 +4770,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4719,14 +4790,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - Perl_croak(aTHX_ "Cannot compress integer"); + DIE(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else - Perl_croak(aTHX_ "Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -4759,6 +4830,8 @@ PP(pp_pack) case 'L': #if LONGSIZE != SIZE32 if (natint) { + unsigned long aulong; + while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); @@ -4778,6 +4851,8 @@ PP(pp_pack) case 'l': #if LONGSIZE != SIZE32 if (natint) { + long along; + while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); @@ -4798,7 +4873,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; @@ -4809,7 +4884,7 @@ PP(pp_pack) sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; -#endif /* HAS_QUAD */ +#endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ @@ -4825,9 +4900,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 +4983,13 @@ PP(pp_split) TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); - if (pm->op_pmreplroot) + if (pm->op_pmreplroot) { +#ifdef USE_ITHREADS + ary = GvAVn((GV*)PL_curpad[(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]; @@ -4920,13 +5004,14 @@ 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)); } 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 */ } @@ -4992,17 +5077,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); @@ -5016,8 +5103,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); @@ -5025,14 +5112,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) { @@ -5144,8 +5235,8 @@ Perl_unlock_condpair(pTHX_ void *svv) Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", - (unsigned long)thr, (unsigned long)svv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(svv));) MUTEX_UNLOCK(MgMUTEXP(mg)); } #endif /* USE_THREADS */ @@ -5169,10 +5260,10 @@ PP(pp_lock) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", - (unsigned long)thr, (unsigned long)sv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV @@ -5185,8 +5276,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));