Fix context propagation below return()
[perl.git] / t / op / do.t
1 #!./perl -w
2
3 require './test.pl';
4 use strict;
5 no warnings 'void';
6
7 sub foo1
8 {
9     ok($_[0], 'in foo1');
10     'value';
11 }
12
13 sub foo2
14 {
15     shift;
16     ok($_[0], 'in foo2');
17     my $x = 'value';
18     $x;
19 }
20
21 my $result;
22 $_[0] = 0;
23 {
24     no warnings 'deprecated';
25     $result = do foo1(1);
26 }
27
28 is($result, 'value', 'do &sub and proper @_ handling');
29 cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling');
30
31 $_[0] = 0;
32 {
33     no warnings 'deprecated';
34     $result = do foo2(0,1,0);
35 }
36 is($result, 'value', 'do &sub and proper @_ handling');
37 cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling');
38
39 my $called;
40 $result = do{ ++$called; 'value';};
41 is($called, 1, 'do block called');
42 is($result, 'value', 'do block returns correct value');
43
44 my @blathered;
45 sub blather {
46     push @blathered, $_ foreach @_;
47 }
48
49 {
50     no warnings 'deprecated';
51     do blather("ayep","sho nuff");
52     is("@blathered", "ayep sho nuff", 'blathered called with list');
53 }
54 @blathered = ();
55
56 my @x = ("jeepers", "okydoke");
57 my @y = ("uhhuh", "yeppers");
58 {
59     no warnings 'deprecated';
60     do blather(@x,"noofie",@y);
61     is("@blathered", "@x noofie @y", 'blathered called with arrays too');
62 }
63
64 unshift @INC, '.';
65
66 my $file16 = tempfile();
67 if (open my $do, '>', $file16) {
68     print $do "isnt(wantarray, undef, 'do in scalar context');\n";
69     print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n";
70     close $do or die "Could not close: $!";
71 }
72
73 my $a = do $file16; die $@ if $@;
74
75 my $file17 = tempfile();
76 if (open my $do, '>', $file17) {
77     print $do "isnt(wantarray, undef, 'do in list context');\n";
78     print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n";
79     close $do or die "Could not close: $!";
80 }
81
82 my @a = do $file17; die $@ if $@;
83
84 my $file18 = tempfile();
85 if (open my $do, '>', $file18) {
86     print $do "is(wantarray, undef, 'do in void context');\n";
87     close $do or die "Could not close: $!";
88 }
89
90 do $file18; die $@ if $@;
91
92 # bug ID 20010920.007
93 eval qq{ do qq(a file that does not exist); };
94 is($@, '', "do on a non-existing file, first try");
95
96 eval qq{ do uc qq(a file that does not exist); };
97 is($@, '', "do on a non-existing file, second try");
98
99 # 6 must be interpreted as a file name here
100 $! = 0;
101 my $do6 = do 6;
102 my $errno = $1;
103 is($do6, undef, 'do 6 must be interpreted as a filename');
104 isnt($!, 0, 'and should set $!');
105
106 # [perl #19545]
107 my ($u, @t);
108 {
109     no warnings 'uninitialized';
110     push @t, ($u = (do {} . "This should be pushed."));
111 }
112 is($#t, 0, "empty do result value" );
113
114 my $zok = '';
115 my $owww = do { 1 if $zok };
116 is($owww, '', 'last is unless');
117 $owww = do { 2 unless not $zok };
118 is($owww, 1, 'last is if not');
119
120 $zok = 'swish';
121 $owww = do { 3 unless $zok };
122 is($owww, 'swish', 'last is unless');
123 $owww = do { 4 if not $zok };
124 is($owww, '', 'last is if not');
125
126 # [perl #38809]
127 @a = (7);
128 my $x = sub { do { return do { @a } }; 2 }->();
129 is($x, 1, 'return do { } receives caller scalar context');
130 @x = sub { do { return do { @a } }; 2 }->();
131 is("@x", "7", 'return do { } receives caller list context');
132
133 @a = (7, 8);
134 $x = sub { do { return do { 1; @a } }; 3 }->();
135 is($x, 2, 'return do { ; } receives caller scalar context');
136 @x = sub { do { return do { 1; @a } }; 3 }->();
137 is("@x", "7 8", 'return do { ; } receives caller list context');
138
139 my @b = (11 .. 15);
140 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
141 is($x, 5, 'return do { ; , } receives caller scalar context');
142 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
143 is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context');
144
145 $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
146 is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
147 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
148 is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context');
149
150 @a = (7, 8, 9);
151 $x = sub { do { do { 1; return @a } }; 4 }->();
152 is($x, 3, 'do { return } receives caller scalar context');
153 @x = sub { do { do { 1; return @a } }; 4 }->();
154 is("@x", "7 8 9", 'do { return } receives caller list context');
155
156 @a = (7, 8, 9, 10);
157 $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
158 is($x, 4, 'return do { do { ; } } receives caller scalar context');
159 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
160 is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
161
162 # More tests about context propagation below return()
163 @a = (11, 12);
164 @b = (21, 22, 23);
165
166 my $test_code = sub {
167     my ($x, $y) = @_;
168     if ($x) {
169         return $y ? do { my $z; @a } : do { my $z; @b };
170     } else {
171         return (
172             do { my $z; @a },
173             (do { my$z; @b }) x $y
174         );
175     }
176     'xxx';
177 };
178
179 $x = $test_code->(1, 1);
180 is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
181 $x = $test_code->(1, 0);
182 is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
183 @x = $test_code->(1, 1);
184 is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
185 @x = $test_code->(1, 0);
186 is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
187
188 $x = $test_code->(0, 0);
189 is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
190 $x = $test_code->(0, 1);
191 is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
192 @x = $test_code->(0, 0);
193 is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
194 @x = $test_code->(0, 1);
195 is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
196
197 $test_code = sub {
198     my ($x, $y) = @_;
199     if ($x) {
200         return do {
201             if ($y == 0) {
202                 my $z;
203                 @a;
204             } elsif ($y == 1) {
205                 my $z;
206                 @b;
207             } else {
208                 my $z;
209                 (wantarray ? reverse(@a) : '99');
210             }
211         };
212     }
213     'xxx';
214 };
215
216 $x = $test_code->(1, 0);
217 is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
218 $x = $test_code->(1, 1);
219 is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
220 $x = $test_code->(1, 2);
221 is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
222 @x = $test_code->(1, 0);
223 is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
224 @x = $test_code->(1, 1);
225 is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
226 @x = $test_code->(1, 2);
227 is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
228
229 # Do blocks created by constant folding
230 # [perl #68108]
231 $x = sub { if (1) { 20 } }->();
232 is($x, 20, 'if (1) { $x } receives caller scalar context');
233
234 @a = (21 .. 23);
235 $x = sub { if (1) { @a } }->();
236 is($x, 3, 'if (1) { @a } receives caller scalar context');
237 @x = sub { if (1) { @a } }->();
238 is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
239
240 $x = sub { if (1) { 0; 20 } }->();
241 is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
242
243 @a = (24 .. 27);
244 $x = sub { if (1) { 0; @a } }->();
245 is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
246 @x = sub { if (1) { 0; @a } }->();
247 is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
248
249 $x = sub { if (1) { 0; 20 } else{} }->();
250 is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
251
252 @a = (24 .. 27);
253 $x = sub { if (1) { 0; @a } else{} }->();
254 is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
255 @x = sub { if (1) { 0; @a } else{} }->();
256 is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
257
258 $x = sub { if (0){} else { 0; 20 } }->();
259 is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
260
261 @a = (24 .. 27);
262 $x = sub { if (0){} else { 0; @a } }->();
263 is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
264 @x = sub { if (0){} else { 0; @a } }->();
265 is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
266
267 done_testing();