From: Vincent Pit Date: Tue, 4 Aug 2009 14:13:28 +0000 (+0200) Subject: Promote blocks resulting from constant folding to first-class do { } blocks X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dd3e51dc8ab0e4da0f911ca693aa0ceaaf79318a;p=p5sagit%2Fp5-mst-13.2.git Promote blocks resulting from constant folding to first-class do { } blocks This solves [perl #68108]: no retval from sub { if(1){ ... } } --- diff --git a/op.c b/op.c index d1ed080..8574f52 100644 --- a/op.c +++ b/op.c @@ -4552,6 +4552,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return newop; } op_free(first); + if (other->op_type == OP_LEAVE) + other = newUNOP(OP_NULL, OPf_SPECIAL, other); return other; } else { diff --git a/t/op/do.t b/t/op/do.t index 43ce3e8..dd378cf 100644 --- a/t/op/do.t +++ b/t/op/do.t @@ -29,7 +29,7 @@ sub ok { return $ok; } -print "1..38\n"; +print "1..44\n"; # Test do &sub and proper @_ handling. $_[0] = 0; @@ -140,6 +140,26 @@ ok(defined $x && $x == 4, 'return do { do { ; } } receives caller scalar context @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); ok("@x" eq "7 8 9 10", 'return do { do { ; } } receives caller list context'); +# Do blocks created by constant folding +# [perl #68108] +$x = sub { if (1) { 20 } }->(); +ok($x == 20, 'if (1) { $x } receives caller scalar context'); + +@a = (21 .. 23); +$x = sub { if (1) { @a } }->(); +ok($x == 3, 'if (1) { @a } receives caller scalar context'); +@x = sub { if (1) { @a } }->(); +ok("@x" eq "21 22 23", 'if (1) { @a } receives caller list context'); + +$x = sub { if (1) { 0; 20 } }->(); +ok($x == 20, 'if (1) { ...; $x } receives caller scalar context'); + +@a = (24 .. 27); +$x = sub { if (1) { 0; @a } }->(); +ok($x == 4, 'if (1) { ...; @a } receives caller scalar context'); +@x = sub { if (1) { 0; @a } }->(); +ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); + END { 1 while unlink("$$.16", "$$.17", "$$.18"); }