From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 27 Dec 2007 13:46:46 +0000 (+0000)
Subject: Regexps are now orange.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3ce3ed558a83da8e2c458cdff55957484ff161a7;p=p5sagit%2Fp5-mst-13.2.git

Regexps are now orange.
(Correct a comparison of $] with 5.011 in B.pm)

p4raw-id: //depot/perl@32740
---

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 9dc85bb..7c498e4 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -34,10 +34,11 @@ use strict;
 @B::IV::ISA = 'B::SV';
 @B::NV::ISA = 'B::SV';
 # RV is eliminated with 5.11.0, but effectively is a specialisation of IV now.
-@B::RV::ISA = $] > 5.011 ? 'B::IV' : 'B::SV';
+@B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV';
 @B::PVIV::ISA = qw(B::PV B::IV);
 @B::PVNV::ISA = qw(B::PVIV B::NV);
 @B::PVMG::ISA = 'B::PVNV';
+@B::ORANGE::ISA = 'B::PVMG' if $] >= 5.011;
 # Change in the inheritance hierarchy post 5.9.0
 @B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
 # BM is eliminated post 5.9.5, but effectively is a specialisation of GV now.
diff --git a/ext/Devel/Peek/t/Peek.t b/ext/Devel/Peek/t/Peek.t
index 76118d1..65937e7 100644
--- a/ext/Devel/Peek/t/Peek.t
+++ b/ext/Devel/Peek/t/Peek.t
@@ -275,6 +275,27 @@ do_test(14,
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
     OUTSIDE = $ADDR \\(MAIN\\)');
 
+if ($] >= 5.011) {
+do_test(15,
+        qr(tic),
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = ORANGE\\($ADDR\\) at $ADDR
+    REFCNT = 1
+    FLAGS = \\(OBJECT,SMG\\)
+    IV = 0
+    NV = 0
+    PV = 0
+    MAGIC = $ADDR
+      MG_VIRTUAL = $ADDR
+      MG_TYPE = PERL_MAGIC_qr\(r\)
+      MG_OBJ = $ADDR
+        PAT = "\(\?-xism:tic\)"
+        REFCNT = 2
+    STASH = $ADDR\\t"Regexp"');
+} else {
 do_test(15,
         qr(tic),
 'SV = $RV\\($ADDR\\) at $ADDR
@@ -294,6 +315,7 @@ do_test(15,
         PAT = "\(\?-xism:tic\)"
         REFCNT = 2
     STASH = $ADDR\\t"Regexp"');
+}
 
 do_test(16,
         (bless {}, "Tac"),
diff --git a/lib/overload.t b/lib/overload.t
index 94cd296..fbaa4fd 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -1125,7 +1125,7 @@ like ($@, qr/zap/);
     like(overload::StrVal(sub{1}),    qr/^CODE\(0x[0-9a-f]+\)$/);
     like(overload::StrVal(\*GLOB),    qr/^GLOB\(0x[0-9a-f]+\)$/);
     like(overload::StrVal(\$o),       qr/^REF\(0x[0-9a-f]+\)$/);
-    like(overload::StrVal(qr/a/),     qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
+    like(overload::StrVal(qr/a/),     qr/^Regexp=ORANGE\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($o),        qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($of),       qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($no),       qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
diff --git a/pp_hot.c b/pp_hot.c
index 764d5be..57540ca 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1197,6 +1197,7 @@ PP(pp_qr)
     SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
     if (rx->extflags & RXf_TAINTED)
         SvTAINTED_on(rv);
+    sv_upgrade(sv, SVt_ORANGE);
     sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
     XPUSHs(rv);
     RETURN;
diff --git a/regexec.c b/regexec.c
index a02a0c0..634844b 100644
--- a/regexec.c
+++ b/regexec.c
@@ -3730,9 +3730,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 			re = CALLREGCOMP(ret, pm_flags);
 			if (!(SvFLAGS(ret)
 			      & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
-				| SVs_GMG)))
+				 | SVs_GMG))) {
+			    SvUPGRADE(ret, SVt_ORANGE);
 			    sv_magic(ret,(SV*)ReREFCNT_inc(re),
 					PERL_MAGIC_qr,0,0);
+			}
 			PL_regsize = osize;
 		    }
 		}
diff --git a/sv.c b/sv.c
index 17cc281..21ba31b 100644
--- a/sv.c
+++ b/sv.c
@@ -916,8 +916,9 @@ static const struct body_details bodies_by_type[] = {
     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 
-    /* There are plans for this  */
-    { 0, 0, 0, SVt_ORANGE, FALSE, NONV, NOARENA, 0 },
+    /* 28 */
+    { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_ORANGE, FALSE, HADNV,
+      HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 
     /* 48 */
     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
@@ -1309,6 +1310,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
+    case SVt_ORANGE:
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PV:
@@ -2696,7 +2698,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 		if (!referent) {
 		    len = 7;
 		    retval = buffer = savepvn("NULLREF", len);
-		} else if (SvTYPE(referent) == SVt_PVMG
+		} else if (SvTYPE(referent) == SVt_ORANGE
 			   && ((SvFLAGS(referent) &
 				(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
 			       == (SVs_OBJECT|SVs_SMG))
@@ -7768,6 +7770,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob)
 	case SVt_PVFM:		return "FORMAT";
 	case SVt_PVIO:		return "IO";
 	case SVt_BIND:		return "BIND";
+	case SVt_ORANGE:	return "ORANGE";
 	default:		return "UNKNOWN";
 	}
     }
diff --git a/util.c b/util.c
index 3294dba..668ddc4 100644
--- a/util.c
+++ b/util.c
@@ -5921,7 +5921,7 @@ Perl_get_re_arg(pTHX_ SV *sv) {
             mg_get(sv);
         if (SvROK(sv) &&
             (tmpsv = (SV*)SvRV(sv)) &&            /* assign deliberate */
-            SvTYPE(tmpsv) == SVt_PVMG &&
+            SvTYPE(tmpsv) == SVt_ORANGE &&
             (mg = mg_find(tmpsv, PERL_MAGIC_qr))) /* assign deliberate */
         {
             return (REGEXP *)mg->mg_obj;