X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=d63f03980906503491982cb9fc607a0b69f214e3;hb=c696a6a43b0b5a16f820f8a91db4e187fc9ac45b;hp=ee32dbacba8c0cf36bf9adc3b3d05be91641af99;hpb=a2b7337b02f836aab62591af0d79675c5d157499;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp.c b/pp.c
index ee32dba..d63f039 100644
--- a/pp.c
+++ b/pp.c
@@ -234,6 +234,8 @@ PP(pp_rv2sv)
 	case SVt_PVAV:
 	case SVt_PVHV:
 	case SVt_PVCV:
+	case SVt_PVFM:
+	case SVt_PVIO:
 	    DIE(aTHX_ "Not a SCALAR reference");
 	}
     }
@@ -637,14 +639,23 @@ PP(pp_study)
 	if (SvSCREAM(sv))
 	    RETPUSHYES;
     }
-    else {
-	if (PL_lastscream) {
-	    SvSCREAM_off(PL_lastscream);
-	    SvREFCNT_dec(PL_lastscream);
-	}
-	PL_lastscream = SvREFCNT_inc(sv);
+    s = (unsigned char*)(SvPV(sv, len));
+    pos = len;
+    if (pos <= 0 || !SvPOK(sv)) {
+	/* No point in studying a zero length string, and not safe to study
+	   anything that doesn't appear to be a simple scalar (and hence might
+	   change between now and when the regexp engine runs without our set
+	   magic ever running) such as a reference to an object with overloaded
+	   stringification.  */
+	RETPUSHNO;
     }
 
+    if (PL_lastscream) {
+	SvSCREAM_off(PL_lastscream);
+	SvREFCNT_dec(PL_lastscream);
+    }
+    PL_lastscream = SvREFCNT_inc(sv);
+
     s = (unsigned char*)(SvPV(sv, len));
     pos = len;
     if (pos <= 0)
@@ -771,7 +782,7 @@ PP(pp_undef)
 	if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
 	    Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 		 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
-	/* FALL THROUGH */
+	/* FALLTHROUGH */
     case SVt_PVFM:
 	{
 	    /* let user-undef'd sub keep its identity */
@@ -1046,6 +1057,7 @@ PP(pp_multiply)
 	    bhigh = blow >> (4 * sizeof (UV));
 	    blow &= botmask;
 	    if (ahigh && bhigh) {
+		/*EMPTY*/;
 		/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
 		   which is overflow. Drop to NVs below.  */
 	    } else if (!ahigh && !bhigh) {
@@ -2205,50 +2217,32 @@ PP(pp_bit_and)
     }
 }
 
-PP(pp_bit_xor)
-{
-    dVAR; dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
-    {
-      dPOPTOPssrl;
-      SvGETMAGIC(left);
-      SvGETMAGIC(right);
-      if (SvNIOKp(left) || SvNIOKp(right)) {
-	if (PL_op->op_private & HINT_INTEGER) {
-	  const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
-	  SETi(i);
-	}
-	else {
-	  const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
-	  SETu(u);
-	}
-      }
-      else {
-	do_vop(PL_op->op_type, TARG, left, right);
-	SETTARG;
-      }
-      RETURN;
-    }
-}
-
 PP(pp_bit_or)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+    dVAR; dSP; dATARGET;
+    const int op_type = PL_op->op_type;
+
+    tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
     {
       dPOPTOPssrl;
       SvGETMAGIC(left);
       SvGETMAGIC(right);
       if (SvNIOKp(left) || SvNIOKp(right)) {
 	if (PL_op->op_private & HINT_INTEGER) {
-	  const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
-	  SETi(i);
+	  const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
+	  const IV r = SvIV_nomg(right);
+	  const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+	  SETi(result);
 	}
 	else {
-	  const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
-	  SETu(u);
+	  const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
+	  const UV r = SvUV_nomg(right);
+	  const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+	  SETu(result);
 	}
       }
       else {
-	do_vop(PL_op->op_type, TARG, left, right);
+	do_vop(op_type, TARG, left, right);
 	SETTARG;
       }
       RETURN;
@@ -2441,12 +2435,19 @@ PP(pp_i_multiply)
 
 PP(pp_i_divide)
 {
+    IV num;
     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
     {
       dPOPiv;
       if (value == 0)
-	DIE(aTHX_ "Illegal division by zero");
-      value = POPi / value;
+	  DIE(aTHX_ "Illegal division by zero");
+      num = POPi;
+
+      /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
+      if (value == -1)
+          value = - num;
+      else
+          value = num / value;
       PUSHi( value );
       RETURN;
     }
@@ -2461,7 +2462,11 @@ PP(pp_i_modulo_0)
 	  dPOPTOPiirl;
 	  if (!right)
 	       DIE(aTHX_ "Illegal modulus zero");
-	  SETi( left % right );
+	  /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+	  if (right == -1)
+	      SETi( 0 );
+	  else
+	      SETi( left % right );
 	  RETURN;
      }
 }
@@ -2478,7 +2483,11 @@ PP(pp_i_modulo_1)
 	  dPOPTOPiirl;
 	  if (!right)
 	       DIE(aTHX_ "Illegal modulus zero");
-	  SETi( left % PERL_ABS(right) );
+	  /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+	  if (right == -1)
+	      SETi( 0 );
+	  else
+	      SETi( left % PERL_ABS(right) );
 	  RETURN;
      }
 }
