Re: [perl #17605] strange behaviour (difference between perl 5.6 and perl 5.8.0)...

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