This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Let's be consistent.
[perl5.git] / t / op / do.t
CommitLineData
a0c9a42a
NC
1#!./perl -w
2
ce9d5336 3BEGIN {
ed430ca9
FC
4 chdir 't';
5 @INC = '../lib';
ce9d5336
FC
6 require './test.pl';
7}
a0c9a42a
NC
8use strict;
9no warnings 'void';
8d063cd8 10
a0c9a42a 11my $called;
8c74b414 12my $result = do{ ++$called; 'value';};
a0c9a42a
NC
13is($called, 1, 'do block called');
14is($result, 'value', 'do block returns correct value');
378cc40b 15
df739378
JH
16unshift @INC, '.';
17
a0c9a42a
NC
18my $file16 = tempfile();
19if (open my $do, '>', $file16) {
20 print $do "isnt(wantarray, undef, 'do in scalar context');\n";
21 print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n";
22 close $do or die "Could not close: $!";
df739378
JH
23}
24
a0c9a42a 25my $a = do $file16; die $@ if $@;
df739378 26
a0c9a42a
NC
27my $file17 = tempfile();
28if (open my $do, '>', $file17) {
29 print $do "isnt(wantarray, undef, 'do in list context');\n";
30 print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n";
31 close $do or die "Could not close: $!";
df739378
JH
32}
33
a0c9a42a 34my @a = do $file17; die $@ if $@;
df739378 35
a0c9a42a
NC
36my $file18 = tempfile();
37if (open my $do, '>', $file18) {
38 print $do "is(wantarray, undef, 'do in void context');\n";
39 close $do or die "Could not close: $!";
df739378
JH
40}
41
a0c9a42a 42do $file18; die $@ if $@;
df739378 43
5d96a5e0
MS
44# bug ID 20010920.007
45eval qq{ do qq(a file that does not exist); };
a0c9a42a 46is($@, '', "do on a non-existing file, first try");
5d96a5e0
MS
47
48eval qq{ do uc qq(a file that does not exist); };
a0c9a42a 49is($@, '', "do on a non-existing file, second try");
5d96a5e0 50
d4a8e56c 51# 6 must be interpreted as a file name here
a0c9a42a
NC
52$! = 0;
53my $do6 = do 6;
54my $errno = $1;
55is($do6, undef, 'do 6 must be interpreted as a filename');
56isnt($!, 0, 'and should set $!');
d4a8e56c 57
db80722a 58# [perl #19545]
a0c9a42a
NC
59my ($u, @t);
60{
61 no warnings 'uninitialized';
62 push @t, ($u = (do {} . "This should be pushed."));
63}
64is($#t, 0, "empty do result value" );
db80722a 65
a0c9a42a
NC
66my $zok = '';
67my $owww = do { 1 if $zok };
68is($owww, '', 'last is unless');
edbe35ea 69$owww = do { 2 unless not $zok };
a0c9a42a 70is($owww, 1, 'last is if not');
edbe35ea
VP
71
72$zok = 'swish';
73$owww = do { 3 unless $zok };
a0c9a42a 74is($owww, 'swish', 'last is unless');
edbe35ea 75$owww = do { 4 if not $zok };
a0c9a42a 76is($owww, '', 'last is if not');
edbe35ea 77
e91684bf 78# [perl #38809]
1c8a4223 79@a = (7);
a0c9a42a
NC
80my $x = sub { do { return do { @a } }; 2 }->();
81is($x, 1, 'return do { } receives caller scalar context');
8c74b414 82my @x = sub { do { return do { @a } }; 2 }->();
a0c9a42a 83is("@x", "7", 'return do { } receives caller list context');
1c8a4223 84
e91684bf
VP
85@a = (7, 8);
86$x = sub { do { return do { 1; @a } }; 3 }->();
a0c9a42a 87is($x, 2, 'return do { ; } receives caller scalar context');
e91684bf 88@x = sub { do { return do { 1; @a } }; 3 }->();
a0c9a42a 89is("@x", "7 8", 'return do { ; } receives caller list context');
1c8a4223 90
a0c9a42a 91my @b = (11 .. 15);
1c8a4223 92$x = sub { do { return do { 1; @a, @b } }; 3 }->();
a0c9a42a 93is($x, 5, 'return do { ; , } receives caller scalar context');
1c8a4223 94@x = sub { do { return do { 1; @a, @b } }; 3 }->();
a0c9a42a 95is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context');
1c8a4223
VP
96
97$x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
a0c9a42a 98is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
1c8a4223 99@x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
a0c9a42a 100is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context');
1c8a4223 101
e91684bf
VP
102@a = (7, 8, 9);
103$x = sub { do { do { 1; return @a } }; 4 }->();
a0c9a42a 104is($x, 3, 'do { return } receives caller scalar context');
e91684bf 105@x = sub { do { do { 1; return @a } }; 4 }->();
a0c9a42a 106is("@x", "7 8 9", 'do { return } receives caller list context');
1c8a4223 107
e91684bf
VP
108@a = (7, 8, 9, 10);
109$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
a0c9a42a 110is($x, 4, 'return do { do { ; } } receives caller scalar context');
e91684bf 111@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
a0c9a42a 112is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
e91684bf 113
7c2d9d03
VP
114# More tests about context propagation below return()
115@a = (11, 12);
116@b = (21, 22, 23);
117
118my $test_code = sub {
119 my ($x, $y) = @_;
120 if ($x) {
121 return $y ? do { my $z; @a } : do { my $z; @b };
122 } else {
123 return (
124 do { my $z; @a },
125 (do { my$z; @b }) x $y
126 );
127 }
128 'xxx';
129};
130
131$x = $test_code->(1, 1);
132is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
133$x = $test_code->(1, 0);
134is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
135@x = $test_code->(1, 1);
136is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
137@x = $test_code->(1, 0);
138is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
139
140$x = $test_code->(0, 0);
141is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
142$x = $test_code->(0, 1);
143is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
144@x = $test_code->(0, 0);
145is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
146@x = $test_code->(0, 1);
147is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
148
149$test_code = sub {
150 my ($x, $y) = @_;
151 if ($x) {
152 return do {
153 if ($y == 0) {
154 my $z;
155 @a;
156 } elsif ($y == 1) {
157 my $z;
158 @b;
159 } else {
160 my $z;
161 (wantarray ? reverse(@a) : '99');
162 }
163 };
164 }
165 'xxx';
166};
167
168$x = $test_code->(1, 0);
169is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
170$x = $test_code->(1, 1);
171is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
172$x = $test_code->(1, 2);
173is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
174@x = $test_code->(1, 0);
175is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
176@x = $test_code->(1, 1);
177is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
178@x = $test_code->(1, 2);
179is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
180
dd3e51dc
VP
181# Do blocks created by constant folding
182# [perl #68108]
183$x = sub { if (1) { 20 } }->();
a0c9a42a 184is($x, 20, 'if (1) { $x } receives caller scalar context');
dd3e51dc
VP
185
186@a = (21 .. 23);
187$x = sub { if (1) { @a } }->();
a0c9a42a 188is($x, 3, 'if (1) { @a } receives caller scalar context');
dd3e51dc 189@x = sub { if (1) { @a } }->();
a0c9a42a 190is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
dd3e51dc
VP
191
192$x = sub { if (1) { 0; 20 } }->();
a0c9a42a 193is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
dd3e51dc
VP
194
195@a = (24 .. 27);
196$x = sub { if (1) { 0; @a } }->();
a0c9a42a 197is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
dd3e51dc 198@x = sub { if (1) { 0; @a } }->();
a0c9a42a 199is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
dd3e51dc 200
ef9da979 201$x = sub { if (1) { 0; 20 } else{} }->();
a0c9a42a 202is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
ef9da979
FC
203
204@a = (24 .. 27);
205$x = sub { if (1) { 0; @a } else{} }->();
a0c9a42a 206is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
ef9da979 207@x = sub { if (1) { 0; @a } else{} }->();
a0c9a42a 208is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
ef9da979
FC
209
210$x = sub { if (0){} else { 0; 20 } }->();
a0c9a42a 211is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
ef9da979
FC
212
213@a = (24 .. 27);
214$x = sub { if (0){} else { 0; @a } }->();
a0c9a42a 215is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
ef9da979 216@x = sub { if (0){} else { 0; @a } }->();
a0c9a42a 217is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
ef9da979 218
3840c57b
FC
219# [rt.cpan.org #72767] do "string" should not propagate warning hints
220SKIP: {
221 skip_if_miniperl("no in-memory files under miniperl", 1);
222
223 my $code = '42; 1';
224 # Based on Eval::WithLexicals::_eval_do
225 local @INC = (sub {
226 if ($_[1] eq '/eval_do') {
227 open my $fh, '<', \$code;
228 $fh;
229 } else {
230 ();
231 }
232 }, @INC);
233 local $^W;
234 use warnings;
235 my $w;
236 local $SIG{__WARN__} = sub { warn shift; ++$w };
237 do '/eval_do' or die $@;
238 is($w, undef, 'do STRING does not propagate warning hints');
239}
240
a3ff80c1
EB
241# RT#113730 - $@ should be cleared on IO error.
242{
243 $@ = "should not see";
244 $! = 0;
245 my $rv = do("some nonexistent file");
246 my $saved_error = $@;
247 my $saved_errno = $!;
248 ok(!$rv, "do returns false on io errror");
249 ok(!$saved_error, "\$\@ not set on io error");
250 ok($saved_errno, "\$! set on io error");
251}
252
c2900bb8
FC
253# do subname should not be do "subname"
254{
255 my $called;
256 sub fungi { $called .= "fungible" }
257 $@ = "scrimptious scrobblings";
258 do fungi;
259 is $called, "fungible", "do-file does not force bareword";
260 isnt $@, "scrimptious scrobblings", "It was interpreted as do-file";
261}
262
8c74b414
DIM
263# do subname() and $subname() are no longer allowed
264{
265 sub subname { fail('do subname('. ($_[0] || '') .') called') };
266 my $subref = sub { fail('do $subref('. ($_[0] || '') .') called') };
267 foreach my $mode (qw(subname("arg") subname() $subref("arg") $subref())) {
268 eval "do $mode";
269 like $@, qr/\Asyntax error/, "do $mode is syntax error";
270 }
271}
272
a0c9a42a 273done_testing();