@@ -2519,7 +2528,11 @@ PP(pp_i_modulo)
 	       }
 	  }
 #endif
-	  SETi( left % right );
+	  /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+	  if (right == -1)
+	      SETi( 0 );
+	  else
+	      SETi( left % right );
 	  RETURN;
      }
 }
@@ -2643,20 +2656,43 @@ PP(pp_atan2)
 
 PP(pp_sin)
 {
-    dVAR; dSP; dTARGET; tryAMAGICun(sin);
-    {
-      const NV value = POPn;
-      XPUSHn(Perl_sin(value));
-      RETURN;
+    dVAR; dSP; dTARGET;
+    int amg_type = sin_amg;
+    const char *neg_report = NULL;
+    NV (*func)(NV) = Perl_sin;
+    const int op_type = PL_op->op_type;
+
+    switch (op_type) {
+    case OP_COS:
+	amg_type = cos_amg;
+	func = Perl_cos;
+	break;
+    case OP_EXP:
+	amg_type = exp_amg;
+	func = Perl_exp;
+	break;
+    case OP_LOG:
+	amg_type = log_amg;
+	func = Perl_log;
+	neg_report = "log";
+	break;
+    case OP_SQRT:
+	amg_type = sqrt_amg;
+	func = Perl_sqrt;
+	neg_report = "sqrt";
+	break;
     }
-}
 
-PP(pp_cos)
-{
-    dVAR; dSP; dTARGET; tryAMAGICun(cos);
+    tryAMAGICun_var(amg_type);
     {
       const NV value = POPn;
-      XPUSHn(Perl_cos(value));
+      if (neg_report) {
+	  if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
+	      SET_NUMERIC_STANDARD();
+	      DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
+	  }
+      }
+      XPUSHn(func(value));
       RETURN;
     }
 }
@@ -2705,46 +2741,6 @@ PP(pp_srand)
     RETPUSHYES;
 }
 
-PP(pp_exp)
-{
-    dVAR; dSP; dTARGET; tryAMAGICun(exp);
-    {
-      NV value;
-      value = POPn;
-      value = Perl_exp(value);
-      XPUSHn(value);
-      RETURN;
-    }
-}
-
-PP(pp_log)
-{
-    dVAR; dSP; dTARGET; tryAMAGICun(log);
-    {
-      const NV value = POPn;
-      if (value <= 0.0) {
-	SET_NUMERIC_STANDARD();
-	DIE(aTHX_ "Can't take log of %"NVgf, value);
-      }
-      XPUSHn(Perl_log(value));
-      RETURN;
-    }
-}
-
-PP(pp_sqrt)
-{
-    dVAR; dSP; dTARGET; tryAMAGICun(sqrt);
-    {
-      const NV value = POPn;
-      if (value < 0.0) {
-	SET_NUMERIC_STANDARD();
-	DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
-      }
-      XPUSHn(Perl_sqrt(value));
-      RETURN;
-    }
-}
-
 PP(pp_int)
 {
     dVAR; dSP; dTARGET; tryAMAGICun(int);
@@ -2821,37 +2817,6 @@ PP(pp_abs)
     RETURN;
 }
 
