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

5 files changed, 22 insertions, 9 deletions

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 11660883c1..7cd198e55d 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 8c947b7f4c..9f9722722f 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 29748ffedf..f4ca5f3d8b 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 d93292b925..d51d3be62b 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 308269eee9..a17c3c62c5 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;