X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=8a31fff8812e3a850830682b989c9815c8aaac53;hb=90248788f819cf7b59aabb5259fdd6d66bc4632b;hp=78596064475bfd5543bf27cc1344deea82cabe88;hpb=ff0cee690d2ef6ba882e59dd4baaa0c944adb7a2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 7859606..8a31fff 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,6 @@ /* pp.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, 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. @@ -16,6 +16,17 @@ #include "perl.h" /* + * The compiler on Concurrent CX/UX systems has a subtle bug which only + * seems to show up when compiling pp.c - it generates the wrong double + * precision constant value for (double)UV_MAX when used inline in the body + * of the code below, so this makes a static variable up front (which the + * compiler seems to get correct) and uses it in place of UV_MAX below. + */ +#ifdef CXUX_BROKEN_CONSTANT_CONVERT +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 @@ -23,23 +34,82 @@ * 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 everywhere, at - * least today. + * It just so happens that "int" is the right size almost everywhere. */ typedef int IBW; typedef unsigned UBW; -static SV* refto _((SV* sv)); +/* + * 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 BYTEORDER > 0xFFFF && 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, + * which for now are all Crays, pack and unpack have to play games. + */ + +/* + * These values are required for portability of pack() output. + * If they're not right on your machine, then pack() and unpack() + * wouldn't work right anyway; you'll need to apply the Cray hack. + * (I'd like to check them with #if, but you can't use sizeof() in + * the preprocessor.) + */ +#define SIZE16 2 +#define SIZE32 4 + +#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) +# if BYTEORDER == 0x12345678 +# define OFF16(p) (char*)(p) +# define OFF32(p) (char*)(p) +# else +# if BYTEORDER == 0x87654321 +# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) +# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) +# else + }}}} bad cray byte order +# endif +# endif +# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) +# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) +# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) +# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) +#else +# define COPY16(s,p) Copy(s, p, SIZE16, char) +# define COPY32(s,p) Copy(s, p, SIZE32, char) +# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) +# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) +#endif + static void doencodes _((SV* sv, char* s, I32 len)); +static SV* refto _((SV* sv)); +static U32 seed _((void)); + +static bool srand_called = FALSE; /* variations on pp_null */ PP(pp_stub) { dSP; - if (GIMME != G_ARRAY) { + if (GIMME_V == G_SCALAR) XPUSHs(&sv_undef); - } RETURN; } @@ -78,25 +148,27 @@ PP(pp_padav) PP(pp_padhv) { dSP; dTARGET; + I32 gimme; + XPUSHs(TARG); if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); if (op->op_flags & OPf_REF) RETURN; - if (GIMME == G_ARRAY) { /* array wanted */ + gimme = GIMME_V; + if (gimme == G_ARRAY) { RETURNOP(do_kv(ARGS)); } - else { + else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); - if (HvFILL((HV*)TARG)) { - sprintf(buf, "%d/%d", HvFILL((HV*)TARG), HvMAX((HV*)TARG)+1); - sv_setpv(sv, buf); - } + if (HvFILL((HV*)TARG)) + sv_setpvf(sv, "%ld/%ld", + (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); else sv_setiv(sv, 0); SETs(sv); - RETURN; } + RETURN; } PP(pp_padany) @@ -117,7 +189,7 @@ PP(pp_rv2gv) GV *gv = (GV*) sv_newmortal(); gv_init(gv, 0, "", 0, 0); GvIOp(gv) = (IO *)sv; - SvREFCNT_inc(sv); + (void)SvREFCNT_inc(sv); sv = (SV*) gv; } else if (SvTYPE(sv) != SVt_PVGV) DIE("Not a GLOB reference"); @@ -135,6 +207,8 @@ PP(pp_rv2gv) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); + if (dowarn) + warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); @@ -177,6 +251,8 @@ PP(pp_rv2sv) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); + if (dowarn) + warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); @@ -190,7 +266,7 @@ PP(pp_rv2sv) if (op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); else if (op->op_private & OPpDEREF) - provide_ref(op, sv); + vivify_ref(sv, op->op_private & OPpDEREF); } SETs(sv); RETURN; @@ -313,9 +389,9 @@ SV* sv; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { if (LvTARGLEN(sv)) - vivify_itervar(sv); - if (LvTARG(sv)) - sv = LvTARG(sv); + vivify_defelem(sv); + if (!(sv = LvTARG(sv))) + sv = &sv_undef; } else if (SvPADTMP(sv)) sv = newSVsv(sv); @@ -374,13 +450,12 @@ PP(pp_study) register I32 ch; register I32 *sfirst; register I32 *snext; - I32 retval; STRLEN len; - s = (unsigned char*)(SvPV(sv, len)); - pos = len; - if (sv == lastscream) - SvSCREAM_off(sv); + if (sv == lastscream) { + if (SvSCREAM(sv)) + RETPUSHYES; + } else { if (lastscream) { SvSCREAM_off(lastscream); @@ -388,10 +463,11 @@ PP(pp_study) } lastscream = SvREFCNT_inc(sv); } - if (pos <= 0) { - retval = 0; - goto ret; - } + + s = (unsigned char*)(SvPV(sv, len)); + pos = len; + if (pos <= 0) + RETPUSHNO; if (pos > maxscream) { if (maxscream < 0) { maxscream = pos + 80; @@ -425,10 +501,7 @@ PP(pp_study) SvSCREAM_on(sv); sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */ - retval = 1; - ret: - XPUSHs(sv_2mortal(newSViv((I32)retval))); - RETURN; + RETPUSHYES; } PP(pp_trans) @@ -545,14 +618,21 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - cv_undef((CV*)sv); + if (cv_const_sv((CV*)sv)) + warn("Constant subroutine %s undefined", + CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); + /* FALL THROUGH */ + case SVt_PVFM: + { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); + cv_undef((CV*)sv); + CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */ break; case SVt_PVGV: if (SvFAKE(sv)) sv_setsv(sv, &sv_undef); break; default: - if (SvPOK(sv) && SvLEN(sv)) { + if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { (void)SvOOK_off(sv); Safefree(SvPVX(sv)); SvPV_set(sv, Nullch); @@ -568,7 +648,7 @@ PP(pp_undef) PP(pp_predec) { dSP; - if (SvREADONLY(TOPs)) + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -585,7 +665,7 @@ PP(pp_predec) PP(pp_postinc) { dSP; dTARGET; - if (SvREADONLY(TOPs)) + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); sv_setsv(TARG, TOPs); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -606,7 +686,7 @@ PP(pp_postinc) PP(pp_postdec) { dSP; dTARGET; - if(SvREADONLY(TOPs)) + if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); sv_setsv(TARG, TOPs); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -676,26 +756,47 @@ PP(pp_modulo) { dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); { - register UV right; + UV left; + UV right; + bool left_neg; + bool right_neg; + UV ans; - right = POPu; - if (!right) - DIE("Illegal modulus zero"); + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + IV i = SvIVX(POPs); + right = (right_neg = (i < 0)) ? -i : i; + } + else { + double n = POPn; + right = U_V((right_neg = (n < 0)) ? -n : n); + } if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { - register IV left = SvIVX(TOPs); - if (left < 0) - SETu( (right - ((UV)(-left) - 1) % right) - 1 ); - else - SETi( left % right ); + IV i = SvIVX(POPs); + left = (left_neg = (i < 0)) ? -i : i; } else { - register double left = TOPn; - if (left < 0.0) - SETu( (right - (U_V(-left) - 1) % right) - 1 ); + double n = POPn; + left = U_V((left_neg = (n < 0)) ? -n : n); + } + + if (!right) + DIE("Illegal modulus zero"); + + ans = left % right; + if ((left_neg != right_neg) && ans) + ans = right - ans; + if (right_neg) { + /* XXX may warn: unary minus operator applied to unsigned type */ + /* could change -foo to be (~foo)+1 instead */ + if (ans <= -(UV)IV_MAX) + sv_setiv(TARG, (IV) -ans); else - SETu( U_V(left) % right ); + sv_setnv(TARG, -(double)ans); } + else + sv_setuv(TARG, ans); + PUSHTARG; RETURN; } } @@ -773,11 +874,13 @@ PP(pp_left_shift) IBW shift = POPi; if (op->op_private & HINT_INTEGER) { IBW i = TOPi; - SETi( i << shift ); + i = BWi(i) << shift; + SETi(BWi(i)); } else { UBW u = TOPu; - SETu( u << shift ); + u <<= shift; + SETu(BWu(u)); } RETURN; } @@ -790,11 +893,13 @@ PP(pp_right_shift) IBW shift = POPi; if (op->op_private & HINT_INTEGER) { IBW i = TOPi; - SETi( i >> shift ); + i = BWi(i) >> shift; + SETi(BWi(i)); } else { UBW u = TOPu; - SETu( u >> shift ); + u >>= shift; + SETu(BWu(u)); } RETURN; } @@ -805,7 +910,7 @@ PP(pp_lt) dSP; tryAMAGICbinSET(lt,0); { dPOPnv; - SETs((TOPn < value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn < value)); RETURN; } } @@ -815,7 +920,7 @@ PP(pp_gt) dSP; tryAMAGICbinSET(gt,0); { dPOPnv; - SETs((TOPn > value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn > value)); RETURN; } } @@ -825,7 +930,7 @@ PP(pp_le) dSP; tryAMAGICbinSET(le,0); { dPOPnv; - SETs((TOPn <= value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn <= value)); RETURN; } } @@ -835,7 +940,7 @@ PP(pp_ge) dSP; tryAMAGICbinSET(ge,0); { dPOPnv; - SETs((TOPn >= value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn >= value)); RETURN; } } @@ -845,7 +950,7 @@ PP(pp_ne) dSP; tryAMAGICbinSET(ne,0); { dPOPnv; - SETs((TOPn != value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn != value)); RETURN; } } @@ -880,7 +985,7 @@ PP(pp_slt) int cmp = ((op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); - SETs( cmp < 0 ? &sv_yes : &sv_no ); + SETs(boolSV(cmp < 0)); RETURN; } } @@ -893,7 +998,7 @@ PP(pp_sgt) int cmp = ((op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); - SETs( cmp > 0 ? &sv_yes : &sv_no ); + SETs(boolSV(cmp > 0)); RETURN; } } @@ -906,7 +1011,7 @@ PP(pp_sle) int cmp = ((op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); - SETs( cmp <= 0 ? &sv_yes : &sv_no ); + SETs(boolSV(cmp <= 0)); RETURN; } } @@ -919,7 +1024,7 @@ PP(pp_sge) int cmp = ((op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); - SETs( cmp >= 0 ? &sv_yes : &sv_no ); + SETs(boolSV(cmp >= 0)); RETURN; } } @@ -929,7 +1034,7 @@ PP(pp_seq) dSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; - SETs( sv_eq(left, right) ? &sv_yes : &sv_no ); + SETs(boolSV(sv_eq(left, right))); RETURN; } } @@ -939,7 +1044,7 @@ PP(pp_sne) dSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; - SETs( !sv_eq(left, right) ? &sv_yes : &sv_no ); + SETs(boolSV(!sv_eq(left, right))); RETURN; } } @@ -965,11 +1070,11 @@ PP(pp_bit_and) if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { IBW value = SvIV(left) & SvIV(right); - SETi( value ); + SETi(BWi(value)); } else { UBW value = SvUV(left) & SvUV(right); - SETu( value ); + SETu(BWu(value)); } } else { @@ -988,11 +1093,11 @@ PP(pp_bit_xor) if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi( value ); + SETi(BWi(value)); } else { UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); - SETu( value ); + SETu(BWu(value)); } } else { @@ -1011,11 +1116,11 @@ PP(pp_bit_or) if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi( value ); + SETi(BWi(value)); } else { UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); - SETu( value ); + SETu(BWu(value)); } } else { @@ -1063,7 +1168,7 @@ PP(pp_not) #ifdef OVERLOAD dSP; tryAMAGICunSET(not); #endif /* OVERLOAD */ - *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes; + *stack_sp = boolSV(!SvTRUE(*stack_sp)); return NORMAL; } @@ -1075,11 +1180,11 @@ PP(pp_complement) if (SvNIOKp(sv)) { if (op->op_private & HINT_INTEGER) { IBW value = ~SvIV(sv); - SETi( value ); + SETi(BWi(value)); } else { UBW value = ~SvUV(sv); - SETu( value ); + SETu(BWu(value)); } } else { @@ -1170,7 +1275,7 @@ PP(pp_i_lt) dSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; - SETs((left < right) ? &sv_yes : &sv_no); + SETs(boolSV(left < right)); RETURN; } } @@ -1180,7 +1285,7 @@ PP(pp_i_gt) dSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; - SETs((left > right) ? &sv_yes : &sv_no); + SETs(boolSV(left > right)); RETURN; } } @@ -1190,7 +1295,7 @@ PP(pp_i_le) dSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; - SETs((left <= right) ? &sv_yes : &sv_no); + SETs(boolSV(left <= right)); RETURN; } } @@ -1200,7 +1305,7 @@ PP(pp_i_ge) dSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; - SETs((left >= right) ? &sv_yes : &sv_no); + SETs(boolSV(left >= right)); RETURN; } } @@ -1210,7 +1315,7 @@ PP(pp_i_eq) dSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; - SETs((left == right) ? &sv_yes : &sv_no); + SETs(boolSV(left == right)); RETURN; } } @@ -1220,7 +1325,7 @@ PP(pp_i_ne) dSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; - SETs((left != right) ? &sv_yes : &sv_no); + SETs(boolSV(left != right)); RETURN; } } @@ -1296,6 +1401,10 @@ PP(pp_rand) value = POPn; if (value == 0.0) value = 1.0; + if (!srand_called) { + (void)srand((unsigned)seed()); + srand_called = TRUE; + } #if RANDBITS == 31 value = rand() * value / 2147483648.0; #else @@ -1316,38 +1425,67 @@ PP(pp_rand) PP(pp_srand) { dSP; - I32 anum; + UV anum; + if (MAXARG < 1) + anum = seed(); + else + anum = POPu; + (void)srand((unsigned)anum); + srand_called = TRUE; + EXTEND(SP, 1); + RETPUSHYES; +} + +static U32 +seed() +{ + /* + * This is really just a quick hack which grabs various garbage + * values. It really should be a real hash algorithm which + * spreads the effect of every input bit onto every output bit, + * if someone who knows about such tings would bother to write it. + * Might be a good idea to add that function to CORE as well. + * No numbers below come from careful analysis or anyting here, + * except they are primes and SEED_C1 > 1E6 to get a full-width + * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should + * probably be bigger too. + */ +#if RANDBITS > 16 +# define SEED_C1 1000003 +#define SEED_C4 73819 +#else +# define SEED_C1 25747 +#define SEED_C4 20639 +#endif +#define SEED_C2 3 +#define SEED_C3 269 +#define SEED_C5 26107 - if (MAXARG < 1) { + U32 u; #ifdef VMS # include - unsigned int when[2]; - _ckvmssts(sys$gettim(when)); - anum = when[0] ^ when[1]; + /* when[] = (low 32 bits, high 32 bits) of time since epoch + * in 100-ns units, typically incremented ever 10 ms. */ + unsigned int when[2]; + _ckvmssts(sys$gettim(when)); + u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY - struct timeval when; - gettimeofday(&when,(struct timezone *) 0); - anum = when.tv_sec ^ when.tv_usec; + struct timeval when; + gettimeofday(&when,(struct timezone *) 0); + u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else - Time_t when; - (void)time(&when); - anum = when; + Time_t when; + (void)time(&when); + u = (U32)SEED_C1 * when; # endif #endif -#if !defined(PLAN9) /* XXX Plan9 assembler chokes on this; fix coming soon */ - /* 17-Jul-1996 bailey@genetics.upenn.edu */ - /* What is a good hashing algorithm here? */ - anum ^= ( ( 269 * (U32)getpid()) - ^ (26107 * (U32)&when) - ^ (73819 * (U32)stack_sp)); + u += SEED_C3 * (U32)getpid(); + u += SEED_C4 * (U32)(UV)stack_sp; +#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ + u += SEED_C5 * (U32)(UV)&when; #endif - } - else - anum = POPi; - (void)srand(anum); - EXTEND(SP, 1); - RETPUSHYES; + return u; } PP(pp_exp) @@ -1492,34 +1630,56 @@ PP(pp_substr) STRLEN curlen; I32 pos; I32 rem; + I32 fail; I32 lvalue = op->op_flags & OPf_MOD; char *tmps; I32 arybase = curcop->cop_arybase; if (MAXARG > 2) len = POPi; - pos = POPi - arybase; + pos = POPi; sv = POPs; tmps = SvPV(sv, curlen); - if (pos < 0) - pos += curlen + arybase; - if (pos < 0 || pos > curlen) { - if (dowarn || lvalue) + if (pos >= arybase) { + pos -= arybase; + rem = curlen-pos; + fail = rem; + if (MAXARG > 2) { + if (len < 0) { + rem += len; + if (rem < 0) + rem = 0; + } + else if (rem > len) + rem = len; + } + } + else { + pos += curlen; + if (MAXARG < 3) + rem = curlen; + else if (len >= 0) { + rem = pos+len; + if (rem > (I32)curlen) + rem = curlen; + } + else { + rem = curlen+len; + if (rem < pos) + rem = pos; + } + if (pos < 0) + pos = 0; + fail = rem; + rem -= pos; + } + if (fail < 0) { + if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } else { - if (MAXARG < 3) - len = curlen; - else if (len < 0) { - len += curlen - pos; - if (len < 0) - len = 0; - } tmps += pos; - rem = curlen - pos; /* rem=how many bytes left*/ - if (rem > len) - rem = len; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { @@ -1618,7 +1778,7 @@ PP(pp_vec) } } - sv_setiv(TARG, (I32)retnum); + sv_setiv(TARG, (IV)retnum); PUSHs(TARG); RETURN; } @@ -1957,22 +2117,23 @@ PP(pp_each) dSP; dTARGET; HV *hash = (HV*)POPs; HE *entry; + I32 gimme = GIMME_V; PUTBACK; - entry = hv_iternext(hash); /* might clobber stack_sp */ + entry = hv_iternext(hash); /* might clobber stack_sp */ SPAGAIN; EXTEND(SP, 2); if (entry) { - PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ - if (GIMME == G_ARRAY) { + PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ + if (gimme == G_ARRAY) { PUTBACK; - sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */ + sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */ SPAGAIN; PUSHs(TARG); } } - else if (GIMME == G_SCALAR) + else if (gimme == G_SCALAR) RETPUSHUNDEF; RETURN; @@ -1991,6 +2152,8 @@ PP(pp_keys) PP(pp_delete) { dSP; + I32 gimme = GIMME_V; + I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; HV *hv; @@ -2000,11 +2163,12 @@ PP(pp_delete) if (SvTYPE(hv) != SVt_PVHV) DIE("Not a HASH reference"); while (++MARK <= SP) { - sv = hv_delete_ent(hv, *MARK, - (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); + sv = hv_delete_ent(hv, *MARK, discard, 0); *MARK = sv ? sv : &sv_undef; } - if (GIMME != G_ARRAY) { + if (discard) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; @@ -2015,11 +2179,11 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) != SVt_PVHV) DIE("Not a HASH reference"); - sv = hv_delete_ent(hv, keysv, - (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); + sv = hv_delete_ent(hv, keysv, discard, 0); if (!sv) sv = &sv_undef; - PUSHs(sv); + if (!discard) + PUSHs(sv); } RETURN; } @@ -2186,11 +2350,13 @@ PP(pp_splice) SP++; if (++MARK < SP) { - offset = SvIVx(*MARK); + offset = i = SvIVx(*MARK); if (offset < 0) offset += AvFILL(ary) + 1; else offset -= curcop->cop_arybase; + if (offset < 0) + DIE(no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) @@ -2203,12 +2369,6 @@ PP(pp_splice) offset = 0; length = AvMAX(ary) + 1; } - if (offset < 0) { - length += offset; - offset = 0; - if (length < 0) - length = 0; - } if (offset > AvFILL(ary) + 1) offset = AvFILL(ary) + 1; after = AvFILL(ary) + 1 - (offset + length); @@ -2448,7 +2608,7 @@ PP(pp_reverse) if (SP - MARK > 1) do_join(TARG, &sv_no, MARK, SP); else - sv_setsv(TARG, *SP); + sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv)); up = SvPV_force(TARG, len); if (len > 1) { down = SvPVX(TARG) + len - 1; @@ -2501,6 +2661,7 @@ PP(pp_unpack) dSP; dPOPPOPssrl; SV **oldsp = sp; + I32 gimme = GIMME_V; SV *sv; STRLEN llen; STRLEN rlen; @@ -2534,7 +2695,7 @@ PP(pp_unpack) double cdouble; static char* bitcount = 0; - if (GIMME != G_ARRAY) { /* arrange to do first one only */ + if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; if (strchr("aAbBhHP", *patend) || *pat == '%') { @@ -2547,7 +2708,9 @@ PP(pp_unpack) } while (pat < patend) { reparse: - datumtype = *pat++; + datumtype = *pat++ & 0xFF; + if (isSPACE(datumtype)) + continue; if (pat >= patend) len = 1; else if (*pat == '*') { @@ -2563,7 +2726,7 @@ PP(pp_unpack) len = (datumtype != '@'); switch(datumtype) { default: - break; + croak("Invalid type in unpack: '%c'", (int)datumtype); case '%': if (len == 1 && pat[-1] != '1') len = 16; @@ -2728,7 +2891,7 @@ PP(pp_unpack) if (aint >= 128) /* fake up signed chars */ aint -= 256; sv = NEWSV(36, 0); - sv_setiv(sv, (I32)aint); + sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } @@ -2749,19 +2912,19 @@ PP(pp_unpack) while (len-- > 0) { auint = *s++ & 255; sv = NEWSV(37, 0); - sv_setiv(sv, (I32)auint); + sv_setiv(sv, (IV)auint); PUSHs(sv_2mortal(sv)); } } break; case 's': - along = (strend - s) / sizeof(I16); + along = (strend - s) / SIZE16; if (len > along) len = along; if (checksum) { while (len-- > 0) { - Copy(s, &ashort, 1, I16); - s += sizeof(I16); + COPY16(s, &ashort); + s += SIZE16; culong += ashort; } } @@ -2769,10 +2932,10 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - Copy(s, &ashort, 1, I16); - s += sizeof(I16); + COPY16(s, &ashort); + s += SIZE16; sv = NEWSV(38, 0); - sv_setiv(sv, (I32)ashort); + sv_setiv(sv, (IV)ashort); PUSHs(sv_2mortal(sv)); } } @@ -2780,13 +2943,13 @@ PP(pp_unpack) case 'v': case 'n': case 'S': - along = (strend - s) / sizeof(U16); + along = (strend - s) / SIZE16; if (len > along) len = along; if (checksum) { while (len-- > 0) { - Copy(s, &aushort, 1, U16); - s += sizeof(U16); + COPY16(s, &aushort); + s += SIZE16; #ifdef HAS_NTOHS if (datumtype == 'n') aushort = ntohs(aushort); @@ -2802,8 +2965,8 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - Copy(s, &aushort, 1, U16); - s += sizeof(U16); + COPY16(s, &aushort); + s += SIZE16; sv = NEWSV(39, 0); #ifdef HAS_NTOHS if (datumtype == 'n') @@ -2813,7 +2976,7 @@ PP(pp_unpack) if (datumtype == 'v') aushort = vtohs(aushort); #endif - sv_setiv(sv, (I32)aushort); + sv_setiv(sv, (IV)aushort); PUSHs(sv_2mortal(sv)); } } @@ -2839,7 +3002,7 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); - sv_setiv(sv, (I32)aint); + sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } @@ -2865,22 +3028,19 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); sv = NEWSV(41, 0); - if (auint <= I32_MAX) - sv_setiv(sv, (I32)auint); - else - sv_setnv(sv, (double)auint); + sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } } break; case 'l': - along = (strend - s) / sizeof(I32); + along = (strend - s) / SIZE32; if (len > along) len = along; if (checksum) { while (len-- > 0) { - Copy(s, &along, 1, I32); - s += sizeof(I32); + COPY32(s, &along); + s += SIZE32; if (checksum > 32) cdouble += (double)along; else @@ -2891,10 +3051,10 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - Copy(s, &along, 1, I32); - s += sizeof(I32); + COPY32(s, &along); + s += SIZE32; sv = NEWSV(42, 0); - sv_setiv(sv, (I32)along); + sv_setiv(sv, (IV)along); PUSHs(sv_2mortal(sv)); } } @@ -2902,13 +3062,13 @@ PP(pp_unpack) case 'V': case 'N': case 'L': - along = (strend - s) / sizeof(U32); + along = (strend - s) / SIZE32; if (len > along) len = along; if (checksum) { while (len-- > 0) { - Copy(s, &aulong, 1, U32); - s += sizeof(U32); + COPY32(s, &aulong); + s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') aulong = ntohl(aulong); @@ -2927,9 +3087,8 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - Copy(s, &aulong, 1, U32); - s += sizeof(U32); - sv = NEWSV(43, 0); + COPY32(s, &aulong); + s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') aulong = ntohl(aulong); @@ -2938,7 +3097,8 @@ PP(pp_unpack) if (datumtype == 'V') aulong = vtohl(aulong); #endif - sv_setnv(sv, (double)aulong); + sv = NEWSV(43, 0); + sv_setuv(sv, (UV)aulong); PUSHs(sv_2mortal(sv)); } } @@ -2980,11 +3140,9 @@ PP(pp_unpack) auv = 0; } else if (++bytes >= sizeof(UV)) { /* promote to string */ - char decn[sizeof(UV) * 3 + 1]; char *t; - (void) sprintf(decn, "%0*ld", sizeof(decn) - 1, auv); - sv = newSVpv(decn, 0); + sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -3030,7 +3188,10 @@ PP(pp_unpack) s += sizeof(Quad_t); } sv = NEWSV(42, 0); - sv_setiv(sv, (IV)aquad); + if (aquad >= IV_MIN && aquad <= IV_MAX) + sv_setiv(sv, (IV)aquad); + else + sv_setnv(sv, (double)aquad); PUSHs(sv_2mortal(sv)); } break; @@ -3045,7 +3206,10 @@ PP(pp_unpack) s += sizeof(unsigned Quad_t); } sv = NEWSV(43, 0); - sv_setiv(sv, (IV)auquad); + if (aquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else + sv_setnv(sv, (double)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -3166,16 +3330,16 @@ PP(pp_unpack) } else { if (checksum < 32) { - along = (1 << checksum) - 1; - culong &= (U32)along; + aulong = (1 << checksum) - 1; + culong &= aulong; } - sv_setnv(sv, (double)culong); + sv_setuv(sv, (UV)culong); } XPUSHs(sv_2mortal(sv)); checksum = 0; } } - if (sp == oldsp && GIMME != G_ARRAY) + if (sp == oldsp && gimme == G_SCALAR) PUSHs(&sv_undef); RETURN; } @@ -3321,7 +3485,9 @@ PP(pp_pack) sv_setpvn(cat, "", 0); while (pat < patend) { #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no) - datumtype = *pat++; + datumtype = *pat++ & 0xFF; + if (isSPACE(datumtype)) + continue; if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; pat++; @@ -3335,7 +3501,7 @@ PP(pp_pack) len = 1; switch(datumtype) { default: - break; + croak("Invalid type in pack: '%c'", (int)datumtype); case '%': DIE("%% may only be used in unpack"); case '@': @@ -3537,7 +3703,7 @@ PP(pp_pack) #ifdef HAS_HTONS ashort = htons(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'v': @@ -3547,7 +3713,7 @@ PP(pp_pack) #ifdef HAS_HTOVS ashort = htovs(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'S': @@ -3555,13 +3721,13 @@ PP(pp_pack) while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'I': while (len-- > 0) { fromstr = NEXTFROM; - auint = U_I(SvNV(fromstr)); + auint = SvUV(fromstr); sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; @@ -3573,7 +3739,18 @@ PP(pp_pack) if (adouble < 0) croak("Cannot compress negative numbers"); - if (adouble <= UV_MAX) { + 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)]; char *in = buf + sizeof(buf); UV auv = U_V(adouble);; @@ -3634,35 +3811,35 @@ PP(pp_pack) case 'N': while (len-- > 0) { fromstr = NEXTFROM; - aulong = U_L(SvNV(fromstr)); + aulong = SvUV(fromstr); #ifdef HAS_HTONL aulong = htonl(aulong); #endif - sv_catpvn(cat, (char*)&aulong, sizeof(U32)); + CAT32(cat, &aulong); } break; case 'V': while (len-- > 0) { fromstr = NEXTFROM; - aulong = U_L(SvNV(fromstr)); + aulong = SvUV(fromstr); #ifdef HAS_HTOVL aulong = htovl(aulong); #endif - sv_catpvn(cat, (char*)&aulong, sizeof(U32)); + CAT32(cat, &aulong); } break; case 'L': while (len-- > 0) { fromstr = NEXTFROM; - aulong = U_L(SvNV(fromstr)); - sv_catpvn(cat, (char*)&aulong, sizeof(U32)); + aulong = SvUV(fromstr); + CAT32(cat, &aulong); } break; case 'l': while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); - sv_catpvn(cat, (char*)&along, sizeof(I32)); + CAT32(cat, &along); } break; #ifdef HAS_QUAD @@ -3687,7 +3864,21 @@ PP(pp_pack) case 'p': while (len-- > 0) { fromstr = NEXTFROM; - aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */ + if (fromstr == &sv_undef) + aptr = NULL; + else { + /* XXX better yet, could spirit away the string to + * a safe spot and hang on to it until the result + * of pack() (and all copies of the result) are + * gone. + */ + if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) + warn("Attempt to pack pointer to temporary value"); + if (SvPOK(fromstr) || SvNIOK(fromstr)) + aptr = SvPV(fromstr,na); + else + aptr = SvPV_force(fromstr,na); + } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; @@ -3741,7 +3932,7 @@ PP(pp_split) I32 realarray = 0; I32 base; AV *oldstack = curstack; - I32 gimme = GIMME; + I32 gimme = GIMME_V; I32 oldsave = savestack_ix; #ifdef DEBUGGING