-
-PP(pp_hex)
-{
-    dVAR; dSP; dTARGET;
-    const char *tmps;
-    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
-    STRLEN len;
-    NV result_nv;
-    UV result_uv;
-    SV* const sv = POPs;
-
-    tmps = (SvPV_const(sv, len));
-    if (DO_UTF8(sv)) {
-	 /* If Unicode, try to downgrade
-	  * If not possible, croak. */
-	 SV* const tsv = sv_2mortal(newSVsv(sv));
-	
-	 SvUTF8_on(tsv);
-	 sv_utf8_downgrade(tsv, FALSE);
-	 tmps = SvPV_const(tsv, len);
-    }
-    result_uv = grok_hex (tmps, &len, &flags, &result_nv);
-    if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
-        XPUSHn(result_nv);
-    }
-    else {
-        XPUSHu(result_uv);
-    }
-    RETURN;
-}
-
 PP(pp_oct)
 {
     dVAR; dSP; dTARGET;
@@ -2872,12 +2837,17 @@ PP(pp_oct)
 	 sv_utf8_downgrade(tsv, FALSE);
 	 tmps = SvPV_const(tsv, len);
     }
+    if (PL_op->op_type == OP_HEX)
+	goto hex;
+
     while (*tmps && len && isSPACE(*tmps))
         tmps++, len--;
     if (*tmps == '0')
         tmps++, len--;
-    if (*tmps == 'x')
+    if (*tmps == 'x') {
+    hex:
         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
+    }
     else if (*tmps == 'b')
         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
     else
@@ -3111,19 +3081,22 @@ PP(pp_index)
     SV *big;
     SV *little;
     SV *temp = NULL;
+    STRLEN biglen;
+    STRLEN llen = 0;
     I32 offset;
     I32 retval;
     const char *tmps;
     const char *tmps2;
-    STRLEN biglen;
     const I32 arybase = PL_curcop->cop_arybase;
     bool big_utf8;
     bool little_utf8;
+    const bool is_index = PL_op->op_type == OP_INDEX;
 
-    if (MAXARG < 3)
-	offset = 0;
-    else
+    if (MAXARG >= 3) {
+	/* arybase is in characters, like offset, so combine prior to the
+	   UTF-8 to bytes calculation.  */
 	offset = POPi - arybase;
+    }
     little = POPs;
     big = POPs;
     big_utf8 = DO_UTF8(big);
@@ -3169,97 +3142,35 @@ PP(pp_index)
 	    }
 	}
     }
-    if (big_utf8 && offset > 0)
-	sv_pos_u2b(big, &offset, 0);
+    /* Don't actually need the NULL initialisation, but it keeps gcc quiet.  */
+    tmps2 = is_index ? NULL : SvPV_const(little, llen);
     tmps = SvPV_const(big, biglen);
