X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=001b9be795baf86b6875fe0ec645f40d7afdf1b1;hb=37d2ac1837312847ffa94e41a7233dcd5cd4c1fe;hp=eccf7eb0c9049956bdf58b6f9aaed9204a2857d8;hpb=f02c194e1a40f11d020685cd18b41e5261091b12;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp.c b/pp.c
index eccf7eb..001b9be 100644
--- a/pp.c
+++ b/pp.c
@@ -1,7 +1,7 @@
 /*    pp.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -106,15 +106,7 @@ PP(pp_padhv)
 	RETURNOP(do_kv());
     }
     else if (gimme == G_SCALAR) {
-	SV* sv = sv_newmortal();
-        if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
-	     Perl_croak(aTHX_ "Can't provide tied hash usage; "
-			"use keys(%%hash) to test if empty");
-	if (HvFILL((HV*)TARG))
-	    Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
-		      (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
-	else
-	    sv_setiv(sv, 0);
+	SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
 	SETs(sv);
     }
     RETURN;
@@ -176,6 +168,12 @@ PP(pp_rv2gv)
 		    }
 		    if (SvTYPE(sv) < SVt_RV)
 			sv_upgrade(sv, SVt_RV);
+		    if (SvPVX(sv)) {
+			(void)SvOOK_off(sv);		/* backoff */
+			if (SvLEN(sv))
+			    Safefree(SvPVX(sv));
+			SvLEN(sv)=SvCUR(sv)=0;
+		    }
 		    SvRV(sv) = (SV*)gv;
 		    SvROK_on(sv);
 		    SvSETMAGIC(sv);
@@ -185,7 +183,7 @@ PP(pp_rv2gv)
 		    PL_op->op_private & HINT_STRICT_REFS)
 		    DIE(aTHX_ PL_no_usym, "a symbol");
 		if (ckWARN(WARN_UNINITIALIZED))
-		    report_uninit();
+		    report_uninit(sv);
 		RETSETUNDEF;
 	    }
 	    sym = SvPV(sv,len);
@@ -246,7 +244,7 @@ PP(pp_rv2sv)
 		    PL_op->op_private & HINT_STRICT_REFS)
 		    DIE(aTHX_ PL_no_usym, "a SCALAR");
 		if (ckWARN(WARN_UNINITIALIZED))
-		    report_uninit();
+		    report_uninit(sv);
 		RETSETUNDEF;
 	    }
 	    sym = SvPV(sv, len);
@@ -688,6 +686,8 @@ PP(pp_trans)
 
     if (PL_op->op_flags & OPf_STACKED)
 	sv = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+	sv = GETTARGET;
     else {
 	sv = DEFSV;
 	EXTEND(SP,1);
@@ -836,7 +836,7 @@ PP(pp_undef)
 PP(pp_predec)
 {
     dSP;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MIN)
@@ -853,7 +853,7 @@ PP(pp_predec)
 PP(pp_postinc)
 {
     dSP; dTARGET;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
@@ -875,7 +875,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     dSP; dTARGET;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
@@ -972,6 +972,7 @@ PP(pp_pow)
 		    register unsigned int highbit = 8 * sizeof(UV);
 		    register unsigned int lowbit = 0;
 		    register unsigned int diff;
+		    bool odd_power = (bool)(power & 1);
 		    while ((diff = (highbit - lowbit) >> 1)) {
 			if (baseuv & ~((1 << (lowbit + diff)) - 1))
 			    lowbit += diff;
@@ -994,7 +995,7 @@ PP(pp_pow)
 			    }
 			}
 			SP--;
-			if (baseuok || !(power & 1))
+			if (baseuok || !odd_power)
 			    /* answer is positive */
 			    SETu( result );
 			else if (result <= (UV)IV_MAX)
@@ -1390,13 +1391,46 @@ PP(pp_repeat)
 {
   dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
   {
-    register IV count = POPi;
+    register IV count;
+    dPOPss;
+    if (SvGMAGICAL(sv))
+	 mg_get(sv);
+    if (SvIOKp(sv)) {
+	 if (SvUOK(sv)) {
+	      UV uv = SvUV(sv);
+	      if (uv > IV_MAX)
+		   count = IV_MAX; /* The best we can do? */
+	      else
+		   count = uv;
+	 } else {
+	      IV iv = SvIV(sv);
+	      if (iv < 0)
+		   count = 0;
+	      else
+		   count = iv;
+	 }
+    }
+    else if (SvNOKp(sv)) {
+	 NV nv = SvNV(sv);
+	 if (nv < 0.0)
+	      count = 0;
+	 else
+	      count = (IV)nv;
+    }
+    else
+	 count = SvIVx(sv);
     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
 	dMARK;
 	I32 items = SP - MARK;
 	I32 max;
+	static const char oom_list_extend[] =
+	  "Out of memory during list extend";
 
 	max = items * count;
+	MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
+	/* Did the max computation overflow? */
+	if (items > 0 && max > 0 && (max < items || max < count))
+	   Perl_croak(aTHX_ oom_list_extend);
 	MEXTEND(MARK, max);
 	if (count > 1) {
 	    while (SP > MARK) {
@@ -1441,6 +1475,8 @@ PP(pp_repeat)
 	SV *tmpstr = POPs;
 	STRLEN len;
 	bool isutf;
+	static const char oom_string_extend[] =
+	  "Out of memory during string extend";
 
 	SvSetSV(TARG, tmpstr);
 	SvPV_force(TARG, len);
@@ -1449,6 +1485,10 @@ PP(pp_repeat)
 	    if (count < 1)
 		SvCUR_set(TARG, 0);
 	    else {
+		IV max = count * len;
+		if (len > ((MEM_SIZE)~0)/count)
+		     Perl_croak(aTHX_ oom_string_extend);
+	        MEM_WRAP_CHECK_1(max, char, oom_string_extend);
 		SvGROW(TARG, (count * len) + 1);
 		repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
 		SvCUR(TARG) *= count;
@@ -2207,13 +2247,15 @@ PP(pp_bit_and)
     dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
     {
       dPOPTOPssrl;
+      if (SvGMAGICAL(left)) mg_get(left);
+      if (SvGMAGICAL(right)) mg_get(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
 	if (PL_op->op_private & HINT_INTEGER) {
-	  IV i = SvIV(left) & SvIV(right);
+	  IV i = SvIV_nomg(left) & SvIV_nomg(right);
 	  SETi(i);
 	}
 	else {
-	  UV u = SvUV(left) & SvUV(right);
+	  UV u = SvUV_nomg(left) & SvUV_nomg(right);
 	  SETu(u);
 	}
       }
@@ -2230,13 +2272,15 @@ PP(pp_bit_xor)
     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
     {
       dPOPTOPssrl;
+      if (SvGMAGICAL(left)) mg_get(left);
+      if (SvGMAGICAL(right)) mg_get(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
 	if (PL_op->op_private & HINT_INTEGER) {
-	  IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+	  IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
 	  SETi(i);
 	}
 	else {
-	  UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+	  UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
 	  SETu(u);
 	}
       }
@@ -2253,13 +2297,15 @@ PP(pp_bit_or)
     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
     {
       dPOPTOPssrl;
+      if (SvGMAGICAL(left)) mg_get(left);
+      if (SvGMAGICAL(right)) mg_get(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
 	if (PL_op->op_private & HINT_INTEGER) {
-	  IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+	  IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
 	  SETi(i);
 	}
 	else {
-	  UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+	  UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
 	  SETu(u);
 	}
       }
@@ -2354,13 +2400,15 @@ PP(pp_complement)
     dSP; dTARGET; tryAMAGICun(compl);
     {
       dTOPss;
+      if (SvGMAGICAL(sv))
+	  mg_get(sv);
       if (SvNIOKp(sv)) {
 	if (PL_op->op_private & HINT_INTEGER) {
-	  IV i = ~SvIV(sv);
+	  IV i = ~SvIV_nomg(sv);
 	  SETi(i);
 	}
 	else {
-	  UV u = ~SvUV(sv);
+	  UV u = ~SvUV_nomg(sv);
 	  SETu(u);
 	}
       }
@@ -2369,7 +2417,8 @@ PP(pp_complement)
 	register I32 anum;
 	STRLEN len;
 
-	SvSetSV(TARG, sv);
+	(void)SvPV_nomg(sv,len); /* force check for uninit var */
+	sv_setsv_nomg(TARG, sv);
 	tmps = (U8*)SvPV_force(TARG, len);
 	anum = len;
 	if (SvUTF8(TARG)) {
@@ -2416,6 +2465,7 @@ PP(pp_complement)
 	      *result = '\0';
 	      result -= nchar;
 	      sv_setpvn(TARG, (char*)result, nchar);
+	      SvUTF8_off(TARG);
 	  }
 	  Safefree(result);
 	  SETs(TARG);
@@ -2727,87 +2777,6 @@ PP(pp_srand)
     RETPUSHYES;
 }
 
-STATIC U32
-S_seed(pTHX)
-{
-    /*
-     * 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 things 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 anything 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
-
-#ifndef PERL_NO_DEV_RANDOM
-    int fd;
-#endif
-    U32 u;
-#ifdef VMS
-#  include <starlet.h>
-    /* when[] = (low 32 bits, high 32 bits) of time since epoch
-     * in 100-ns units, typically incremented ever 10 ms.        */
-    unsigned int when[2];
-#else
-#  ifdef HAS_GETTIMEOFDAY
-    struct timeval when;
-#  else
-    Time_t when;
-#  endif
-#endif
-
-/* This test is an escape hatch, this symbol isn't set by Configure. */
-#ifndef PERL_NO_DEV_RANDOM
-#ifndef PERL_RANDOM_DEVICE
-   /* /dev/random isn't used by default because reads from it will block
-    * if there isn't enough entropy available.  You can compile with
-    * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
-    * is enough real entropy to fill the seed. */
-#  define PERL_RANDOM_DEVICE "/dev/urandom"
-#endif
-    fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
-    if (fd != -1) {
-    	if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
-	    u = 0;
-	PerlLIO_close(fd);
-	if (u)
-	    return u;
-    }
-#endif
-
-#ifdef VMS
-    _ckvmssts(sys$gettim(when));
-    u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-#  ifdef HAS_GETTIMEOFDAY
-    PerlProc_gettimeofday(&when,NULL);
-    u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-#  else
-    (void)time(&when);
-    u = (U32)SEED_C1 * when;
-#  endif
-#endif
-    u += SEED_C3 * (U32)PerlProc_getpid();
-    u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
-#ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
-    u += SEED_C5 * (U32)PTR2UV(&when);
-#endif
-    return u;
-}
-
 PP(pp_exp)
 {
     dSP; dTARGET; tryAMAGICun(exp);
@@ -2852,28 +2821,6 @@ PP(pp_sqrt)
     }
 }
 
-/*
- * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
- * These need to be revisited when a newer toolchain becomes available.
- */
-#if defined(__sparc64__) && defined(__GNUC__)
-#   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
-#       undef  SPARC64_MODF_WORKAROUND
-#       define SPARC64_MODF_WORKAROUND 1
-#   endif
-#endif
-
-#if defined(SPARC64_MODF_WORKAROUND)
-static NV
-sparc64_workaround_modf(NV theVal, NV *theIntRes)
-{
-    NV res, ret;
-    ret = Perl_modf(theVal, &res);
-    *theIntRes = res;
-    return ret;
-}
-#endif
-
 PP(pp_int)
 {
     dSP; dTARGET; tryAMAGICun(int);
@@ -2885,7 +2832,9 @@ PP(pp_int)
 	 else preferring IV has introduced a subtle behaviour change bug. OTOH
 	 relying on floating point to be accurate is a bug.  */
 
-      if (SvIOK(TOPs)) {
+      if (!SvOK(TOPs))
+        SETu(0);
+      else if (SvIOK(TOPs)) {
 	if (SvIsUV(TOPs)) {
 	    UV uv = TOPu;
 	    SETu(uv);
@@ -2897,34 +2846,14 @@ PP(pp_int)
 	      if (value < (NV)UV_MAX + 0.5) {
 		  SETu(U_V(value));
 	      } else {
-#if defined(SPARC64_MODF_WORKAROUND)
-                  (void)sparc64_workaround_modf(value, &value);
-#elif defined(HAS_MODFL_POW32_BUG)
-/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
-                  NV offset = Perl_modf(value, &value);
-                  (void)Perl_modf(offset, &offset);
-                  value += offset;
-#else
-                  (void)Perl_modf(value, &value);
-#endif
-		  SETn(value);
+		  SETn(Perl_floor(value));
 	      }
 	  }
 	  else {
 	      if (value > (NV)IV_MIN - 0.5) {
 		  SETi(I_V(value));
 	      } else {
-#if defined(SPARC64_MODF_WORKAROUND)
-                  (void)sparc64_workaround_modf(-value, &value);
-#elif defined(HAS_MODFL_POW32_BUG)
-/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
-                  NV offset = Perl_modf(-value, &value);
-                  (void)Perl_modf(offset, &offset);
-                  value += offset;
-#else
-		  (void)Perl_modf(-value, &value);
-#endif
-		  SETn(-value);
+		  SETn(Perl_ceil(value));
 	      }
 	  }
       }
@@ -2939,7 +2868,9 @@ PP(pp_abs)
       /* This will cache the NV value if string isn't actually integer  */
       IV iv = TOPi;
 
-      if (SvIOK(TOPs)) {
+      if (!SvOK(TOPs))
+        SETu(0);
+      else if (SvIOK(TOPs)) {
 	/* IVX is precise  */
 	if (SvIsUV(TOPs)) {
 	  SETu(TOPu);	/* force it to be numeric only */
@@ -3149,6 +3080,19 @@ PP(pp_substr)
 	if (utf8_curlen)
 	    sv_pos_u2b(sv, &pos, &rem);
 	tmps += pos;
+	/* we either return a PV or an LV. If the TARG hasn't been used
+	 * before, or is of that type, reuse it; otherwise use a mortal
+	 * instead. Note that LVs can have an extended lifetime, so also
+	 * dont reuse if refcount > 1 (bug #20933) */
+	if (SvTYPE(TARG) > SVt_NULL) {
+	    if ( (SvTYPE(TARG) == SVt_PVLV)
+		    ? (!lvalue || SvREFCNT(TARG) > 1)
+		    : lvalue)
+	    {
+		TARG = sv_newmortal();
+	    }
+	}
+
 	sv_setpvn(TARG, tmps, rem);
 #ifdef USE_LOCALE_COLLATE
 	sv_unmagic(TARG, PERL_MAGIC_collxfrm);
@@ -3185,12 +3129,12 @@ PP(pp_substr)
 		    sv_setpvn(sv,"",0);	/* avoid lexical reincarnation */
 	    }
 
-	    if (SvREFCNT(TARG) > 1)	/* don't share the TARG (#20933) */
-		TARG = sv_newmortal();
 	    if (SvTYPE(TARG) < SVt_PVLV) {
 		sv_upgrade(TARG, SVt_PVLV);
 		sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
 	    }
+	    else
+		(void)SvOK_off(TARG);
 
 	    LvTYPE(TARG) = 'x';
 	    if (LvTARG(TARG) != sv) {
@@ -3887,7 +3831,10 @@ PP(pp_delete)
 	    SP = ORIGMARK;
 	else if (gimme == G_SCALAR) {
 	    MARK = ORIGMARK;
-	    *++MARK = *SP;
+	    if (SP > MARK)
+		*++MARK = *SP;
+	    else
+		*++MARK = &PL_sv_undef;
 	    SP = MARK;
 	}
     }
@@ -4419,12 +4366,17 @@ PP(pp_reverse)
 	register I32 tmp;
 	dTARGET;
 	STRLEN len;
+	I32 padoff_du;
 
 	SvUTF8_off(TARG);				/* decontaminate */
 	if (SP - MARK > 1)
 	    do_join(TARG, &PL_sv_no, MARK, SP);
 	else
-	    sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
+	    sv_setsv(TARG, (SP > MARK)
+		    ? *SP
+		    : (padoff_du = find_rundefsvoffset(),
+			(padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+			? DEFSV : PAD_SVl(padoff_du)));
 	up = SvPV_force(TARG, len);
 	if (len > 1) {
 	    if (DO_UTF8(TARG)) {	/* first reverse each character */
@@ -4553,7 +4505,7 @@ PP(pp_split)
 		s++;
 	}
     }
-    if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
+    if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
 	SAVEINT(PL_multiline);
 	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
@@ -4658,13 +4610,13 @@ PP(pp_split)
     }
     else {
 	maxiters += slen * rx->nparens;
-	while (s < strend && --limit
-/*	       && (!rx->check_substr
-		   || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
-						 0, NULL))))
-*/	       && CALLREGEXEC(aTHX_ rx, s, strend, orig,
-			      1 /* minend */, sv, NULL, 0))
+	while (s < strend && --limit)
 	{
+	    PUTBACK;
+	    i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
+	    SPAGAIN;
+	    if (i == 0)
+		break;
 	    TAINT_IF(RX_MATCH_TAINTED(rx));
 	    if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 		m = s;
@@ -4703,7 +4655,6 @@ PP(pp_split)
 		}
 	    }
 	    s = rx->endp[0] + orig;
-	    PUTBACK;
 	}
     }
 
@@ -4729,7 +4680,7 @@ PP(pp_split)
 	    if (TOPs && !make_mortal)
 		sv_2mortal(TOPs);
 	    iters--;
-	    SP--;
+	    *SP-- = &PL_sv_undef;
 	}
     }