From: Nicholas Clark <nick@ccl4.org>
Date: Tue, 9 Feb 2010 16:11:34 +0000 (-0800)
Subject: Fix for non-regexps being upgraded to SVt_REGEXP
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9ad13acb338e137b9560a8b578e1f7c983706be;p=p5sagit%2Fp5-mst-13.2.git

Fix for non-regexps being upgraded to SVt_REGEXP

$ ./perl -lwe '$a = ${qr//}; $a = 2; print re::is_regexp(\$a)'
1

It is possible for arbitrary SVs (eg PAD entries) to be upgraded to
SVt_REGEXP.  (This is new with first class regexps)

Whilst the example above does not SEGV, it will be possible to write
code that will cause SEGVs (or worse) at the point when the scalar is freed,
because the code in sv_clear() assumes that all scalars of type
SVt_REGEXP *are* regexps, and passes them to pregfree2(), which assumes that
pointers within are valid.
---

diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index fc26157..3d282d3 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -326,7 +326,7 @@ do_test(15,
   RV = $ADDR
   SV = REGEXP\\($ADDR\\) at $ADDR
     REFCNT = 1
-    FLAGS = \\(OBJECT,POK,pPOK\\)
+    FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
     IV = 0
     PV = $ADDR "\\(\\?-xism:tic\\)"
     CUR = 12
diff --git a/regcomp.c b/regcomp.c
index 10f97b9..ecea32d 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -9457,6 +9457,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
 	   sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
     SvLEN_set(ret_x, 0);
+    SvSTASH_set(ret_x, NULL);
     Newx(ret->offs, npar, regexp_paren_pair);
     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
     if (r->substrs) {
diff --git a/sv.c b/sv.c
index 3b16d7d..4ab41f6 100644
--- a/sv.c
+++ b/sv.c
@@ -1372,6 +1372,10 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
 	break;
 
 
+    case SVt_REGEXP:
+	/* This ensures that SvTHINKFIRST(sv) is true, and hence that
+	   sv_force_normal_flags(sv) is called.  */
+	SvFAKE_on(sv);
     case SVt_PVIV:
 	/* XXX Is this still needed?  Was it ever needed?   Surely as there is
 	   no route from NV to PVIV, NOK can never be true  */
@@ -1382,7 +1386,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
-    case SVt_REGEXP:
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PV:
@@ -4615,6 +4618,45 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
 	sv_unref_flags(sv, flags);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
 	sv_unglob(sv);
+    else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+	/* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
+	   to sv_unglob. We only need it here, so inline it.  */
+	const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+	SV *const temp = newSV_type(new_type);
+	void *const temp_p = SvANY(sv);
+
+	if (new_type == SVt_PVMG) {
+	    SvMAGIC_set(temp, SvMAGIC(sv));
+	    SvMAGIC_set(sv, NULL);
+	    SvSTASH_set(temp, SvSTASH(sv));
+	    SvSTASH_set(sv, NULL);
+	}
+	SvCUR_set(temp, SvCUR(sv));
+	/* Remember that SvPVX is in the head, not the body. */
+	if (SvLEN(temp)) {
+	    SvLEN_set(temp, SvLEN(sv));
+	    /* This signals "buffer is owned by someone else" in sv_clear,
+	       which is the least effort way to stop it freeing the buffer.
+	    */
+	    SvLEN_set(sv, SvLEN(sv)+1);
+	} else {
+	    /* Their buffer is already owned by someone else. */
+	    SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
+	    SvLEN_set(temp, SvCUR(sv)+1);
+	}
+
+	/* Now swap the rest of the bodies. */
+
+	SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
+	SvFLAGS(sv) |= new_type;
+	SvANY(sv) = SvANY(temp);
+
+	SvFLAGS(temp) &= ~(SVTYPEMASK);
+	SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
+	SvANY(temp) = temp_p;
+
+	SvREFCNT_dec(temp);
+    }
 }
 
 /*
diff --git a/t/op/qr.t b/t/op/qr.t
index acabd28..13438de 100644
--- a/t/op/qr.t
+++ b/t/op/qr.t
@@ -4,7 +4,7 @@ use strict;
 
 require './test.pl';
 
-plan(tests => 12);
+plan(tests => 18);
 
 sub r {
     return qr/Good/;
@@ -37,5 +37,22 @@ isnt($c + 0, $d + 0, 'Not the same object');
 $$d = 'Bad';
 
 like("$c", qr/Good/);
-like("$d", qr/Bad/);
-like("$d1", qr/Bad/);
+is($$d, 'Bad');
+is($$d1, 'Bad');
+
+# Assignment to an implicitly blessed Regexp object retains the class
+# (No different from direct value assignment to any other blessed SV
+
+isa_ok($d, 'Regexp');
+like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/);
+
+# As does an explicitly blessed Regexp object.
+
+my $e = bless qr/Faux Pie/, 'Stew';
+
+isa_ok($e, 'Stew');
+$$e = 'Fake!';
+
+is($$e, 'Fake!');
+isa_ok($e, 'Stew');
+like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/);