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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;