New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Bad return value from a block with variable localization #8384
Comments
From christian.jaeger@sl.ethz.chHello When putting a do{} block inside an if statement inside a subroutine, This is bad for me since it prevents autogenerated perl code (output Cheers, use strict; __END__ With DEBUG set to 1 this gives: chris@pflanze html > perl -w perl_do_bug.pl chris@pflanze html > perl --version Same result under perl 5.005_03 on linux/ppc. |
From @schwernOn Sat, May 25, 2002 at 07:10:17PM +0200, Christian Jaeger wrote:
Not just if(){}, but it has to be if(CONSTANT){}. Which makes me think use strict; the above... $ bleadperl ~/tmp/bug.plx and then this: $ bleadperl ~/tmp/bug.plx the only difference being that the if condition is variable. This screams Oddly enough, with an explicit "return $rv" it works fine. Bug appears in at least 5.004, 5.005_03, 5.6.0, 5.6.1 and bleadperl. -- |
From [Unknown Contact. See original ticket]At 16:57 Uhr -0400 25.05.2002, Michael G Schwern wrote:
Hmm, the original code that exposed the bug didn't have a constant sub somesub { I can't reproduce it now separatet from the application, like you I Christian. |
From vince@midori.profvince.comCreated by vince@midori.profvince.comHello, I've run into this strange behaviour when playing with trying Looks like some parsing bug, but not that I'm good enough to have Regards, Vincent Pit ################################################################# #!/usr/bin/perl use strict; sub foo { # let's just remove the else sub bar { print foo().' '.foo('baz')."\n"; # that was expected ################################################################# 0 1 ################################################################# 0 1 ################################################################# The name of the localized variable doesn't matter. Perl Info
|
p5p@spam.wizbit.be - Status changed from 'new' to 'stalled' |
From perl@profvince.comThis is the bug that makes sub foo { do { return do { 1; 2 } }; 3 } returns undef. The 1 is here to prevent the return do block to be 1 <;> nextstate(main 3 -e:1) v The problem is that the enter after the pushmark has no context and The patch attached is a way better solution compared to the previous one Vincent. |
From perl@profvince.comperl-rt38809.patch--- op.c 2008-06-17 13:25:08.000000000 +0200
+++ op.c 2008-08-30 17:21:16.000000000 +0200
@@ -7561,13 +7561,19 @@
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling) {
+ if (kid->op_type == OP_NULL && kid->op_flags & OPf_SPECIAL) /* do */
+ list(kid);
+ }
}
return o;
}
--- t/op/do.t 2007-01-08 22:22:52.000000000 +0100
+++ t/op/do.t 2008-08-30 16:32:00.000000000 +0200
@@ -29,7 +29,7 @@
return $ok;
}
-print "1..22\n";
+print "1..23\n";
# Test do &sub and proper @_ handling.
$_[0] = 0;
@@ -92,6 +92,10 @@
push @t, ($u = (do {} . "This should be pushed."));
ok( $#t == 0, "empty do result value" );
+# [perl #38809]
+@a = sub { do { return 38, do { 1; 80, 9 } }; 2 }->();
+ok( join('', @a) eq '38809', "do blocks in return should have list context" );
+
END {
1 while unlink("$$.16", "$$.17", "$$.18");
}
|
The RT System itself - Status changed from 'stalled' to 'open' |
From perl@profvince.com
Corrected patch attached with more tests. |
From perl@profvince.comperl-rt38809-take2.patch--- op.c 2008-06-17 13:25:08.000000000 +0200
+++ op.c 2008-08-31 16:29:34.000000000 +0200
@@ -7561,14 +7561,25 @@
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling)
+ if (kid->op_type == OP_NULL && kid->op_flags & OPf_SPECIAL) {
+ /* This is a do block */
+ assert(cUNOPx(kid)->op_first);
+ assert(cUNOPx(kid)->op_first->op_type == OP_LEAVE);
+ /* Force the use of the caller's context */
+ cUNOPx(kid)->op_first->op_private |= OPpLEAVE_INRETURN;
+ }
}
+
return o;
}
--- op.h 2008-06-08 17:41:31.000000000 +0200
+++ op.h 2008-08-31 15:52:26.000000000 +0200
@@ -158,6 +158,9 @@
/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
+/* Private for OP_LEAVE */
+#define OPpLEAVE_INRETURN 128 /* Use subroutine context */
+
/* Private for OP_AASSIGN */
#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
--- pp_hot.c 2008-06-28 23:11:23.000000000 +0200
+++ pp_hot.c 2008-08-31 16:28:44.000000000 +0200
@@ -1860,9 +1860,13 @@
gimme = OP_GIMME(PL_op, -1);
if (gimme == -1) {
- if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
+ if (cxstack_ix >= 0) {
+ /* If this flag is set, we're just inside a return, so we should
+ * apply the caller's context */
+ gimme = (PL_op->op_private & OPpLEAVE_INRETURN)
+ ? block_gimme()
+ : cxstack[cxstack_ix].blk_gimme;
+ } else
gimme = G_SCALAR;
}
--- t/op/do.t 2007-01-08 22:22:52.000000000 +0100
+++ t/op/do.t 2008-08-31 14:34:36.000000000 +0200
@@ -29,7 +29,7 @@
return $ok;
}
-print "1..22\n";
+print "1..26\n";
# Test do &sub and proper @_ handling.
$_[0] = 0;
@@ -92,6 +92,18 @@
push @t, ($u = (do {} . "This should be pushed."));
ok( $#t == 0, "empty do result value" );
+# [perl #38809]
+@a = (7, 8);
+$x = sub { do { return do { 1; @a } }; 3 }->();
+ok(defined $x && $x == 2, 'return do { } receives caller scalar context');
+@x = sub { do { return do { 1; @a } }; 3 }->();
+ok("@x" eq "7 8", 'return do { } receives caller list context');
+@a = (7, 8, 9);
+$x = sub { do { do { 1; return @a } }; 4 }->();
+ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
+@x = sub { do { do { 1; return @a } }; 4 }->();
+ok("@x" eq "7 8 9", 'do { return } receives caller list context');
+
END {
1 while unlink("$$.16", "$$.17", "$$.18");
}
|
From perl@profvince.comAttached is another patch for 38809. It does essentially two things. return do { 1; do { 2; @a } } This is fixed with this version. Vincent. |
From perl@profvince.comperl-rt38809-take4.patch--- op.c 2008-09-19 23:04:16.000000000 +0200
+++ op.c 2008-09-29 17:09:05.000000000 +0200
@@ -7625,14 +7625,28 @@
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling)
+ if ((kid->op_type == OP_NULL)
+ && (kid->op_flags & OPf_SPECIAL)) {
+ /* This is a do block */
+ OP *op = cUNOPx(kid)->op_first;
+ assert(op && (op->op_type == OP_LEAVE) && (op->op_flags & OPf_KIDS));
+ op = cUNOPx(op)->op_first;
+ assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+ /* Force the use of the caller's context */
+ op->op_flags |= OPf_SPECIAL;
+ }
}
+
return o;
}
--- op.h 2008-09-19 23:04:16.000000000 +0200
+++ op.h 2008-09-29 17:09:05.000000000 +0200
@@ -137,6 +137,7 @@
/* On OP_SMARTMATCH, an implicit smartmatch */
/* On OP_ANONHASH and OP_ANONLIST, create a
reference to the new anon hash or array */
+ /* On OP_ENTER, store caller context */
/* old names; don't use in new code, but don't break them, either */
#define OPf_LIST OPf_WANT_LIST
--- pp_hot.c 2008-09-19 23:04:19.000000000 +0200
+++ pp_hot.c 2008-09-29 17:09:05.000000000 +0200
@@ -1748,9 +1748,13 @@
I32 gimme = OP_GIMME(PL_op, -1);
if (gimme == -1) {
- if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
+ if (cxstack_ix >= 0) {
+ /* If this flag is set, we're just inside a return, so we should
+ * store the caller's context */
+ gimme = (PL_op->op_flags & OPf_SPECIAL)
+ ? block_gimme()
+ : cxstack[cxstack_ix].blk_gimme;
+ } else
gimme = G_SCALAR;
}
@@ -1858,13 +1862,7 @@
POPBLOCK(cx,newpm);
- gimme = OP_GIMME(PL_op, -1);
- if (gimme == -1) {
- if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
- gimme = G_SCALAR;
- }
+ gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
TAINT_NOT;
if (gimme == G_VOID)
--- t/op/do.t 2008-09-19 23:04:20.000000000 +0200
+++ t/op/do.t 2008-09-29 17:09:41.000000000 +0200
@@ -29,7 +29,7 @@
return $ok;
}
-print "1..26\n";
+print "1..32\n";
# Test do &sub and proper @_ handling.
$_[0] = 0;
@@ -104,6 +104,23 @@
$owww = do { 4 if not $zok };
ok( $owww eq '', 'last is if not' );
+# [perl #38809]
+@a = (7, 8);
+$x = sub { do { return do { 1; @a } }; 3 }->();
+ok(defined $x && $x == 2, 'return do { } receives caller scalar context');
+@x = sub { do { return do { 1; @a } }; 3 }->();
+ok("@x" eq "7 8", 'return do { } receives caller list context');
+@a = (7, 8, 9);
+$x = sub { do { do { 1; return @a } }; 4 }->();
+ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
+@x = sub { do { do { 1; return @a } }; 4 }->();
+ok("@x" eq "7 8 9", 'do { return } receives caller list context');
+@a = (7, 8, 9, 10);
+$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
+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');
+
END {
1 while unlink("$$.16", "$$.17", "$$.18");
}
|
From @smpetersOn Mon Sep 29 10:59:21 2008, perl@profvince.com wrote:
Thanks! I've applied this patch as change #34907. Steve Peters |
@smpeters - Status changed from 'open' to 'resolved' |
From @cpansproutThis was fixed in perl 5.12.0 by change 34907/e91684bfbb744fa7e8f. |
@cpansprout - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#38809 (status was 'resolved')
Searchable as RT38809$
The text was updated successfully, but these errors were encountered: