X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=07bb33d367add9720dfe56396c8ad45a7bec8f46;hb=5bc28da93666e223bb56098f72517273bc8bcbf9;hp=6780fab45101acbc76dbd50141e3b25c903892dc;hpb=70c6d02e8060a55a75042c794203b8925b3151f3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp.c b/pp.c
index 6780fab..07bb33d 100644
--- a/pp.c
+++ b/pp.c
@@ -406,6 +406,8 @@ PP(pp_rv2cv)
     if (cv) {
 	if (CvCLONE(cv))
 	    cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+	if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+	    Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
     }
     else
 	cv = (CV*)&PL_sv_undef;
@@ -900,7 +902,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     djSP; dTARGET;
-    if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 	Perl_croak(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
@@ -1776,9 +1778,9 @@ S_seed(pTHX)
 #  endif
 #endif
     u += SEED_C3 * (U32)getpid();
-    u += SEED_C4 * (U32)(UV)PL_stack_sp;
+    u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
-    u += SEED_C5 * (U32)(UV)&when;
+    u += SEED_C5 * (U32)PTR2UV(&when);
 #endif
     return u;
 }
@@ -1885,14 +1887,14 @@ PP(pp_hex)
     STRLEN n_a;
 
     tmps = POPpx;
-    XPUSHu(scan_hex(tmps, 99, &argtype));
+    XPUSHn(scan_hex(tmps, 99, &argtype));
     RETURN;
 }
 
 PP(pp_oct)
 {
     djSP; dTARGET;
-    UV value;
+    NV value;
     I32 argtype;
     char *tmps;
     STRLEN n_a;
@@ -1908,7 +1910,7 @@ PP(pp_oct)
 	value = scan_bin(++tmps, 99, &argtype);
     else
 	value = scan_oct(tmps, 99, &argtype);
-    XPUSHu(value);
+    XPUSHn(value);
     RETURN;
 }
 
@@ -2052,74 +2054,24 @@ PP(pp_vec)
     register I32 offset = POPi;
     register SV *src = POPs;
     I32 lvalue = PL_op->op_flags & OPf_MOD;
-    STRLEN srclen;
-    unsigned char *s = (unsigned char*)SvPV(src, srclen);
-    unsigned long retnum;
-    I32 len;
-
-    SvTAINTED_off(TARG);			/* decontaminate */
-    offset *= size;		/* turn into bit offset */
-    len = (offset + size + 7) / 8;
-    if (offset < 0 || size < 1)
-	retnum = 0;
-    else {
-	if (lvalue) {                      /* it's an lvalue! */
-	    if (SvTYPE(TARG) < SVt_PVLV) {
-		sv_upgrade(TARG, SVt_PVLV);
-		sv_magic(TARG, Nullsv, 'v', Nullch, 0);
-	    }
 
-	    LvTYPE(TARG) = 'v';
-	    if (LvTARG(TARG) != src) {
-		if (LvTARG(TARG))
-		    SvREFCNT_dec(LvTARG(TARG));
-		LvTARG(TARG) = SvREFCNT_inc(src);
-	    }
-	    LvTARGOFF(TARG) = offset;
-	    LvTARGLEN(TARG) = size;
-	}
-	if (len > srclen) {
-	    if (size <= 8)
-		retnum = 0;
-	    else {
-		offset >>= 3;
-		if (size == 16) {
-		    if (offset >= srclen)
-			retnum = 0;
-		    else
-			retnum = (unsigned long) s[offset] << 8;
-		}
-		else if (size == 32) {
-		    if (offset >= srclen)
-			retnum = 0;
-		    else if (offset + 1 >= srclen)
-			retnum = (unsigned long) s[offset] << 24;
-		    else if (offset + 2 >= srclen)
-			retnum = ((unsigned long) s[offset] << 24) +
-			    ((unsigned long) s[offset + 1] << 16);
-		    else
-			retnum = ((unsigned long) s[offset] << 24) +
-			    ((unsigned long) s[offset + 1] << 16) +
-			    (s[offset + 2] << 8);
-		}
-	    }
+    SvTAINTED_off(TARG);		/* decontaminate */
+    if (lvalue) {			/* it's an lvalue! */
+	if (SvTYPE(TARG) < SVt_PVLV) {
+	    sv_upgrade(TARG, SVt_PVLV);
+	    sv_magic(TARG, Nullsv, 'v', Nullch, 0);
 	}
-	else if (size < 8)
-	    retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
-	else {
-	    offset >>= 3;
-	    if (size == 8)
-		retnum = s[offset];
-	    else if (size == 16)
-		retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
-	    else if (size == 32)
-		retnum = ((unsigned long) s[offset] << 24) +
-			((unsigned long) s[offset + 1] << 16) +
-			(s[offset + 2] << 8) + s[offset+3];
+	LvTYPE(TARG) = 'v';
+	if (LvTARG(TARG) != src) {
+	    if (LvTARG(TARG))
+		SvREFCNT_dec(LvTARG(TARG));
+	    LvTARG(TARG) = SvREFCNT_inc(src);
 	}
+	LvTARGOFF(TARG) = offset;
+	LvTARGLEN(TARG) = size;
     }
 
-    sv_setuv(TARG, (UV)retnum);
+    sv_setuv(TARG, do_vecget(src, offset, size));
     PUSHs(TARG);
     RETURN;
 }
@@ -2308,7 +2260,8 @@ PP(pp_ucfirst)
 	    s = (U8*)SvPV_force(sv, slen);
 	    Copy(tmpbuf, s, ulen, U8);
 	}
-    } else {
+    }
+    else {
 	if (!SvPADTMP(sv)) {
 	    dTARGET;
 	    sv_setsv(TARG, sv);
@@ -2364,7 +2317,8 @@ PP(pp_lcfirst)
 	    s = (U8*)SvPV_force(sv, slen);
 	    Copy(tmpbuf, s, ulen, U8);
 	}
-    } else {
+    }
+    else {
 	if (!SvPADTMP(sv)) {
 	    dTARGET;
 	    sv_setsv(TARG, sv);
@@ -2405,7 +2359,8 @@ PP(pp_uc)
 	if (!len) {
 	    sv_setpvn(TARG, "", 0);
 	    SETs(TARG);
-	} else {
+	}
+	else {
 	    (void)SvUPGRADE(TARG, SVt_PV);
 	    SvGROW(TARG, (len * 2) + 1);
 	    (void)SvPOK_only(TARG);
@@ -2429,7 +2384,8 @@ PP(pp_uc)
 	    SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
 	    SETs(TARG);
 	}
-    } else {
+    }
+    else {
 	if (!SvPADTMP(sv)) {
 	    dTARGET;
 	    sv_setsv(TARG, sv);
@@ -2474,7 +2430,8 @@ PP(pp_lc)
 	if (!len) {
 	    sv_setpvn(TARG, "", 0);
 	    SETs(TARG);
-	} else {
+	}
+	else {
 	    (void)SvUPGRADE(TARG, SVt_PV);
 	    SvGROW(TARG, (len * 2) + 1);
 	    (void)SvPOK_only(TARG);
@@ -2498,7 +2455,8 @@ PP(pp_lc)
 	    SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
 	    SETs(TARG);
 	}
-    } else {
+    }
+    else {
 	if (!SvPADTMP(sv)) {
 	    dTARGET;
 	    sv_setsv(TARG, sv);
@@ -2625,7 +2583,7 @@ PP(pp_aslice)
 
 PP(pp_each)
 {
-    djSP; dTARGET;
+    djSP;
     HV *hash = (HV*)POPs;
     HE *entry;
     I32 gimme = GIMME_V;
@@ -2640,12 +2598,13 @@ PP(pp_each)
     if (entry) {
 	PUSHs(hv_iterkeysv(entry));	/* won't clobber stack_sp */
 	if (gimme == G_ARRAY) {
+	    SV *val;
 	    PUTBACK;
 	    /* might clobber stack_sp */
-	    sv_setsv(TARG, realhv ?
-		     hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
+	    val = realhv ?
+		  hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
 	    SPAGAIN;
-	    PUSHs(TARG);
+	    PUSHs(val);
 	}
     }
     else if (gimme == G_SCALAR)
@@ -3192,9 +3151,10 @@ PP(pp_reverse)
 			up = (char*)s;
 			s += UTF8SKIP(s);
 			down = (char*)(s - 1);
-			if ((s > send || !((*down & 0xc0) == 0x80)) &&
-					ckWARN_d(WARN_UTF8)) {
-			    Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
+			if (s > send || !((*down & 0xc0) == 0x80)) {
+			    if (ckWARN_d(WARN_UTF8))
+				Perl_warner(aTHX_ WARN_UTF8,
+					    "Malformed UTF-8 character");
 			    break;
 			}
 			while (down > up) {
@@ -3342,8 +3302,11 @@ PP(pp_unpack)
 	}
 	else if (isDIGIT(*pat)) {
 	    len = *pat++ - '0';
-	    while (isDIGIT(*pat))
+	    while (isDIGIT(*pat)) {
 		len = (len * 10) + (*pat++ - '0');
+		if (len < 0)
+		    Perl_croak(aTHX_ "Repeat count in unpack overflows");
+	    }
 	}
 	else
 	    len = (datumtype != '@');
@@ -3378,6 +3341,18 @@ PP(pp_unpack)
 		DIE(aTHX_ "x outside of string");
 	    s += len;
 	    break;
+	case '#':
+	    if (oldsp >= SP)
+		DIE(aTHX_ "# must follow a numeric type");
+	    if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
+		DIE(aTHX_ "# must be followed by a, A or Z");
+	    datumtype = *pat++;
+	    if (*pat == '*')
+		pat++;		/* ignore '*' for compatibility with pack */
+	    if (isDIGIT(*pat))
+		DIE(aTHX_ "# cannot take a count" );
+	    len = POPi;
+	    /* drop through */
 	case 'A':
 	case 'Z':
 	case 'a':
@@ -3588,6 +3563,7 @@ PP(pp_unpack)
 	    if (checksum) {
 #if SHORTSIZE != SIZE16
 		if (natint) {
+		    short ashort;
 		    while (len-- > 0) {
 			COPYNN(s, &ashort, sizeof(short));
 			s += sizeof(short);
@@ -3614,6 +3590,7 @@ PP(pp_unpack)
 		EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
 		if (natint) {
+		    short ashort;
 		    while (len-- > 0) {
 			COPYNN(s, &ashort, sizeof(short));
 			s += sizeof(short);
@@ -3653,6 +3630,7 @@ PP(pp_unpack)
 	    if (checksum) {
 #if SHORTSIZE != SIZE16
 		if (unatint) {
+		    unsigned short aushort;
 		    while (len-- > 0) {
 			COPYNN(s, &aushort, sizeof(unsigned short));
 			s += sizeof(unsigned short);
@@ -3682,6 +3660,7 @@ PP(pp_unpack)
 		EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
 		if (unatint) {
+		    unsigned short aushort;
 		    while (len-- > 0) {
 			COPYNN(s, &aushort, sizeof(unsigned short));
 			s += sizeof(unsigned short);
@@ -3806,6 +3785,7 @@ PP(pp_unpack)
 	    if (checksum) {
 #if LONGSIZE != SIZE32
 		if (natint) {
+		    long along;
 		    while (len-- > 0) {
 			COPYNN(s, &along, sizeof(long));
 			s += sizeof(long);
@@ -3837,6 +3817,7 @@ PP(pp_unpack)
 		EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
 		if (natint) {
+		    long along;
 		    while (len-- > 0) {
 			COPYNN(s, &along, sizeof(long));
 			s += sizeof(long);
@@ -3876,6 +3857,7 @@ PP(pp_unpack)
 	    if (checksum) {
 #if LONGSIZE != SIZE32
 		if (unatint) {
+		    unsigned long aulong;
 		    while (len-- > 0) {
 			COPYNN(s, &aulong, sizeof(unsigned long));
 			s += sizeof(unsigned long);
@@ -3911,6 +3893,7 @@ PP(pp_unpack)
 		EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
 		if (unatint) {
+		    unsigned long aulong;
 		    while (len-- > 0) {
 			COPYNN(s, &aulong, sizeof(unsigned long));
 			s += sizeof(unsigned long);
@@ -4348,7 +4331,8 @@ PP(pp_pack)
     MARK++;
     sv_setpvn(cat, "", 0);
     while (pat < patend) {
-#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
+	SV *lengthcode = Nullsv;
+#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
 	datumtype = *pat++ & 0xFF;
 #ifdef PERL_NATINT_PACK
 	natint = 0;
@@ -4373,17 +4357,28 @@ PP(pp_pack)
 	}
 	else if (isDIGIT(*pat)) {
 	    len = *pat++ - '0';
-	    while (isDIGIT(*pat))
+	    while (isDIGIT(*pat)) {
 		len = (len * 10) + (*pat++ - '0');
+		if (len < 0)
+		    Perl_croak(aTHX_ "Repeat count in pack overflows");
+	    }
 	}
 	else
 	    len = 1;
+	if (*pat == '#') {
+	    ++pat;
+	    if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
+		DIE(aTHX_ "# must be followed by a*, A* or Z*");
+	    lengthcode = sv_2mortal(newSViv(sv_len(items > 0
+						   ? *MARK : &PL_sv_no)));
+	}
 	switch(datumtype) {
 	default:
 	    Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
 	case ',': /* grandfather in commas but with a warning */
 	    if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
+		Perl_warner(aTHX_ WARN_UNSAFE,
+			    "Invalid type in pack: '%c'", (int)datumtype);
 	    break;
 	case '%':
 	    DIE(aTHX_ "%% may only be used in unpack");
@@ -4637,6 +4632,8 @@ PP(pp_pack)
 	case 's':
 #if SHORTSIZE != SIZE16
 	    if (natint) {
+		short ashort;
+
 		while (len-- > 0) {
 		    fromstr = NEXTFROM;
 		    ashort = SvIV(fromstr);
@@ -4760,6 +4757,8 @@ PP(pp_pack)
 	case 'L':
 #if LONGSIZE != SIZE32
 	    if (natint) {
+		unsigned long aulong;
+
 		while (len-- > 0) {
 		    fromstr = NEXTFROM;
 		    aulong = SvUV(fromstr);
@@ -4779,6 +4778,8 @@ PP(pp_pack)
 	case 'l':
 #if LONGSIZE != SIZE32
 	    if (natint) {
+		long along;
+
 		while (len-- > 0) {
 		    fromstr = NEXTFROM;
 		    along = SvIV(fromstr);
@@ -4799,7 +4800,7 @@ PP(pp_pack)
 	case 'Q':
 	    while (len-- > 0) {
 		fromstr = NEXTFROM;
-		auquad = (Uquad_t)SvIV(fromstr);
+		auquad = (Uquad_t)SvUV(fromstr);
 		sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
 	    }
 	    break;
@@ -4928,6 +4929,7 @@ PP(pp_split)
 	else {
 	    if (!AvREAL(ary)) {
 		AvREAL_on(ary);
+		AvREIFY_off(ary);
 		for (i = AvFILLp(ary); i >= 0; i--)
 		    AvARRAY(ary)[i] = &PL_sv_undef;	/* don't free mere refs */
 	    }
@@ -5179,7 +5181,7 @@ PP(pp_lock)
 	DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
 			      (unsigned long)thr, (unsigned long)sv);)
 	MUTEX_UNLOCK(MgMUTEXP(mg));
-	save_destructor(Perl_unlock_condpair, sv);
+	SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
     }
 #endif /* USE_THREADS */
     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV