X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=8fbe61de71ca98f83d7708728531d91e75920d12;hb=0a5d5e8be390bda2f9b7684490082d428228d28f;hp=f4cdc2dd63e549ba26435f107697f751ce9267eb;hpb=74c80e585086695d5428ab316ca82fd6931aeabd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index f4cdc2d..8fbe61d 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. @@ -15,16 +15,109 @@ #include "EXTERN.h" #include "perl.h" -static void doencodes _((SV *sv, char *s, I32 len)); +/* + * 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 + * 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 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 */ +#ifdef DONT_DECLARE_STD +#ifdef I_UNISTD +#include +#endif +#else +extern pid_t getpid (void); +#endif + PP(pp_stub) { - dSP; - if (GIMME != G_ARRAY) { + djSP; + if (GIMME_V == G_SCALAR) XPUSHs(&sv_undef); - } RETURN; } @@ -37,7 +130,7 @@ PP(pp_scalar) PP(pp_padav) { - dSP; dTARGET; + djSP; dTARGET; if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); EXTEND(SP, 1); @@ -62,26 +155,28 @@ PP(pp_padav) PP(pp_padhv) { - dSP; dTARGET; + djSP; 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) @@ -93,7 +188,7 @@ PP(pp_padany) PP(pp_rv2gv) { - dSP; dTOPss; + djSP; dTOPss; if (SvROK(sv)) { wasref: @@ -102,7 +197,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"); @@ -120,6 +215,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); @@ -128,35 +225,15 @@ PP(pp_rv2gv) sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } - if (op->op_private & OPpLVAL_INTRO) { - GP *ogp = GvGP(sv); - - SSCHECK(3); - SSPUSHPTR(SvREFCNT_inc(sv)); - SSPUSHPTR(ogp); - SSPUSHINT(SAVEt_GP); - - if (op->op_flags & OPf_SPECIAL) { - GvGP(sv)->gp_refcnt++; /* will soon be assigned */ - GvINTRO_on(sv); - } - else { - GP *gp; - Newz(602,gp, 1, GP); - GvGP(sv) = gp; - GvREFCNT(sv) = 1; - GvSV(sv) = NEWSV(72,0); - GvLINE(sv) = curcop->cop_line; - GvEGV(sv) = (GV*)sv; - } - } + if (op->op_private & OPpLVAL_INTRO) + save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } PP(pp_rv2sv) { - dSP; dTOPss; + djSP; dTOPss; if (SvROK(sv)) { wasref: @@ -182,6 +259,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); @@ -194,8 +273,8 @@ PP(pp_rv2sv) if (op->op_flags & OPf_MOD) { if (op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, sv); + else if (op->op_private & OPpDEREF) + vivify_ref(sv, op->op_private & OPpDEREF); } SETs(sv); RETURN; @@ -203,7 +282,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dSP; + djSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { @@ -217,10 +296,15 @@ PP(pp_av2arylen) PP(pp_pos) { - dSP; dTARGET; dPOPss; + djSP; dTARGET; dPOPss; if (op->op_flags & OPf_MOD) { - LvTYPE(TARG) = '<'; + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, '.', Nullch, 0); + } + + LvTYPE(TARG) = '.'; LvTARG(TARG) = sv; PUSHs(TARG); /* no SvSETMAGIC */ RETURN; @@ -241,15 +325,18 @@ PP(pp_pos) PP(pp_rv2cv) { - dSP; + djSP; GV *gv; HV *stash; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL)); - - if (!cv) + if (cv) { + if (CvCLONE(cv)) + cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); + } + else cv = (CV*)&sv_undef; SETs((SV*)cv); RETURN; @@ -257,7 +344,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dSP; + djSP; CV *cv; HV *stash; GV *gv; @@ -265,74 +352,70 @@ PP(pp_prototype) ret = &sv_undef; cv = sv_2cv(TOPs, &stash, &gv, FALSE); - if (cv && SvPOK(cv)) { - char *p = SvPVX(cv); - ret = sv_2mortal(newSVpv(p ? p : "", SvLEN(cv))); - } + if (cv && SvPOK(cv)) + ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv))); SETs(ret); RETURN; } PP(pp_anoncode) { - dSP; - CV* cv = (CV*)cSVOP->op_sv; - EXTEND(SP,1); - + djSP; + CV* cv = (CV*)curpad[op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - + EXTEND(SP,1); PUSHs((SV*)cv); RETURN; } PP(pp_srefgen) { - dSP; dTOPss; - SV* rv; - rv = sv_newmortal(); - sv_upgrade(rv, SVt_RV); - if (SvPADTMP(sv)) - sv = newSVsv(sv); - else { - SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); - } - SvRV(rv) = sv; - SvROK_on(rv); - SETs(rv); + djSP; + *SP = refto(*SP); RETURN; } PP(pp_refgen) { - dSP; dMARK; - SV* sv; - SV* rv; + djSP; dMARK; if (GIMME != G_ARRAY) { MARK[1] = *SP; SP = MARK + 1; } - while (MARK < SP) { - sv = *++MARK; - rv = sv_newmortal(); - sv_upgrade(rv, SVt_RV); - if (SvPADTMP(sv)) - sv = newSVsv(sv); - else { - SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); - } - SvRV(rv) = sv; - SvROK_on(rv); - *MARK = rv; - } + EXTEND_MORTAL(SP - MARK); + while (++MARK <= SP) + *MARK = refto(*MARK); RETURN; } +static SV* +refto(SV *sv) +{ + SV* rv; + + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { + if (LvTARGLEN(sv)) + vivify_defelem(sv); + if (!(sv = LvTARG(sv))) + sv = &sv_undef; + } + else if (SvPADTMP(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } + rv = sv_newmortal(); + sv_upgrade(rv, SVt_RV); + SvRV(rv) = sv; + SvROK_on(rv); + return rv; +} + PP(pp_ref) { - dSP; dTARGET; + djSP; dTARGET; SV *sv; char *pv; @@ -352,7 +435,7 @@ PP(pp_ref) PP(pp_bless) { - dSP; + djSP; HV *stash; if (MAXARG == 1) @@ -364,23 +447,93 @@ PP(pp_bless) RETURN; } +PP(pp_gelem) +{ + GV *gv; + SV *sv; + SV *ref; + char *elem; + djSP; + + sv = POPs; + elem = SvPV(sv, na); + gv = (GV*)POPs; + ref = Nullsv; + sv = Nullsv; + switch (elem ? *elem : '\0') + { + case 'A': + if (strEQ(elem, "ARRAY")) + ref = (SV*)GvAV(gv); + break; + case 'C': + if (strEQ(elem, "CODE")) + ref = (SV*)GvCVu(gv); + break; + case 'F': + if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ + ref = (SV*)GvIOp(gv); + break; + case 'G': + if (strEQ(elem, "GLOB")) + ref = (SV*)gv; + break; + case 'H': + if (strEQ(elem, "HASH")) + ref = (SV*)GvHV(gv); + break; + case 'I': + if (strEQ(elem, "IO")) + ref = (SV*)GvIOp(gv); + break; + case 'N': + if (strEQ(elem, "NAME")) + sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); + break; + case 'P': + if (strEQ(elem, "PACKAGE")) + sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + break; + case 'S': + if (strEQ(elem, "SCALAR")) + ref = GvSV(gv); + break; + } + if (ref) + sv = newRV(ref); + if (sv) + sv_2mortal(sv); + else + sv = &sv_undef; + XPUSHs(sv); + RETURN; +} + /* Pattern matching */ PP(pp_study) { - dSP; dPOPss; + djSP; dPOPss; + register UNOP *unop = cUNOP; register unsigned char *s; register I32 pos; 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(unop->op_first && unop->op_first->op_type == OP_PUSHRE) { + PMOP *pm = (PMOP *)unop->op_first; + SV *rv = sv_newmortal(); + sv = newSVrv(rv, "Regexp"); + sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); + RETURNX(PUSHs(rv)); + } + + if (sv == lastscream) { + if (SvSCREAM(sv)) + RETPUSHYES; + } else { if (lastscream) { SvSCREAM_off(lastscream); @@ -388,10 +541,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; @@ -421,32 +575,22 @@ PP(pp_study) else snext[pos] = -pos; sfirst[ch] = pos; - - /* If there were any case insensitive searches, we must assume they - * all are. This speeds up insensitive searches much more than - * it slows down sensitive ones. - */ - if (sawi) - sfirst[fold[ch]] = pos; } 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) { - dSP; dTARG; + djSP; dTARG; SV *sv; if (op->op_flags & OPf_STACKED) sv = POPs; else { - sv = GvSV(defgv); + sv = DEFSV; EXTEND(SP,1); } TARG = sv_newmortal(); @@ -458,7 +602,7 @@ PP(pp_trans) PP(pp_schop) { - dSP; dTARGET; + djSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -466,7 +610,7 @@ PP(pp_schop) PP(pp_chop) { - dSP; dMARK; dTARGET; + djSP; dMARK; dTARGET; while (SP > MARK) do_chop(TARG, POPs); PUSHTARG; @@ -475,14 +619,14 @@ PP(pp_chop) PP(pp_schomp) { - dSP; dTARGET; + djSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { - dSP; dMARK; dTARGET; + djSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) @@ -493,7 +637,7 @@ PP(pp_chomp) PP(pp_defined) { - dSP; + djSP; register SV* sv; sv = POPs; @@ -501,11 +645,11 @@ PP(pp_defined) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvRMAGICAL(sv)) + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)) RETPUSHYES; break; case SVt_PVHV: - if (HvARRAY(sv) || SvRMAGICAL(sv)) + if (HvARRAY(sv) || SvGMAGICAL(sv)) RETPUSHYES; break; case SVt_PVCV: @@ -523,11 +667,13 @@ PP(pp_defined) PP(pp_undef) { - dSP; + djSP; SV *sv; - if (!op->op_private) + if (!op->op_private) { + EXTEND(SP, 1); RETPUSHUNDEF; + } sv = POPs; if (!sv) @@ -550,16 +696,21 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - cv_undef((CV*)sv); - sub_generation++; + 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; - } + 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); @@ -574,17 +725,14 @@ PP(pp_undef) PP(pp_predec) { - dSP; - if (SvREADONLY(TOPs)) - croak(no_modify); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + djSP; + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + croak(no_modify); + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -594,18 +742,15 @@ PP(pp_predec) PP(pp_postinc) { - dSP; dTARGET; - if (SvREADONLY(TOPs)) - croak(no_modify); + djSP; dTARGET; + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + croak(no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MAX) { - sv_setnv(TOPs, (double)SvIVX(TOPs) + 1.0); - } - else { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MAX) + { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); @@ -618,18 +763,15 @@ PP(pp_postinc) PP(pp_postdec) { - dSP; dTARGET; - if(SvREADONLY(TOPs)) - croak(no_modify); + djSP; dTARGET; + if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + croak(no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs)) { - if (SvIVX(TOPs) == IV_MIN) { - sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); - } - else { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); - } + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + SvIVX(TOPs) != IV_MIN) + { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); @@ -642,7 +784,7 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( pow( left, right) ); @@ -652,7 +794,7 @@ PP(pp_pow) PP(pp_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); @@ -662,27 +804,26 @@ PP(pp_multiply) PP(pp_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { - dPOPnv; - if (value == 0.0) + dPOPPOPnnrl; + double value; + if (right == 0.0) DIE("Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { - double x; - I32 k; - x = POPn; - if ((double)I_32(x) == x && - (double)I_32(value) == value && - (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) { + IV k; + if ((double)I_V(left) == left && + (double)I_V(right) == right && + (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; } else { - value = x/value; + value = left / right; } } #else - value = POPn / value; + value = left / right; #endif PUSHn( value ); RETURN; @@ -691,28 +832,56 @@ PP(pp_divide) PP(pp_modulo) { - dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mod,opASSIGN); { - register IV value; - register UV uval; + UV left; + UV right; + bool left_neg; + bool right_neg; + UV ans; + + 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); + } - uval = POPn; - if (!uval) - DIE("Illegal modulus zero"); - value = TOPn; - if (value >= 0) - value = (UV)value % uval; + if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + IV i = SvIVX(POPs); + left = (left_neg = (i < 0)) ? -i : i; + } else { - value = (uval - ((UV)(-value - 1) % uval)) - 1; + double n = POPn; + left = U_V((left_neg = (n < 0)) ? -n : n); } - SETi(value); + + 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)+1) + sv_setiv(TARG, ~ans+1); + else + sv_setnv(TARG, -(double)ans); + } + else + sv_setuv(TARG, ans); + PUSHTARG; RETURN; } } PP(pp_repeat) { - dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register I32 count = POPi; if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) { @@ -749,16 +918,17 @@ PP(pp_repeat) } SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); - if (count >= 1) { - SvGROW(TARG, (count * len) + 1); - if (count > 1) + if (count != 1) { + if (count < 1) + SvCUR_set(TARG, 0); + else { + SvGROW(TARG, (count * len) + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); - SvCUR(TARG) *= count; + SvCUR(TARG) *= count; + } *SvEND(TARG) = '\0'; - (void)SvPOK_only(TARG); } - else - sv_setsv(TARG, &sv_no); + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -767,9 +937,9 @@ PP(pp_repeat) PP(pp_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPnnrl; + dPOPTOPnnrl_ul; SETn( left - right ); RETURN; } @@ -777,87 +947,109 @@ PP(pp_subtract) PP(pp_left_shift) { - dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - dPOPTOPiirl; - SETi( left << right ); - RETURN; + IBW shift = POPi; + if (op->op_private & HINT_INTEGER) { + IBW i = TOPi; + i = BWi(i) << shift; + SETi(BWi(i)); + } + else { + UBW u = TOPu; + u <<= shift; + SETu(BWu(u)); + } + RETURN; } } PP(pp_right_shift) { - dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - dPOPTOPiirl; - SETi( left >> right ); + IBW shift = POPi; + if (op->op_private & HINT_INTEGER) { + IBW i = TOPi; + i = BWi(i) >> shift; + SETi(BWi(i)); + } + else { + UBW u = TOPu; + u >>= shift; + SETu(BWu(u)); + } RETURN; } } PP(pp_lt) { - dSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPnv; - SETs((TOPn < value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn < value)); RETURN; } } PP(pp_gt) { - dSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPnv; - SETs((TOPn > value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn > value)); RETURN; } } PP(pp_le) { - dSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPnv; - SETs((TOPn <= value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn <= value)); RETURN; } } PP(pp_ge) { - dSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPnv; - SETs((TOPn >= value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn >= value)); RETURN; } } PP(pp_ne) { - dSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPnv; - SETs((TOPn != value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn != value)); RETURN; } } PP(pp_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; - if (left > right) - value = 1; + if (left == right) + value = 0; else if (left < right) value = -1; - else - value = 0; + else if (left > right) + value = 1; + else { + SETs(&sv_undef); + RETURN; + } SETi(value); RETURN; } @@ -865,75 +1057,103 @@ PP(pp_ncmp) PP(pp_slt) { - dSP; tryAMAGICbinSET(slt,0); + djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs(boolSV(cmp < 0)); RETURN; } } PP(pp_sgt) { - dSP; tryAMAGICbinSET(sgt,0); + djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs(boolSV(cmp > 0)); RETURN; } } PP(pp_sle) { - dSP; tryAMAGICbinSET(sle,0); + djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs(boolSV(cmp <= 0)); RETURN; } } PP(pp_sge) { - dSP; tryAMAGICbinSET(sge,0); + djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; - SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETs(boolSV(cmp >= 0)); + RETURN; + } +} + +PP(pp_seq) +{ + djSP; tryAMAGICbinSET(seq,0); + { + dPOPTOPssrl; + SETs(boolSV(sv_eq(left, right))); RETURN; } } PP(pp_sne) { - dSP; tryAMAGICbinSET(sne,0); + djSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; - SETs( !sv_eq(left, right) ? &sv_yes : &sv_no ); + SETs(boolSV(!sv_eq(left, right))); RETURN; } } PP(pp_scmp) { - dSP; dTARGET; tryAMAGICbin(scmp,0); + djSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; - SETi( sv_cmp(left, right) ); + int cmp = ((op->op_private & OPpLOCALE) + ? sv_cmp_locale(left, right) + : sv_cmp(left, right)); + SETi( cmp ); RETURN; } } -PP(pp_bit_and) { - dSP; dATARGET; tryAMAGICbin(band,opASSIGN); +PP(pp_bit_and) +{ + djSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value & U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = SvIV(left) & SvIV(right); + SETi(BWi(value)); + } + else { + UBW value = SvUV(left) & SvUV(right); + SETu(BWu(value)); + } } else { do_vop(op->op_type, TARG, left, right); @@ -945,16 +1165,18 @@ PP(pp_bit_and) { PP(pp_bit_xor) { - dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value ^ U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi(BWi(value)); + } + else { + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(BWu(value)); + } } else { do_vop(op->op_type, TARG, left, right); @@ -966,16 +1188,18 @@ PP(pp_bit_xor) PP(pp_bit_or) { - dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - unsigned long value = U_L(SvNV(left)); - value = value | U_L(SvNV(right)); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi(BWi(value)); + } + else { + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(BWu(value)); + } } else { do_vop(op->op_type, TARG, left, right); @@ -987,17 +1211,19 @@ PP(pp_bit_or) PP(pp_negate) { - dSP; dTARGET; tryAMAGICun(neg); + djSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) mg_get(sv); - if (SvNIOKp(sv)) + if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN) + SETi(-SvIVX(sv)); + else if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; char *s = SvPV(sv, len); - if (isALPHA(*s) || *s == '_') { + if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } @@ -1018,29 +1244,31 @@ PP(pp_negate) PP(pp_not) { #ifdef OVERLOAD - dSP; tryAMAGICunSET(not); + djSP; tryAMAGICunSET(not); #endif /* OVERLOAD */ - *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes; + *stack_sp = boolSV(!SvTRUE(*stack_sp)); return NORMAL; } PP(pp_complement) { - dSP; dTARGET; tryAMAGICun(compl); + djSP; dTARGET; tryAMAGICun(compl); { dTOPss; - register I32 anum; - if (SvNIOKp(sv)) { - UV value = ~SvIV(sv); - if ((IV)value == value) - SETi(value); - else - SETn((double)value); + if (op->op_private & HINT_INTEGER) { + IBW value = ~SvIV(sv); + SETi(BWi(value)); + } + else { + UBW value = ~SvUV(sv); + SETu(BWu(value)); + } } else { register char *tmps; register long *tmpl; + register I32 anum; STRLEN len; SvSetSV(TARG, sv); @@ -1067,7 +1295,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -1077,7 +1305,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) @@ -1090,9 +1318,11 @@ PP(pp_i_divide) PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mod,opASSIGN); { dPOPTOPiirl; + if (!right) + DIE("Illegal modulus zero"); SETi( left % right ); RETURN; } @@ -1100,7 +1330,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl; SETi( left + right ); @@ -1110,7 +1340,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl; SETi( left - right ); @@ -1120,67 +1350,67 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; - SETs((left < right) ? &sv_yes : &sv_no); + SETs(boolSV(left < right)); RETURN; } } PP(pp_i_gt) { - dSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; - SETs((left > right) ? &sv_yes : &sv_no); + SETs(boolSV(left > right)); RETURN; } } PP(pp_i_le) { - dSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; - SETs((left <= right) ? &sv_yes : &sv_no); + SETs(boolSV(left <= right)); RETURN; } } PP(pp_i_ge) { - dSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; - SETs((left >= right) ? &sv_yes : &sv_no); + SETs(boolSV(left >= right)); RETURN; } } PP(pp_i_eq) { - dSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; - SETs((left == right) ? &sv_yes : &sv_no); + SETs(boolSV(left == right)); RETURN; } } PP(pp_i_ne) { - dSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; - SETs((left != right) ? &sv_yes : &sv_no); + SETs(boolSV(left != right)); RETURN; } } PP(pp_i_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -1198,7 +1428,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dSP; dTARGET; tryAMAGICun(neg); + djSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -1207,7 +1437,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dSP; dTARGET; tryAMAGICbin(atan2,0); + djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(atan2(left, right)); @@ -1217,7 +1447,7 @@ PP(pp_atan2) PP(pp_sin) { - dSP; dTARGET; tryAMAGICun(sin); + djSP; dTARGET; tryAMAGICun(sin); { double value; value = POPn; @@ -1229,7 +1459,7 @@ PP(pp_sin) PP(pp_cos) { - dSP; dTARGET; tryAMAGICun(cos); + djSP; dTARGET; tryAMAGICun(cos); { double value; value = POPn; @@ -1241,7 +1471,7 @@ PP(pp_cos) PP(pp_rand) { - dSP; dTARGET; + djSP; dTARGET; double value; if (MAXARG < 1) value = 1.0; @@ -1249,6 +1479,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 @@ -1268,44 +1502,74 @@ PP(pp_rand) PP(pp_srand) { - dSP; - I32 anum; + djSP; + UV anum; + if (MAXARG < 1) + anum = seed(); + else + anum = POPu; + (void)srand((unsigned)anum); + srand_called = TRUE; + EXTEND(SP, 1); + RETPUSHYES; +} + +static U32 +seed(void) +{ + /* + * 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) { + dTHR; + 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 -# if defined(I_SYS_TIME) && !defined(PLAN9) - struct timeval when; - gettimeofday(&when,(struct timezone *) 0); - anum = when.tv_sec ^ when.tv_usec; +# ifdef HAS_GETTIMEOFDAY + 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) { - dSP; dTARGET; tryAMAGICun(exp); + djSP; dTARGET; tryAMAGICun(exp); { double value; value = POPn; @@ -1317,12 +1581,14 @@ PP(pp_exp) PP(pp_log) { - dSP; dTARGET; tryAMAGICun(log); + djSP; dTARGET; tryAMAGICun(log); { double value; value = POPn; - if (value <= 0.0) + if (value <= 0.0) { + SET_NUMERIC_STANDARD(); DIE("Can't take log of %g", value); + } value = log(value); XPUSHn(value); RETURN; @@ -1331,12 +1597,14 @@ PP(pp_log) PP(pp_sqrt) { - dSP; dTARGET; tryAMAGICun(sqrt); + djSP; dTARGET; tryAMAGICun(sqrt); { double value; value = POPn; - if (value < 0.0) + if (value < 0.0) { + SET_NUMERIC_STANDARD(); DIE("Can't take sqrt of %g", value); + } value = sqrt(value); XPUSHn(value); RETURN; @@ -1345,54 +1613,69 @@ PP(pp_sqrt) PP(pp_int) { - dSP; dTARGET; - double value; - value = POPn; - if (value >= 0.0) - (void)modf(value, &value); - else { - (void)modf(-value, &value); - value = -value; + djSP; dTARGET; + { + double value = TOPn; + IV iv; + + if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { + iv = SvIVX(TOPs); + SETi(iv); + } + else { + if (value >= 0.0) + (void)modf(value, &value); + else { + (void)modf(-value, &value); + value = -value; + } + iv = I_V(value); + if (iv == value) + SETi(iv); + else + SETn(value); + } } - XPUSHn(value); RETURN; } PP(pp_abs) { - dSP; dTARGET; tryAMAGICun(abs); + djSP; dTARGET; tryAMAGICun(abs); { - double value; - value = POPn; - - if (value < 0.0) - value = -value; - - XPUSHn(value); - RETURN; + double value = TOPn; + IV iv; + + if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && + (iv = SvIVX(TOPs)) != IV_MIN) { + if (iv < 0) + iv = -iv; + SETi(iv); + } + else { + if (value < 0.0) + value = -value; + SETn(value); + } } + RETURN; } PP(pp_hex) { - dSP; dTARGET; + djSP; dTARGET; char *tmps; - unsigned long value; I32 argtype; tmps = POPp; - value = scan_hex(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { - dSP; dTARGET; - unsigned long value; + djSP; dTARGET; + UV value; I32 argtype; char *tmps; @@ -1405,10 +1688,7 @@ PP(pp_oct) value = scan_hex(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - if ((IV)value >= 0) - XPUSHi(value); - else - XPUSHn(U_V(value)); + XPUSHu(value); RETURN; } @@ -1416,47 +1696,69 @@ PP(pp_oct) PP(pp_length) { - dSP; dTARGET; + djSP; dTARGET; SETi( sv_len(TOPs) ); RETURN; } PP(pp_substr) { - dSP; dTARGET; + djSP; dTARGET; SV *sv; I32 len; 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)) { @@ -1470,12 +1772,13 @@ PP(pp_substr) else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } + if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'x', Nullch, 0); } - LvTYPE(TARG) = 's'; + LvTYPE(TARG) = 'x'; LvTARG(TARG) = sv; LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; @@ -1487,7 +1790,7 @@ PP(pp_substr) PP(pp_vec) { - dSP; dTARGET; + djSP; dTARGET; register I32 size = POPi; register I32 offset = POPi; register SV *src = POPs; @@ -1554,14 +1857,14 @@ PP(pp_vec) } } - sv_setiv(TARG, (I32)retnum); + sv_setiv(TARG, (IV)retnum); PUSHs(TARG); RETURN; } PP(pp_index) { - dSP; dTARGET; + djSP; dTARGET; SV *big; SV *little; I32 offset; @@ -1593,7 +1896,7 @@ PP(pp_index) PP(pp_rindex) { - dSP; dTARGET; + djSP; dTARGET; SV *big; SV *little; STRLEN blen; @@ -1630,8 +1933,15 @@ PP(pp_rindex) PP(pp_sprintf) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; +#ifdef USE_LOCALE_NUMERIC + if (op->op_private & OPpLOCALE) + SET_NUMERIC_LOCAL(); + else + SET_NUMERIC_STANDARD(); +#endif do_sprintf(TARG, SP-MARK, MARK+1); + TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; PUSHTARG; RETURN; @@ -1639,7 +1949,7 @@ PP(pp_sprintf) PP(pp_ord) { - dSP; dTARGET; + djSP; dTARGET; I32 value; char *tmps; @@ -1658,7 +1968,7 @@ PP(pp_ord) PP(pp_chr) { - dSP; dTARGET; + djSP; dTARGET; char *tmps; (void)SvUPGRADE(TARG,SVt_PV); @@ -1674,7 +1984,7 @@ PP(pp_chr) PP(pp_crypt) { - dSP; dTARGET; dPOPTOPssrl; + djSP; dTARGET; dPOPTOPssrl; #ifdef HAS_CRYPT char *tmps = SvPV(left, na); #ifdef FCRYPT @@ -1692,7 +2002,7 @@ PP(pp_crypt) PP(pp_ucfirst) { - dSP; + djSP; SV *sv = TOPs; register char *s; @@ -1703,15 +2013,22 @@ PP(pp_ucfirst) SETs(sv); } s = SvPV_force(sv, na); - if (isLOWER(*s)) - *s = toUPPER(*s); + if (*s) { + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toUPPER_LC(*s); + } + else + *s = toUPPER(*s); + } RETURN; } PP(pp_lcfirst) { - dSP; + djSP; SV *sv = TOPs; register char *s; @@ -1722,8 +2039,15 @@ PP(pp_lcfirst) SETs(sv); } s = SvPV_force(sv, na); - if (isUPPER(*s)) - *s = toLOWER(*s); + if (*s) { + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toLOWER_LC(*s); + } + else + *s = toLOWER(*s); + } SETs(sv); RETURN; @@ -1731,10 +2055,9 @@ PP(pp_lcfirst) PP(pp_uc) { - dSP; + djSP; SV *sv = TOPs; register char *s; - register char *send; STRLEN len; if (!SvPADTMP(sv)) { @@ -1743,22 +2066,30 @@ PP(pp_uc) sv = TARG; SETs(sv); } + s = SvPV_force(sv, len); - send = s + len; - while (s < send) { - if (isLOWER(*s)) - *s = toUPPER(*s); - s++; + if (len) { + register char *send = s + len; + + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toUPPER_LC(*s); + } + else { + for (; s < send; s++) + *s = toUPPER(*s); + } } RETURN; } PP(pp_lc) { - dSP; + djSP; SV *sv = TOPs; register char *s; - register char *send; STRLEN len; if (!SvPADTMP(sv)) { @@ -1767,19 +2098,28 @@ PP(pp_lc) sv = TARG; SETs(sv); } + s = SvPV_force(sv, len); - send = s + len; - while (s < send) { - if (isUPPER(*s)) - *s = toLOWER(*s); - s++; + if (len) { + register char *send = s + len; + + if (op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toLOWER_LC(*s); + } + else { + for (; s < send; s++) + *s = toLOWER(*s); + } } RETURN; } PP(pp_quotemeta) { - dSP; dTARGET; + djSP; dTARGET; SV *sv = TOPs; STRLEN len; register char *s = SvPV(sv,len); @@ -1808,7 +2148,7 @@ PP(pp_quotemeta) PP(pp_aslice) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; register I32 lval = op->op_flags & OPf_MOD; @@ -1853,25 +2193,30 @@ PP(pp_aslice) PP(pp_each) { - dSP; dTARGET; + djSP; dTARGET; HV *hash = (HV*)POPs; HE *entry; + I32 gimme = GIMME_V; + I32 realhv = (SvTYPE(hash) == SVt_PVHV); PUTBACK; - entry = hv_iternext(hash); /* might clobber stack_sp */ + /* might clobber stack_sp */ + entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); 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 */ + /* might clobber stack_sp */ + sv_setsv(TARG, realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); SPAGAIN; PUSHs(TARG); } } - else if (GIMME == G_SCALAR) + else if (gimme == G_SCALAR) RETPUSHUNDEF; RETURN; @@ -1889,48 +2234,86 @@ PP(pp_keys) PP(pp_delete) { - dSP; + djSP; + I32 gimme = GIMME_V; + I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; - SV *tmpsv = POPs; - HV *hv = (HV*)POPs; - STRLEN len; - if (SvTYPE(hv) != SVt_PVHV) { - DIE("Not a HASH reference"); + HV *hv; + + if (op->op_private & OPpSLICE) { + dMARK; dORIGMARK; + U32 hvtype; + hv = (HV*)POPs; + hvtype = SvTYPE(hv); + while (++MARK <= SP) { + if (hvtype == SVt_PVHV) + sv = hv_delete_ent(hv, *MARK, discard, 0); + else if (hvtype == SVt_PVAV) + sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); + else + DIE("Not a HASH reference"); + *MARK = sv ? sv : &sv_undef; + } + if (discard) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { + MARK = ORIGMARK; + *++MARK = *SP; + SP = MARK; + } + } + else { + SV *keysv = POPs; + hv = (HV*)POPs; + if (SvTYPE(hv) == SVt_PVHV) + sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) + sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); + else + DIE("Not a HASH reference"); + if (!sv) + sv = &sv_undef; + if (!discard) + PUSHs(sv); } - sv = hv_delete_ent(hv, tmpsv, - (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0); - if (!sv) - RETPUSHUNDEF; - PUSHs(sv); RETURN; } PP(pp_exists) { - dSP; + djSP; SV *tmpsv = POPs; HV *hv = (HV*)POPs; - STRLEN len; - if (SvTYPE(hv) != SVt_PVHV) { + 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)) + RETPUSHYES; + } else { DIE("Not a HASH reference"); } - if (hv_exists_ent(hv, tmpsv, 0)) - RETPUSHYES; RETPUSHNO; } PP(pp_hslice) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register HE *he; register HV *hv = (HV*)POPs; register I32 lval = op->op_flags & OPf_MOD; + I32 realhv = (SvTYPE(hv) == SVt_PVHV); - if (SvTYPE(hv) == SVt_PVHV) { + if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; - - he = hv_fetch_ent(hv, keysv, lval, 0); + SV **svp; + if (realhv) { + he = hv_fetch_ent(hv, keysv, lval, 0); + svp = he ? &HeVAL(he) : 0; + } else { + svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); + } if (lval) { if (!he || HeVAL(he) == &sv_undef) DIE(no_helem, SvPV(keysv, na)); @@ -1952,7 +2335,7 @@ PP(pp_hslice) PP(pp_list) { - dSP; dMARK; + djSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ @@ -1965,7 +2348,7 @@ PP(pp_list) PP(pp_lslice) { - dSP; + djSP; SV **lastrelem = stack_sp; SV **lastlelem = stack_base + POPMARK; SV **firstlelem = stack_base + POPMARK + 1; @@ -2011,7 +2394,7 @@ PP(pp_lslice) if (ix >= max || !(*lelem = firstrelem[ix])) *lelem = &sv_undef; } - if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem))) + if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem))) is_something_there = TRUE; } if (is_something_there) @@ -2023,17 +2406,17 @@ PP(pp_lslice) PP(pp_anonlist) { - dSP; dMARK; + djSP; dMARK; dORIGMARK; I32 items = SP - MARK; - SP = MARK; - XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1))); + SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); + SP = ORIGMARK; /* av_make() might realloc stack_sp */ + XPUSHs(av); RETURN; } PP(pp_anonhash) { - dSP; dMARK; dORIGMARK; - STRLEN len; + djSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { @@ -2041,7 +2424,7 @@ PP(pp_anonhash) SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else + else if (dowarn) warn("Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } @@ -2052,7 +2435,7 @@ PP(pp_anonhash) PP(pp_splice) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -2067,11 +2450,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) @@ -2084,12 +2469,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); @@ -2104,6 +2483,12 @@ PP(pp_splice) newlen = SP - MARK; diff = newlen - length; + if (newlen && !AvREAL(ary)) { + if (AvREIFY(ary)) + av_reify(ary); + else + assert(AvREAL(ary)); /* would leak, so croak */ + } if (diff < 0) { /* shrinking the area */ if (newlen) { @@ -2116,15 +2501,20 @@ PP(pp_splice) MEXTEND(MARK, length); Copy(AvARRAY(ary)+offset, MARK, length, SV*); if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ + EXTEND_MORTAL(length); + for (i = length, dst = MARK; i; i--) { + if (!SvIMMORTAL(*dst)) + sv_2mortal(*dst); /* free them eventualy */ + dst++; + } } MARK += length - 1; } else { *MARK = AvARRAY(ary)[offset+length-1]; if (AvREAL(ary)) { - sv_2mortal(*MARK); + if (!SvIMMORTAL(*MARK)) + sv_2mortal(*MARK); for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } @@ -2210,8 +2600,12 @@ PP(pp_splice) if (length) { Copy(tmparyval, MARK, length, SV*); if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ + EXTEND_MORTAL(length); + for (i = length, dst = MARK; i; i--) { + if (!SvIMMORTAL(*dst)) + sv_2mortal(*dst); /* free them eventualy */ + dst++; + } } Safefree(tmparyval); } @@ -2220,7 +2614,8 @@ PP(pp_splice) else if (length--) { *MARK = tmparyval[length]; if (AvREAL(ary)) { - sv_2mortal(*MARK); + if (!SvIMMORTAL(*MARK)) + sv_2mortal(*MARK); while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } @@ -2235,7 +2630,7 @@ PP(pp_splice) PP(pp_push) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &sv_undef; @@ -2252,10 +2647,10 @@ PP(pp_push) PP(pp_pop) { - dSP; + djSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); - if (sv != &sv_undef && AvREAL(av)) + if (!SvIMMORTAL(sv) && AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2263,13 +2658,13 @@ PP(pp_pop) PP(pp_shift) { - dSP; + djSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); if (!sv) RETPUSHUNDEF; - if (sv != &sv_undef && AvREAL(av)) + if (!SvIMMORTAL(sv) && AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2277,7 +2672,7 @@ PP(pp_shift) PP(pp_unshift) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; @@ -2296,7 +2691,7 @@ PP(pp_unshift) PP(pp_reverse) { - dSP; dMARK; + djSP; dMARK; register SV *tmp; SV **oldsp = SP; @@ -2319,7 +2714,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 : DEFSV); up = SvPV_force(TARG, len); if (len > 1) { down = SvPVX(TARG) + len - 1; @@ -2336,12 +2731,41 @@ PP(pp_reverse) RETURN; } +static SV * +mul128(SV *sv, U8 m) +{ + STRLEN len; + char *s = SvPV(sv, len); + char *t; + U32 i = 0; + + if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ + SV *New = newSVpv("0000000000", 10); + + sv_catsv(New, sv); + SvREFCNT_dec(sv); /* free old sv */ + sv = New; + s = SvPV(sv, len); + } + t = s + len - 1; + while (!*t) /* trailing '\0'? */ + t--; + while (t > s) { + i = ((*t - '0') << 7) + m; + *(t--) = '0' + (i % 10); + m = i / 10; + } + return (sv); +} + /* Explosives and implosives. */ PP(pp_unpack) { - dSP; + djSP; dPOPPOPssrl; + SV **oldsp = sp; + I32 gimme = GIMME_V; SV *sv; STRLEN llen; STRLEN rlen; @@ -2374,8 +2798,9 @@ PP(pp_unpack) register U32 culong; double cdouble; static char* bitcount = 0; + int commas = 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 == '%') { @@ -2388,7 +2813,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 == '*') { @@ -2404,6 +2831,10 @@ PP(pp_unpack) len = (datumtype != '@'); switch(datumtype) { default: + croak("Invalid type in unpack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && dowarn) + warn("Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -2563,12 +2994,13 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { aint = *s++; 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)); } } @@ -2585,32 +3017,34 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); 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; } } else { 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)); } } @@ -2618,13 +3052,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); @@ -2638,9 +3072,10 @@ PP(pp_unpack) } else { 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') @@ -2650,7 +3085,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)); } } @@ -2671,11 +3106,12 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { 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)); } } @@ -2696,26 +3132,24 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { 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 @@ -2724,11 +3158,12 @@ PP(pp_unpack) } else { 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)); } } @@ -2736,13 +3171,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); @@ -2759,10 +3194,10 @@ PP(pp_unpack) } else { 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); @@ -2771,7 +3206,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)); } } @@ -2781,6 +3217,7 @@ PP(pp_unpack) if (len > along) len = along; EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (sizeof(char*) > strend - s) break; @@ -2795,49 +3232,45 @@ PP(pp_unpack) } break; case 'w': - along = (strend - s) / sizeof(char); - if (len > along) - len = along; EXTEND(SP, len); - { - I8 bytes = 0; - - auint = 0; - while (len > 0) { - if (s >= strend) { - if (auint) { - DIE("Unterminated compressed integer"); - } else { - break; - } - } - auint = (auint << 7) | (*s & 0x7f); - if (!(*s & 0x80)) { - sv = NEWSV(40, 0); - sv_setiv(sv, (I32) auint); - PUSHs(sv_2mortal(sv)); - len--; - auint = 0; - bytes = 0; - } else if (++bytes >= sizeof(auint)) { /* promote to double */ - adouble = auint; - - while (*s & 0x80) { - adouble = (adouble * 128) + (*(++s) & 0x7f); - if (s >= strend) { - DIE("Unterminated compressed integer"); - } - } - sv = NEWSV(40, 0); - sv_setnv(sv, adouble); - PUSHs(sv_2mortal(sv)); - len--; - auint = 0; - bytes = 0; - } - s++; - } - } + EXTEND_MORTAL(len); + { + UV auv = 0; + U32 bytes = 0; + + while ((len > 0) && (s < strend)) { + auv = (auv << 7) | (*s & 0x7f); + if (!(*s++ & 0x80)) { + bytes = 0; + sv = NEWSV(40, 0); + sv_setuv(sv, auv); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + else if (++bytes >= sizeof(UV)) { /* promote to string */ + char *t; + + sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); + while (s < strend) { + sv = mul128(sv, *s & 0x7f); + if (!(*s++ & 0x80)) { + bytes = 0; + break; + } + } + t = SvPV(sv, na); + while (*t == '0') + t++; + sv_chop(sv, t); + PUSHs(sv_2mortal(sv)); + len--; + auv = 0; + } + } + if ((s >= strend) && bytes) + croak("Unterminated compressed integer"); + } break; case 'P': EXTEND(SP, 1); @@ -2855,6 +3288,7 @@ PP(pp_unpack) #ifdef HAS_QUAD case 'q': EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Quad_t) > strend) aquad = 0; @@ -2863,12 +3297,16 @@ 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; case 'Q': EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(unsigned Quad_t) > strend) auquad = 0; @@ -2877,7 +3315,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; @@ -2897,6 +3338,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); @@ -2920,6 +3362,7 @@ PP(pp_unpack) } else { EXTEND(SP, len); + EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); @@ -2957,10 +3400,10 @@ PP(pp_unpack) d = (*s++ - ' ') & 077; else d = 0; - hunk[0] = a << 2 | b >> 4; - hunk[1] = b << 4 | c >> 2; - hunk[2] = c << 6 | d; - sv_catpvn(sv, hunk, len > 3 ? 3 : len); + hunk[0] = (a << 2) | (b >> 4); + hunk[1] = (b << 4) | (c >> 2); + hunk[2] = (c << 6) | d; + sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (*s == '\n') @@ -2996,23 +3439,22 @@ 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_SCALAR) + PUSHs(&sv_undef); RETURN; } static void -doencodes(sv, s, len) -register SV *sv; -register char *s; -register I32 len; +doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; @@ -3021,8 +3463,8 @@ register I32 len; hunk[4] = '\0'; while (len > 0) { hunk[0] = ' ' + (077 & (*s >> 2)); - hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017)); - hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03)); + hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017))); + hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03))); hunk[3] = ' ' + (077 & (s[2] & 077)); sv_catpvn(sv, hunk, 4); s += 3; @@ -3035,9 +3477,86 @@ register I32 len; sv_catpvn(sv, "\n", 1); } +static SV * +is_an_int(char *s, STRLEN l) +{ + SV *result = newSVpv("", l); + char *result_c = SvPV(result, na); /* convenience */ + char *out = result_c; + bool skip = 1; + bool ignore = 0; + + while (*s) { + switch (*s) { + case ' ': + break; + case '+': + if (!skip) { + SvREFCNT_dec(result); + return (NULL); + } + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + skip = 0; + if (!ignore) { + *(out++) = *s; + } + break; + case '.': + ignore = 1; + break; + default: + SvREFCNT_dec(result); + return (NULL); + } + s++; + } + *(out++) = '\0'; + SvCUR_set(result, out - result_c); + return (result); +} + +static int +div128(SV *pnum, char *done) + /* must be '\0' terminated */ + +{ + STRLEN len; + char *s = SvPV(pnum, len); + int m = 0; + int r = 0; + char *t = s; + + *done = 1; + while (*t) { + int i; + + i = m * 10 + (*t - '0'); + m = i & 0x7F; + r = (i >> 7); /* r < 10 */ + if (r) { + *done = 0; + } + *(t++) = '0' + r; + } + *(t++) = '\0'; + SvCUR_set(pnum, (STRLEN) (t - s)); + return (m); +} + + PP(pp_pack) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; @@ -3064,13 +3583,16 @@ PP(pp_pack) char *aptr; float afloat; double adouble; + int commas = 0; items = SP - MARK; MARK++; 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++; @@ -3084,6 +3606,10 @@ PP(pp_pack) len = 1; switch(datumtype) { default: + croak("Invalid type in pack: '%c'", (int)datumtype); + case ',': /* grandfather in commas but with a warning */ + if (commas++ == 0 && dowarn) + warn("Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); @@ -3286,7 +3812,7 @@ PP(pp_pack) #ifdef HAS_HTONS ashort = htons(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'v': @@ -3296,7 +3822,7 @@ PP(pp_pack) #ifdef HAS_HTOVS ashort = htovs(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'S': @@ -3304,51 +3830,85 @@ 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; case 'w': while (len-- > 0) { - fromstr = NEXTFROM; - adouble = floor((double)SvNV(fromstr)); - - if (adouble < 268435456) { /* we can use integers */ - unsigned char buf[4]; /* buffer for compressed int */ - unsigned char *in = buf + 3; - auint = U_I(adouble); - do { - *(in--) = (unsigned char) ((auint & 0x7f) | 0x80); - auint >>= 7; - } while (auint); - buf[3] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, (char*) in+1, buf+3-in); - } else { - unsigned char buf[sizeof(double)*2]; /* buffer for compressed int */ - I8 msize = sizeof(double)*2; /* 8/7 would be enough */ - unsigned char *in = buf + msize -1; - if (adouble<0) { - croak("Cannot compress negative numbers"); + fromstr = NEXTFROM; + adouble = floor(SvNV(fromstr)); + + if (adouble < 0) + croak("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)]; + char *in = buf + sizeof(buf); + UV auv = U_V(adouble);; + + do { + *--in = (auv & 0x7f) | 0x80; + auv >>= 7; + } while (auv); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ + char *from, *result, *in; + SV *norm; + STRLEN len; + bool done; + + /* Copy string and check for compliance */ + from = SvPV(fromstr, len); + if ((norm = is_an_int(from, len)) == NULL) + croak("can compress only unsigned integer"); + + New('w', result, len, char); + in = result + len; + done = FALSE; + while (!done) + *--in = div128(norm, &done) | 0x80; + result[len - 1] &= 0x7F; /* clear continue bit */ + sv_catpvn(cat, in, (result + len) - in); + Safefree(result); + SvREFCNT_dec(norm); /* free norm */ } - do { - double next = adouble/128; - *in = (unsigned char) (adouble - floor(next)*128); - *in |= 0x80; /* set continue bit */ - if (--in < buf) { /* this cannot happen ;-) */ - croak ("Cannot compress integer"); - } - adouble = next; - } while (floor(adouble)>0); /* floor() not necessary? */ - buf[msize-1] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, (char*) in+1, buf+msize-in-1); - } - } + else if (SvNOKp(fromstr)) { + char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ + char *in = buf + sizeof(buf); + + do { + double next = floor(adouble / 128); + *--in = (unsigned char)(adouble - (next * 128)) | 0x80; + if (--in < buf) /* this cannot happen ;-) */ + croak ("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 + croak("Cannot compress non integer"); + } break; case 'i': while (len-- > 0) { @@ -3360,35 +3920,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 @@ -3413,7 +3973,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; @@ -3448,14 +4022,15 @@ PP(pp_pack) PP(pp_split) { - dSP; dTARG; + djSP; dTARG; AV *ary; register I32 limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; register char *s = SvPV(sv, len); char *strend = s + len; - register PMOP *pm = (PMOP*)POPs; + register PMOP *pm; + register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; @@ -3466,16 +4041,29 @@ PP(pp_split) I32 realarray = 0; I32 base; AV *oldstack = curstack; - register REGEXP *rx = pm->op_pmregexp; - I32 gimme = GIMME; + I32 gimme = GIMME_V; I32 oldsave = savestack_ix; +#ifdef DEBUGGING + Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); +#else + pm = (PMOP*)POPs; +#endif if (!pm || !s) DIE("panic: do_split"); + rx = pm->op_pmregexp; + + TAINT_IF((pm->op_pmflags & PMf_LOCALE) && + (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); + if (pm->op_pmreplroot) ary = GvAVn((GV*)pm->op_pmreplroot); else if (gimme != G_ARRAY) +#ifdef USE_THREADS + ary = (AV*)curpad[0]; +#else ary = GvAVn(defgv); +#endif /* USE_THREADS */ else ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { @@ -3493,8 +4081,14 @@ PP(pp_split) base = SP - stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { - while (isSPACE(*s)) - s++; + if (pm->op_pmflags & PMf_LOCALE) { + while (isSPACE_LC(*s)) + s++; + } + else { + while (isSPACE(*s)) + s++; + } } if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); @@ -3505,17 +4099,25 @@ PP(pp_split) limit = maxiters + 2; if (pm->op_pmflags & PMf_WHITE) { while (--limit) { - /*SUPPRESS 530*/ - for (m = s; m < strend && !isSPACE(*m); m++) ; + m = s; + while (m < strend && + !((pm->op_pmflags & PMf_LOCALE) + ? isSPACE_LC(*m) : isSPACE(*m))) + ++m; if (m >= strend) break; + dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (!realarray) sv_2mortal(dstr); XPUSHs(dstr); - /*SUPPRESS 530*/ - for (s = m + 1; s < strend && isSPACE(*s); s++) ; + + s = m + 1; + while (s < strend && + ((pm->op_pmflags & PMf_LOCALE) + ? isSPACE_LC(*s) : isSPACE(*s))) + ++s; } } else if (strEQ("^", rx->precomp)) { @@ -3533,23 +4135,15 @@ PP(pp_split) s = m; } } - else if (pm->op_pmshort) { - i = SvCUR(pm->op_pmshort); - if (i == 1) { - I32 fold = (pm->op_pmflags & PMf_FOLD); - i = *SvPVX(pm->op_pmshort); - if (fold && isUPPER(i)) - i = toLOWER(i); + else if (rx->check_substr && !rx->nparens + && (rx->reganch & ROPT_CHECK_ALL) + && !(rx->reganch & ROPT_ANCH)) { + i = SvCUR(rx->check_substr); + if (i == 1 && !SvTAIL(rx->check_substr)) { + i = *SvPVX(rx->check_substr); while (--limit) { - if (fold) { - for ( m = s; - m < strend && *m != i && - (!isUPPER(*m) || toLOWER(*m) != i); - m++) /*SUPPRESS 530*/ - ; - } - else /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + /*SUPPRESS 530*/ + for (m = s; m < strend && *m != i; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); @@ -3564,7 +4158,7 @@ PP(pp_split) #ifndef lint while (s < strend && --limit && (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - pm->op_pmshort)) ) + rx->check_substr)) ) #endif { dstr = NEWSV(31, m-s); @@ -3579,7 +4173,9 @@ PP(pp_split) else { maxiters += (strend - s) * rx->nparens; while (s < strend && --limit && - pregexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) { + regexec_flags(rx, s, strend, orig, 1, Nullsv, NULL, 0)) + { + TAINT_IF(RX_MATCH_TAINTED(rx)); if (rx->subbase && rx->subbase != orig) { m = s; @@ -3632,6 +4228,11 @@ PP(pp_split) } if (realarray) { SWITCHSTACK(ary, oldstack); + if (SvSMAGICAL(ary)) { + PUTBACK; + mg_set((SV*)ary); + SPAGAIN; + } if (gimme == G_ARRAY) { EXTEND(SP, iters); Copy(AvARRAY(ary), SP + 1, iters, SV*); @@ -3651,3 +4252,71 @@ PP(pp_split) RETPUSHUNDEF; } +#ifdef USE_THREADS +void +unlock_condpair(void *svv) +{ + dTHR; + MAGIC *mg = mg_find((SV*)svv, 'm'); + + if (!mg) + croak("panic: unlock_condpair unlocking non-mutex"); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) != thr) + croak("panic: unlock_condpair unlocking mutex that we don't own"); + MgOWNER(mg) = 0; + COND_SIGNAL(MgOWNERCONDP(mg)); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", + (unsigned long)thr, (unsigned long)svv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); +} +#endif /* USE_THREADS */ + +PP(pp_lock) +{ + djSP; + dTOPss; + SV *retsv = sv; +#ifdef USE_THREADS + MAGIC *mg; + + if (SvROK(sv)) + sv = SvRV(sv); + + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", + (unsigned long)thr, (unsigned long)sv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); + SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */ + save_destructor(unlock_condpair, sv); + } +#endif /* USE_THREADS */ + if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV + || SvTYPE(retsv) == SVt_PVCV) { + retsv = refto(retsv); + } + SETs(retsv); + RETURN; +} + +PP(pp_threadsv) +{ + djSP; +#ifdef USE_THREADS + EXTEND(sp, 1); + if (op->op_private & OPpLVAL_INTRO) + PUSHs(*save_threadsv(op->op_targ)); + else + PUSHs(*av_fetch(thr->threadsv, op->op_targ, FALSE)); +#else + DIE("tried to access per-thread data in non-threaded perl"); +#endif /* USE_THREADS */ + RETURN; +}