From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 22 Feb 2006 22:30:19 +0000 (+0000)
Subject: Avoid C<study>ing any strings that might change underneath us, such
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4f4e9060b702ac8bd69a560b36e93c3c44a5c97;p=p5sagit%2Fp5-mst-13.2.git

Avoid C<study>ing any strings that might change underneath us, such
as tied scalars and scalars with overloaded stringification.

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

diff --git a/pp.c b/pp.c
index f9f9e7b..d41dd57 100644
--- a/pp.c
+++ b/pp.c
@@ -639,13 +639,22 @@ 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;
diff --git a/t/op/studytied.t b/t/op/studytied.t
index 2a78c8c..d50c964 100644
--- a/t/op/studytied.t
+++ b/t/op/studytied.t
@@ -41,16 +41,10 @@ for my $do_study qw( 0 1 ) {
     is( index( $x, 'f' ), -1,   qq{"next" doesn't contain "f"} );
 
     # Subsequent references to $x are "next", so should match /n/
-    TODO: {
-	local $TODO = $do_study ? 'not yet fixed' : 0;
-	ok( $x =~ /n/,              qq{"next" matches /n/} );
-    }
+    ok( $x =~ /n/,              qq{"next" matches /n/} );
     is( index( $x, 'n' ), 0,    qq{"next" contains "n" at pos 0} );
 
     # The letter "t" is in both, but in different positions
-    TODO: {
-	local $TODO = $do_study ? 'not yet fixed' : 0;
-	ok( $x =~ /t/,              qq{"next" matches /t/} );
-    }
-    is( index( $x, 't' ), 3,    qq{"next" contains "t" at pos 3} );
+    ok( $x =~ /t/,              qq{"next" matches /x/} );
+    is( index( $x, 't' ), 3,    qq{"next" contains "x" at pos 3} );
 }