-    if (offset < 0)
-	offset = 0;
-    else if (offset > (I32)biglen)
-	offset = biglen;
-    if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
-      (unsigned char*)tmps + biglen, little, 0)))
-	retval = -1;
-    else {
-	retval = tmps2 - tmps;
-	if (big_utf8)
-	    sv_pos_b2u(big, &retval);
-    }
-    if (temp)
-	SvREFCNT_dec(temp);
- fail:
-    PUSHi(retval + arybase);
-    RETURN;
-}
-
-PP(pp_rindex)
-{
-    dVAR; dSP; dTARGET;
-    SV *big;
-    SV *little;
-    SV *temp = NULL;
-    STRLEN blen;
-    STRLEN llen;
-    I32 offset;
-    I32 retval;
-    const char *tmps;
-    const char *tmps2;
-    const I32 arybase = PL_curcop->cop_arybase;
-    int big_utf8;
-    int little_utf8;
-
-    if (MAXARG >= 3)
-	offset = POPi;
-    little = POPs;
-    big = POPs;
-    big_utf8 = DO_UTF8(big);
-    little_utf8 = DO_UTF8(little);
-    if (big_utf8 ^ little_utf8) {
-	/* One needs to be upgraded.  */
-	SV * const bytes = little_utf8 ? big : little;
-	STRLEN len;
-	const char *p = SvPV_const(bytes, len);
-
-	temp = newSVpvn(p, len);
-
-	if (PL_encoding) {
-	    sv_recode_to_utf8(temp, PL_encoding);
-	} else {
-	    sv_utf8_upgrade(temp);
-	}
-	if (little_utf8) {
-	    big = temp;
-	    big_utf8 = TRUE;
-	} else {
-	    little = temp;
-	}
-    }
-    tmps2 = SvPV_const(little, llen);
-    tmps = SvPV_const(big, blen);
 
     if (MAXARG < 3)
-	offset = blen;
+	offset = is_index ? 0 : biglen;
     else {
-	/* arybase is in characters, like offset, so combine prior to the
-	   UTF-8 to bytes calculation.  */
-	offset -= arybase;
-	if (offset > 0 && big_utf8)
+	if (big_utf8 && offset > 0)
 	    sv_pos_u2b(big, &offset, 0);
-	/* llen is in bytes.  */
 	offset += llen;
     }
     if (offset < 0)
 	offset = 0;
-    else if (offset > (I32)blen)
-	offset = blen;
-    if (!(tmps2 = rninstr(tmps,  tmps  + offset,
-			  tmps2, tmps2 + llen)))
+    else if (offset > (I32)biglen)
+	offset = biglen;
+    if (!(tmps2 = is_index
+	  ? fbm_instr((unsigned char*)tmps + offset,
+		      (unsigned char*)tmps + biglen, little, 0)
+	  : rninstr(tmps,  tmps  + offset,
+		    tmps2, tmps2 + llen)))
 	retval = -1;
-    else
+    else {
 	retval = tmps2 - tmps;
-    if (retval > 0 && big_utf8)
-	sv_pos_b2u(big, &retval);
+	if (retval > 0 && big_utf8)
+	    sv_pos_b2u(big, &retval);
+    }
     if (temp)
 	SvREFCNT_dec(temp);
+ fail:
     PUSHi(retval + arybase);
     RETURN;
 }
@@ -3590,6 +3501,7 @@ PP(pp_lc)
 
 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
 		if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
+		    /*EMPTY*/
 		     /*
 		      * Now if the sigma is NOT followed by
 		      * /$ignorable_sequence$cased_letter/;
@@ -4279,27 +4191,14 @@ PP(pp_push)
     RETURN;
 }
 
-PP(pp_pop)
-{
-    dVAR;
-    dSP;
-    AV * const av = (AV*)POPs;
-    SV * const sv = av_pop(av);
-    if (AvREAL(av))
-	(void)sv_2mortal(sv);
-    PUSHs(sv);
-    RETURN;
-}
-
 PP(pp_shift)
 {
     dVAR;
     dSP;
     AV * const av = (AV*)POPs;
-    SV * const sv = av_shift(av);
+    SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
     EXTEND(SP, 1);
-    if (!sv)
-	RETPUSHUNDEF;
+    assert (sv);
     if (AvREAL(av))
 	(void)sv_2mortal(sv);
     PUSHs(sv);
@@ -4364,7 +4263,8 @@ PP(pp_reverse)
 	    sv_setsv(TARG, (SP > MARK)
 		    ? *SP
 		    : (padoff_du = find_rundefsvoffset(),
-			(padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+			(padoff_du == NOT_IN_PAD
+			 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
 			? DEFSV : PAD_SVl(padoff_du)));
 	up = SvPV_force(TARG, len);
 	if (len > 1) {