X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=aaeca3fc2e5ab29b0e83251f8fa1fccd1e2eeae5;hb=565764a853a177193a027e73655fad354d57fc10;hp=4effd286db780f976880cc3d10f59aead3c290ec;hpb=43c928080ab3849e95bac569d60d022dc2b624ad;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 4effd28..aaeca3f 100644 --- a/pp.c +++ b/pp.c @@ -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,90 @@ * 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; +/* + * 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 + +#ifndef PERL_OBJECT static void doencodes _((SV* sv, char* s, I32 len)); static SV* refto _((SV* sv)); static U32 seed _((void)); +#endif 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; + djSP; if (GIMME_V == G_SCALAR) XPUSHs(&sv_undef); RETURN; @@ -54,7 +132,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); @@ -65,7 +143,16 @@ PP(pp_padav) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; EXTEND(SP, maxarg); - Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); + if (SvMAGICAL(TARG)) { + U32 i; + for (i=0; i < maxarg; i++) { + SV **svp = av_fetch((AV*)TARG, i, FALSE); + SP[i+1] = (svp) ? *svp : &sv_undef; + } + } + else { + Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); + } SP += maxarg; } else { @@ -79,7 +166,7 @@ PP(pp_padav) PP(pp_padhv) { - dSP; dTARGET; + djSP; dTARGET; I32 gimme; XPUSHs(TARG); @@ -93,11 +180,9 @@ PP(pp_padhv) } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); - if (HvFILL((HV*)TARG)) { - sprintf(buf, "%ld/%ld", - (long)HvFILL((HV*)TARG), (long)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); @@ -114,8 +199,8 @@ PP(pp_padany) PP(pp_rv2gv) { - dSP; dTOPss; - + djSP; dTOPss; + if (SvROK(sv)) { wasref: sv = SvRV(sv); @@ -123,7 +208,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"); @@ -159,7 +244,7 @@ PP(pp_rv2gv) PP(pp_rv2sv) { - dSP; dTOPss; + djSP; dTOPss; if (SvROK(sv)) { wasref: @@ -208,7 +293,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dSP; + djSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { @@ -222,8 +307,8 @@ PP(pp_av2arylen) PP(pp_pos) { - dSP; dTARGET; dPOPss; - + djSP; dTARGET; dPOPss; + if (op->op_flags & OPf_MOD) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); @@ -236,7 +321,7 @@ PP(pp_pos) RETURN; } else { - MAGIC* mg; + MAGIC* mg; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); @@ -251,7 +336,7 @@ PP(pp_pos) PP(pp_rv2cv) { - dSP; + djSP; GV *gv; HV *stash; @@ -270,7 +355,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dSP; + djSP; CV *cv; HV *stash; GV *gv; @@ -286,7 +371,7 @@ PP(pp_prototype) PP(pp_anoncode) { - dSP; + djSP; CV* cv = (CV*)curpad[op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -297,14 +382,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - dSP; + djSP; *SP = refto(*SP); RETURN; -} +} PP(pp_refgen) { - dSP; dMARK; + djSP; dMARK; if (GIMME != G_ARRAY) { MARK[1] = *SP; SP = MARK + 1; @@ -315,9 +400,8 @@ PP(pp_refgen) RETURN; } -static SV* -refto(sv) -SV* sv; +STATIC SV* +refto(SV *sv) { SV* rv; @@ -342,14 +426,14 @@ SV* sv; PP(pp_ref) { - dSP; dTARGET; + djSP; dTARGET; SV *sv; char *pv; sv = POPs; if (sv && SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); if (!sv || !SvROK(sv)) RETPUSHNO; @@ -362,7 +446,7 @@ PP(pp_ref) PP(pp_bless) { - dSP; + djSP; HV *stash; if (MAXARG == 1) @@ -374,11 +458,74 @@ PP(pp_bless) RETURN; } +PP(pp_gelem) +{ + GV *gv; + SV *sv; + SV *tmpRef; + char *elem; + djSP; + + sv = POPs; + elem = SvPV(sv, na); + gv = (GV*)POPs; + tmpRef = Nullsv; + sv = Nullsv; + switch (elem ? *elem : '\0') + { + case 'A': + if (strEQ(elem, "ARRAY")) + tmpRef = (SV*)GvAV(gv); + break; + case 'C': + if (strEQ(elem, "CODE")) + tmpRef = (SV*)GvCVu(gv); + break; + case 'F': + if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ + tmpRef = (SV*)GvIOp(gv); + break; + case 'G': + if (strEQ(elem, "GLOB")) + tmpRef = (SV*)gv; + break; + case 'H': + if (strEQ(elem, "HASH")) + tmpRef = (SV*)GvHV(gv); + break; + case 'I': + if (strEQ(elem, "IO")) + tmpRef = (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")) + tmpRef = GvSV(gv); + break; + } + if (tmpRef) + sv = newRV(tmpRef); + 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; @@ -386,6 +533,14 @@ PP(pp_study) register I32 *snext; STRLEN len; + 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; @@ -440,13 +595,13 @@ PP(pp_study) 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 +613,7 @@ PP(pp_trans) PP(pp_schop) { - dSP; dTARGET; + djSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -466,7 +621,7 @@ PP(pp_schop) PP(pp_chop) { - dSP; dMARK; dTARGET; + djSP; dMARK; dTARGET; while (SP > MARK) do_chop(TARG, POPs); PUSHTARG; @@ -475,16 +630,16 @@ 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) count += do_chomp(POPs); PUSHi(count); @@ -493,7 +648,7 @@ PP(pp_chomp) PP(pp_defined) { - dSP; + djSP; register SV* sv; sv = POPs; @@ -501,11 +656,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,7 +678,7 @@ PP(pp_defined) PP(pp_undef) { - dSP; + djSP; SV *sv; if (!op->op_private) { @@ -581,7 +736,7 @@ PP(pp_undef) PP(pp_predec) { - dSP; + djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -598,7 +753,7 @@ PP(pp_predec) PP(pp_postinc) { - dSP; dTARGET; + djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); sv_setsv(TARG, TOPs); @@ -619,7 +774,7 @@ PP(pp_postinc) PP(pp_postdec) { - dSP; dTARGET; + djSP; dTARGET; if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(no_modify); sv_setsv(TARG, TOPs); @@ -640,7 +795,7 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( pow( left, right) ); @@ -650,7 +805,7 @@ PP(pp_pow) PP(pp_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); @@ -660,7 +815,7 @@ PP(pp_multiply) PP(pp_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; double value; @@ -688,7 +843,7 @@ PP(pp_divide) PP(pp_modulo) { - dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left; UV right; @@ -721,8 +876,10 @@ PP(pp_modulo) if ((left_neg != right_neg) && ans) ans = right - ans; if (right_neg) { - if (ans <= -(UV)IV_MAX) - sv_setiv(TARG, (IV) -ans); + /* 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); } @@ -735,7 +892,7 @@ PP(pp_modulo) 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) { @@ -791,7 +948,7 @@ PP(pp_repeat) PP(pp_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -801,16 +958,18 @@ PP(pp_subtract) PP(pp_left_shift) { - dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { 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; } @@ -818,16 +977,18 @@ PP(pp_left_shift) PP(pp_right_shift) { - dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { 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; } @@ -835,7 +996,7 @@ PP(pp_right_shift) PP(pp_lt) { - dSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); @@ -845,7 +1006,7 @@ PP(pp_lt) PP(pp_gt) { - dSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); @@ -855,7 +1016,7 @@ PP(pp_gt) PP(pp_le) { - dSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -865,7 +1026,7 @@ PP(pp_le) PP(pp_ge) { - dSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -875,7 +1036,7 @@ PP(pp_ge) PP(pp_ne) { - dSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); @@ -885,7 +1046,7 @@ PP(pp_ne) PP(pp_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; @@ -907,7 +1068,7 @@ PP(pp_ncmp) PP(pp_slt) { - dSP; tryAMAGICbinSET(slt,0); + djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -920,7 +1081,7 @@ PP(pp_slt) PP(pp_sgt) { - dSP; tryAMAGICbinSET(sgt,0); + djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -933,7 +1094,7 @@ PP(pp_sgt) PP(pp_sle) { - dSP; tryAMAGICbinSET(sle,0); + djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -946,7 +1107,7 @@ PP(pp_sle) PP(pp_sge) { - dSP; tryAMAGICbinSET(sge,0); + djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -959,7 +1120,7 @@ PP(pp_sge) PP(pp_seq) { - dSP; tryAMAGICbinSET(seq,0); + djSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -969,7 +1130,7 @@ PP(pp_seq) PP(pp_sne) { - dSP; tryAMAGICbinSET(sne,0); + djSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -979,7 +1140,7 @@ PP(pp_sne) PP(pp_scmp) { - dSP; dTARGET; tryAMAGICbin(scmp,0); + djSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -992,17 +1153,17 @@ PP(pp_scmp) PP(pp_bit_and) { - dSP; dATARGET; tryAMAGICbin(band,opASSIGN); + djSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = SvIV(left) & SvIV(right); - SETi( value ); + IBW value = SvIV(left) & SvIV(right); + SETi(BWi(value)); } else { - UBW value = SvUV(left) & SvUV(right); - SETu( value ); + UBW value = SvUV(left) & SvUV(right); + SETu(BWu(value)); } } else { @@ -1015,17 +1176,17 @@ PP(pp_bit_and) PP(pp_bit_xor) { - dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi( value ); + 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( value ); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(BWu(value)); } } else { @@ -1038,17 +1199,17 @@ PP(pp_bit_xor) PP(pp_bit_or) { - dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi( value ); + 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( value ); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(BWu(value)); } } else { @@ -1061,7 +1222,7 @@ PP(pp_bit_or) PP(pp_negate) { - dSP; dTARGET; tryAMAGICun(neg); + djSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) @@ -1094,7 +1255,7 @@ PP(pp_negate) PP(pp_not) { #ifdef OVERLOAD - dSP; tryAMAGICunSET(not); + djSP; tryAMAGICunSET(not); #endif /* OVERLOAD */ *stack_sp = boolSV(!SvTRUE(*stack_sp)); return NORMAL; @@ -1102,17 +1263,17 @@ PP(pp_not) PP(pp_complement) { - dSP; dTARGET; tryAMAGICun(compl); + djSP; dTARGET; tryAMAGICun(compl); { dTOPss; 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 { @@ -1145,7 +1306,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -1155,7 +1316,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) @@ -1168,7 +1329,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1180,7 +1341,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl; SETi( left + right ); @@ -1190,7 +1351,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl; SETi( left - right ); @@ -1200,7 +1361,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -1210,7 +1371,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -1220,7 +1381,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -1230,7 +1391,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -1240,7 +1401,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -1250,7 +1411,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -1260,7 +1421,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -1278,7 +1439,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dSP; dTARGET; tryAMAGICun(neg); + djSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -1287,7 +1448,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dSP; dTARGET; tryAMAGICbin(atan2,0); + djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(atan2(left, right)); @@ -1297,7 +1458,7 @@ PP(pp_atan2) PP(pp_sin) { - dSP; dTARGET; tryAMAGICun(sin); + djSP; dTARGET; tryAMAGICun(sin); { double value; value = POPn; @@ -1309,7 +1470,7 @@ PP(pp_sin) PP(pp_cos) { - dSP; dTARGET; tryAMAGICun(cos); + djSP; dTARGET; tryAMAGICun(cos); { double value; value = POPn; @@ -1321,7 +1482,7 @@ PP(pp_cos) PP(pp_rand) { - dSP; dTARGET; + djSP; dTARGET; double value; if (MAXARG < 1) value = 1.0; @@ -1352,7 +1513,7 @@ PP(pp_rand) PP(pp_srand) { - dSP; + djSP; UV anum; if (MAXARG < 1) anum = seed(); @@ -1364,8 +1525,8 @@ PP(pp_srand) RETPUSHYES; } -static U32 -seed() +STATIC U32 +seed(void) { /* * This is really just a quick hack which grabs various garbage @@ -1389,6 +1550,7 @@ seed() #define SEED_C3 269 #define SEED_C5 26107 + dTHR; U32 u; #ifdef VMS # include @@ -1418,7 +1580,7 @@ seed() PP(pp_exp) { - dSP; dTARGET; tryAMAGICun(exp); + djSP; dTARGET; tryAMAGICun(exp); { double value; value = POPn; @@ -1430,7 +1592,7 @@ PP(pp_exp) PP(pp_log) { - dSP; dTARGET; tryAMAGICun(log); + djSP; dTARGET; tryAMAGICun(log); { double value; value = POPn; @@ -1446,7 +1608,7 @@ PP(pp_log) PP(pp_sqrt) { - dSP; dTARGET; tryAMAGICun(sqrt); + djSP; dTARGET; tryAMAGICun(sqrt); { double value; value = POPn; @@ -1462,7 +1624,7 @@ PP(pp_sqrt) PP(pp_int) { - dSP; dTARGET; + djSP; dTARGET; { double value = TOPn; IV iv; @@ -1490,7 +1652,7 @@ PP(pp_int) PP(pp_abs) { - dSP; dTARGET; tryAMAGICun(abs); + djSP; dTARGET; tryAMAGICun(abs); { double value = TOPn; IV iv; @@ -1512,7 +1674,7 @@ PP(pp_abs) PP(pp_hex) { - dSP; dTARGET; + djSP; dTARGET; char *tmps; I32 argtype; @@ -1523,7 +1685,7 @@ PP(pp_hex) PP(pp_oct) { - dSP; dTARGET; + djSP; dTARGET; UV value; I32 argtype; char *tmps; @@ -1545,50 +1707,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 && MAXARG < 3) - pos = 0; + 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; + } } - if (pos < 0 || pos > curlen) { + 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)) { @@ -1611,7 +1792,7 @@ PP(pp_substr) LvTYPE(TARG) = 'x'; LvTARG(TARG) = sv; LvTARGOFF(TARG) = pos; - LvTARGLEN(TARG) = rem; + LvTARGLEN(TARG) = rem; } } PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -1620,7 +1801,7 @@ PP(pp_substr) PP(pp_vec) { - dSP; dTARGET; + djSP; dTARGET; register I32 size = POPi; register I32 offset = POPi; register SV *src = POPs; @@ -1643,8 +1824,8 @@ PP(pp_vec) LvTYPE(TARG) = 'v'; LvTARG(TARG) = src; - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; } if (len > srclen) { if (size <= 8) @@ -1694,7 +1875,7 @@ PP(pp_vec) PP(pp_index) { - dSP; dTARGET; + djSP; dTARGET; SV *big; SV *little; I32 offset; @@ -1726,7 +1907,7 @@ PP(pp_index) PP(pp_rindex) { - dSP; dTARGET; + djSP; dTARGET; SV *big; SV *little; STRLEN blen; @@ -1763,7 +1944,7 @@ 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(); @@ -1779,7 +1960,7 @@ PP(pp_sprintf) PP(pp_ord) { - dSP; dTARGET; + djSP; dTARGET; I32 value; char *tmps; @@ -1798,7 +1979,7 @@ PP(pp_ord) PP(pp_chr) { - dSP; dTARGET; + djSP; dTARGET; char *tmps; (void)SvUPGRADE(TARG,SVt_PV); @@ -1814,7 +1995,7 @@ PP(pp_chr) PP(pp_crypt) { - dSP; dTARGET; dPOPTOPssrl; + djSP; dTARGET; dPOPTOPssrl; #ifdef HAS_CRYPT char *tmps = SvPV(left, na); #ifdef FCRYPT @@ -1832,7 +2013,7 @@ PP(pp_crypt) PP(pp_ucfirst) { - dSP; + djSP; SV *sv = TOPs; register char *s; @@ -1858,7 +2039,7 @@ PP(pp_ucfirst) PP(pp_lcfirst) { - dSP; + djSP; SV *sv = TOPs; register char *s; @@ -1885,7 +2066,7 @@ PP(pp_lcfirst) PP(pp_uc) { - dSP; + djSP; SV *sv = TOPs; register char *s; STRLEN len; @@ -1917,7 +2098,7 @@ PP(pp_uc) PP(pp_lc) { - dSP; + djSP; SV *sv = TOPs; register char *s; STRLEN len; @@ -1949,7 +2130,7 @@ PP(pp_lc) PP(pp_quotemeta) { - dSP; dTARGET; + djSP; dTARGET; SV *sv = TOPs; STRLEN len; register char *s = SvPV(sv,len); @@ -1978,7 +2159,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; @@ -2023,13 +2204,15 @@ 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); @@ -2037,7 +2220,9 @@ PP(pp_each) PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { PUTBACK; - sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */ + /* might clobber stack_sp */ + sv_setsv(TARG, realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); SPAGAIN; PUSHs(TARG); } @@ -2060,7 +2245,7 @@ PP(pp_keys) PP(pp_delete) { - dSP; + djSP; I32 gimme = GIMME_V; I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; @@ -2068,11 +2253,16 @@ PP(pp_delete) if (op->op_private & OPpSLICE) { dMARK; dORIGMARK; + U32 hvtype; hv = (HV*)POPs; - if (SvTYPE(hv) != SVt_PVHV) - DIE("Not a HASH reference"); + hvtype = SvTYPE(hv); while (++MARK <= SP) { - sv = hv_delete_ent(hv, *MARK, discard, 0); + 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) @@ -2086,9 +2276,12 @@ PP(pp_delete) else { SV *keysv = POPs; hv = (HV*)POPs; - if (SvTYPE(hv) != SVt_PVHV) + 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"); - sv = hv_delete_ent(hv, keysv, discard, 0); if (!sv) sv = &sv_undef; if (!discard) @@ -2099,30 +2292,39 @@ PP(pp_delete) 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)); @@ -2144,7 +2346,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 */ @@ -2157,7 +2359,7 @@ PP(pp_list) PP(pp_lslice) { - dSP; + djSP; SV **lastrelem = stack_sp; SV **lastlelem = stack_base + POPMARK; SV **firstlelem = stack_base + POPMARK + 1; @@ -2215,7 +2417,7 @@ PP(pp_lslice) PP(pp_anonlist) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; I32 items = SP - MARK; SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ @@ -2225,7 +2427,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { @@ -2233,7 +2435,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); } @@ -2244,7 +2446,7 @@ PP(pp_anonhash) PP(pp_splice) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -2255,15 +2457,29 @@ PP(pp_splice) I32 after; I32 diff; SV **tmparyval = 0; + MAGIC *mg; + + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { + *MARK-- = mg->mg_obj; + PUSHMARK(MARK); + PUTBACK; + ENTER; + perl_call_method("SPLICE",GIMME_V); + LEAVE; + SPAGAIN; + RETURN; + } SP++; if (++MARK < SP) { - offset = SvIVx(*MARK); + offset = i = SvIVx(*MARK); if (offset < 0) - offset += AvFILL(ary) + 1; + offset += AvFILLp(ary) + 1; else offset -= curcop->cop_arybase; + if (offset < 0) + DIE(no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) @@ -2276,15 +2492,9 @@ 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); + if (offset > AvFILLp(ary) + 1) + offset = AvFILLp(ary) + 1; + after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ length += after; /* offset+length now in array */ after = 0; @@ -2296,6 +2506,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) { @@ -2326,7 +2542,7 @@ PP(pp_splice) SvREFCNT_dec(*dst++); /* free them now */ } } - AvFILL(ary) += diff; + AvFILLp(ary) += diff; /* pull up or down? */ @@ -2347,7 +2563,7 @@ PP(pp_splice) dst = src + diff; /* diff is negative */ Move(src, dst, after, SV*); } - dst = &AvARRAY(ary)[AvFILL(ary)+1]; + dst = &AvARRAY(ary)[AvFILLp(ary)+1]; /* avoid later double free */ } i = -diff; @@ -2381,15 +2597,15 @@ PP(pp_splice) } SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ AvMAX(ary) += diff; - AvFILL(ary) += diff; + AvFILLp(ary) += diff; } else { - if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */ - av_extend(ary, AvFILL(ary) + diff); - AvFILL(ary) += diff; + if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ + av_extend(ary, AvFILLp(ary) + diff); + AvFILLp(ary) += diff; if (after) { - dst = AvARRAY(ary) + AvFILL(ary); + dst = AvARRAY(ary) + AvFILLp(ary); src = dst - diff; for (i = after; i; i--) { *dst-- = *src--; @@ -2437,15 +2653,28 @@ PP(pp_splice) PP(pp_push) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &sv_undef; + MAGIC *mg; - for (++MARK; MARK <= SP; MARK++) { - sv = NEWSV(51, 0); - if (*MARK) - sv_setsv(sv, *MARK); - av_push(ary, sv); + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { + *MARK-- = mg->mg_obj; + PUSHMARK(MARK); + PUTBACK; + ENTER; + perl_call_method("PUSH",G_SCALAR|G_DISCARD); + LEAVE; + SPAGAIN; + } + else { + /* Why no pre-extend of ary here ? */ + for (++MARK; MARK <= SP; MARK++) { + sv = NEWSV(51, 0); + if (*MARK) + sv_setsv(sv, *MARK); + av_push(ary, sv); + } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); @@ -2454,7 +2683,7 @@ PP(pp_push) PP(pp_pop) { - dSP; + djSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); if (!SvIMMORTAL(sv) && AvREAL(av)) @@ -2465,7 +2694,7 @@ PP(pp_pop) PP(pp_shift) { - dSP; + djSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); @@ -2479,18 +2708,30 @@ 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; + MAGIC *mg; + + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - av_unshift(ary, SP - MARK); - while (MARK < SP) { - sv = NEWSV(27, 0); - sv_setsv(sv, *++MARK); - (void)av_store(ary, i++, sv); - } + *MARK-- = mg->mg_obj; + PUTBACK; + ENTER; + perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD); + LEAVE; + SPAGAIN; + } + else { + av_unshift(ary, SP - MARK); + while (MARK < SP) { + sv = NEWSV(27, 0); + sv_setsv(sv, *++MARK); + (void)av_store(ary, i++, sv); + } + } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; @@ -2498,7 +2739,7 @@ PP(pp_unshift) PP(pp_reverse) { - dSP; dMARK; + djSP; dMARK; register SV *tmp; SV **oldsp = SP; @@ -2521,7 +2762,7 @@ PP(pp_reverse) if (SP - MARK > 1) do_join(TARG, &sv_no, MARK, SP); else - sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv)); + sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); up = SvPV_force(TARG, len); if (len > 1) { down = SvPVX(TARG) + len - 1; @@ -2538,10 +2779,8 @@ PP(pp_reverse) RETURN; } -static SV * -mul128(sv, m) - SV *sv; - U8 m; +STATIC SV * +mul128(SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); @@ -2549,11 +2788,11 @@ mul128(sv, m) U32 i = 0; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *new = newSVpv("0000000000", 10); + SV *New = newSVpv("0000000000", 10); - sv_catsv(new, sv); + sv_catsv(New, sv); SvREFCNT_dec(sv); /* free old sv */ - sv = new; + sv = New; s = SvPV(sv, len); } t = s + len - 1; @@ -2571,7 +2810,7 @@ mul128(sv, m) PP(pp_unpack) { - dSP; + djSP; dPOPPOPssrl; SV **oldsp = sp; I32 gimme = GIMME_V; @@ -2607,6 +2846,7 @@ 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 */ /*SUPPRESS 530*/ @@ -2621,7 +2861,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 == '*') { @@ -2637,6 +2879,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') @@ -2829,13 +3075,13 @@ PP(pp_unpack) } 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; } } @@ -2843,8 +3089,8 @@ 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, (IV)ashort); PUSHs(sv_2mortal(sv)); @@ -2854,16 +3100,16 @@ 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); + aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS if (datumtype == 'v') @@ -2876,12 +3122,12 @@ 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') - aushort = ntohs(aushort); + aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS if (datumtype == 'v') @@ -2945,13 +3191,13 @@ PP(pp_unpack) } 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 @@ -2962,8 +3208,8 @@ 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, (IV)along); PUSHs(sv_2mortal(sv)); @@ -2973,16 +3219,16 @@ 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); + aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL if (datumtype == 'V') @@ -2998,11 +3244,11 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); 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); + aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL if (datumtype == 'V') @@ -3036,7 +3282,7 @@ PP(pp_unpack) case 'w': EXTEND(SP, len); EXTEND_MORTAL(len); - { + { UV auv = 0; U32 bytes = 0; @@ -3051,12 +3297,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", - (int)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)) { @@ -3102,7 +3345,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; @@ -3117,7 +3363,10 @@ PP(pp_unpack) s += sizeof(unsigned Quad_t); } sv = NEWSV(43, 0); - sv_setuv(sv, (UV)auquad); + if (aquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else + sv_setnv(sv, (double)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -3199,10 +3448,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') @@ -3238,10 +3487,10 @@ 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; @@ -3252,11 +3501,8 @@ PP(pp_unpack) RETURN; } -static void -doencodes(sv, s, len) -register SV *sv; -register char *s; -register I32 len; +STATIC void +doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; @@ -3265,8 +3511,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; @@ -3279,10 +3525,8 @@ register I32 len; sv_catpvn(sv, "\n", 1); } -static SV * -is_an_int(s, l) - char *s; - STRLEN l; +STATIC SV * +is_an_int(char *s, STRLEN l) { SV *result = newSVpv("", l); char *result_c = SvPV(result, na); /* convenience */ @@ -3329,10 +3573,10 @@ is_an_int(s, l) return (result); } -static int -div128(pnum, done) - SV *pnum; /* must be '\0' terminated */ - bool *done; +STATIC int +div128(SV *pnum, bool *done) + /* must be '\0' terminated */ + { STRLEN len; char *s = SvPV(pnum, len); @@ -3360,7 +3604,7 @@ div128(pnum, done) PP(pp_pack) { - dSP; dMARK; dORIGMARK; dTARGET; + djSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; @@ -3387,13 +3631,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++; @@ -3407,6 +3654,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"); @@ -3607,9 +3858,9 @@ PP(pp_pack) fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTONS - ashort = htons(ashort); + ashort = PerlSock_htons(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'v': @@ -3619,7 +3870,7 @@ PP(pp_pack) #ifdef HAS_HTOVS ashort = htovs(ashort); #endif - sv_catpvn(cat, (char*)&ashort, sizeof(I16)); + CAT16(cat, &ashort); } break; case 'S': @@ -3627,13 +3878,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; @@ -3645,7 +3896,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);; @@ -3662,7 +3924,7 @@ PP(pp_pack) SV *norm; STRLEN len; bool done; - + /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) @@ -3706,35 +3968,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); + aulong = PerlSock_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 @@ -3759,7 +4021,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; @@ -3792,9 +4068,10 @@ PP(pp_pack) } #undef NEXTFROM + PP(pp_split) { - dSP; dTARG; + djSP; dTARG; AV *ary; register I32 limit = POPi; /* note, negative is forever */ SV *sv = POPs; @@ -3815,6 +4092,8 @@ PP(pp_split) AV *oldstack = curstack; I32 gimme = GIMME_V; I32 oldsave = savestack_ix; + I32 make_mortal = 1; + MAGIC *mg = (MAGIC *) NULL; #ifdef DEBUGGING Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); @@ -3831,20 +4110,33 @@ PP(pp_split) 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))) { realarray = 1; - if (!AvREAL(ary)) { - AvREAL_on(ary); - for (i = AvFILL(ary); i >= 0; i--) - AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ - } + PUTBACK; av_extend(ary,0); av_clear(ary); - /* temporarily switch stacks */ - SWITCHSTACK(curstack, ary); + SPAGAIN; + if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) { + PUSHMARK(SP); + XPUSHs(mg->mg_obj); + } + else { + if (!AvREAL(ary)) { + AvREAL_on(ary); + for (i = AvFILLp(ary); i >= 0; i--) + AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ + } + /* temporarily switch stacks */ + SWITCHSTACK(curstack, ary); + make_mortal = 0; + } } base = SP - stack_base; orig = s; @@ -3877,7 +4169,7 @@ PP(pp_split) dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); @@ -3897,16 +4189,18 @@ PP(pp_split) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m; } } - else if (pm->op_pmshort && !rx->nparens) { - i = SvCUR(pm->op_pmshort); - if (i == 1) { - i = *SvPVX(pm->op_pmshort); + 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) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != i; m++) ; @@ -3914,7 +4208,7 @@ PP(pp_split) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; @@ -3924,12 +4218,12 @@ 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); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + i; @@ -3939,9 +4233,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->exec_tainted); + TAINT_IF(RX_MATCH_TAINTED(rx)); if (rx->subbase && rx->subbase != orig) { m = s; @@ -3953,7 +4247,7 @@ PP(pp_split) m = rx->startp[0]; dstr = NEWSV(32, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); if (rx->nparens) { @@ -3966,7 +4260,7 @@ PP(pp_split) } else dstr = NEWSV(33, 0); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); } @@ -3974,16 +4268,17 @@ PP(pp_split) s = rx->endp[0]; } } + LEAVE_SCOPE(oldsave); iters = (SP - stack_base) - base; if (iters > maxiters) DIE("Split loop"); - + /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { dstr = NEWSV(34, strend-s); sv_setpvn(dstr, s, strend-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); iters++; @@ -3992,13 +4287,37 @@ PP(pp_split) while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) iters--, SP--; } + if (realarray) { - SWITCHSTACK(ary, oldstack); - if (gimme == G_ARRAY) { - EXTEND(SP, iters); - Copy(AvARRAY(ary), SP + 1, iters, SV*); - SP += iters; - RETURN; + if (!mg) { + 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*); + SP += iters; + RETURN; + } + } + else { + PUTBACK; + ENTER; + perl_call_method("PUSH",G_SCALAR|G_DISCARD); + LEAVE; + SPAGAIN; + if (gimme == G_ARRAY) { + /* EXTEND should not be needed - we just popped them */ + EXTEND(SP, iters); + for (i=0; i < iters; i++) { + SV **svp = av_fetch(ary, i, FALSE); + PUSHs((svp) ? *svp : &sv_undef); + } + RETURN; + } } } else { @@ -4013,3 +4332,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)); + RETURN; +#else + DIE("tried to access per-thread data in non-threaded perl"); +#endif /* USE_THREADS */ +}