From: Hugo van der Sanden <hv@crypt.org>
Date: Sun, 3 Nov 2002 16:41:24 +0000 (+0000)
Subject: Re: [perl #17605] strange behaviour (difference between perl 5.6 and perl 5.8.0)... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e9f19e3c03f1d62dc32ee20c3f9cd088c9618f14;p=p5sagit%2Fp5-mst-13.2.git

Re: [perl #17605] strange behaviour (difference between perl 5.6 and perl 5.8.0) in the regexp
Message-Id: <200211031641.gA3GfOm08609@crypt.compulink.co.uk>

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

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 1166088..7cd198e 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -532,7 +532,7 @@ sub tree {
 
 # Why these are different for MacOS?  Does it matter?
 my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
-my $seq_mnum = $^O eq 'MacOS' ? 100 : 84;
+my $seq_mnum = $^O eq 'MacOS' ? 102 : 86;
 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
 $seq_base = svref_2object(eval 'sub{}')->START->seq + $seq_mnum;
 
diff --git a/op.c b/op.c
index 8c947b7..9f97227 100644
--- a/op.c
+++ b/op.c
@@ -1756,9 +1756,14 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
 {
     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
     line_t copline = PL_copline;
-    /* there should be a nextstate in every block */
-    OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
-    PL_copline = copline;  /* XXX newSTATEOP may reset PL_copline */
+    OP* retval = scalarseq(seq);
+    if (!seq) {
+	/* scalarseq() gave us an OP_STUB */
+	retval->op_flags |= OPf_PARENS;
+	/* there should be a nextstate in every block */
+	retval = newSTATEOP(0, Nullch, retval);
+	PL_copline = copline;  /* XXX newSTATEOP may reset PL_copline */
+    }
     LEAVE_SCOPE(floor);
     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
     if (needblockscope)
diff --git a/pp_hot.c b/pp_hot.c
index 29748ff..f4ca5f3 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2317,8 +2317,9 @@ PP(pp_leavesublv)
 		    PL_curpm = newpm;
 		    LEAVE;
 		    LEAVESUB(sv);
-		    DIE(aTHX_ "Can't return a %s from lvalue subroutine",
-			SvREADONLY(TOPs) ? "readonly value" : "temporary");
+		    DIE(aTHX_ "Can't return %s from lvalue subroutine",
+			SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
+			: "a readonly value" : "a temporary");
 		}
 		else {                  /* Can be a localized value
 					 * subject to deletion. */
diff --git a/t/op/closure.t b/t/op/closure.t
index d93292b..d51d3be 100755
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -13,7 +13,7 @@ BEGIN {
 
 use Config;
 
-print "1..173\n";
+print "1..174\n";
 
 my $test = 1;
 sub test (&) {
@@ -527,3 +527,10 @@ sub {
 }->();
 test {1};
 
+# [perl #17605] found that an empty block called in scalar context
+# can lead to stack corruption
+{
+    my $x = "foooobar";
+    $x =~ s/o//eg;
+    test { $x eq 'fbar' }
+}
diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 308269e..a17c3c6 100755
--- a/t/op/sub_lval.t
+++ b/t/op/sub_lval.t
@@ -251,7 +251,7 @@ eval <<'EOE' or $_ = $@;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Empty array returned from lvalue subroutine in scalar context/;
+  unless /Can't return undef from lvalue subroutine/;
 print "ok 31\n";
 
 sub lv10 : lvalue {}
@@ -274,7 +274,7 @@ eval <<'EOE' or $_ = $@;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a readonly value from lvalue subroutine/;
+  unless /Can't return undef from lvalue subroutine/;
 print "ok 33\n";
 
 $_ = undef;