1#!./perl -w
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc( '../lib' );
7}
8use strict;
9no warnings 'void';
10use Errno qw(ENOENT EISDIR);
11
12my $called;
13my $result = do{ ++$called; 'value';};
14is($called, 1, 'do block called');
15is($result, 'value', 'do block returns correct value');
16
17unshift @INC, '.';
18
19my $file16 = tempfile();
20if (open my $do, '>', $file16) {
21    print $do "isnt(wantarray, undef, 'do in scalar context');\n";
22    print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n";
23    close $do or die "Could not close: $!";
24}
25
26my $a = do $file16; die $@ if $@;
27
28my $file17 = tempfile();
29if (open my $do, '>', $file17) {
30    print $do "isnt(wantarray, undef, 'do in list context');\n";
31    print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n";
32    close $do or die "Could not close: $!";
33}
34
35my @a = do $file17; die $@ if $@;
36
37my $file18 = tempfile();
38if (open my $do, '>', $file18) {
39    print $do "is(wantarray, undef, 'do in void context');\n";
40    close $do or die "Could not close: $!";
41}
42
43do $file18; die $@ if $@;
44
45# bug ID 20010920.007 (#7713)
46eval qq{ do qq(a file that does not exist); };
47is($@, '', "do on a non-existing file, first try");
48
49eval qq{ do uc qq(a file that does not exist); };
50is($@, '', "do on a non-existing file, second try");
51
52# 6 must be interpreted as a file name here
53$! = 0;
54my $do6 = do 6;
55my $errno = $1;
56is($do6, undef, 'do 6 must be interpreted as a filename');
57isnt($!, 0, 'and should set $!');
58
59# [perl #19545]
60my ($u, @t);
61{
62    no warnings 'uninitialized';
63    push @t, ($u = (do {} . "This should be pushed."));
64}
65is($#t, 0, "empty do result value" );
66
67my $zok = '';
68my $owww = do { 1 if $zok };
69is($owww, '', 'last is unless');
70$owww = do { 2 unless not $zok };
71is($owww, 1, 'last is if not');
72
73$zok = 'swish';
74$owww = do { 3 unless $zok };
75is($owww, 'swish', 'last is unless');
76$owww = do { 4 if not $zok };
77is($owww, '', 'last is if not');
78
79# [perl #38809]
80@a = (7);
81my $x = sub { do { return do { @a } }; 2 }->();
82is($x, 1, 'return do { } receives caller scalar context');
83my @x = sub { do { return do { @a } }; 2 }->();
84is("@x", "7", 'return do { } receives caller list context');
85
86@a = (7, 8);
87$x = sub { do { return do { 1; @a } }; 3 }->();
88is($x, 2, 'return do { ; } receives caller scalar context');
89@x = sub { do { return do { 1; @a } }; 3 }->();
90is("@x", "7 8", 'return do { ; } receives caller list context');
91
92my @b = (11 .. 15);
93$x = sub { do { return do { 1; @a, @b } }; 3 }->();
94is($x, 5, 'return do { ; , } receives caller scalar context');
95@x = sub { do { return do { 1; @a, @b } }; 3 }->();
96is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context');
97
98$x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
99is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
100@x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
101is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context');
102
103@a = (7, 8, 9);
104$x = sub { do { do { 1; return @a } }; 4 }->();
105is($x, 3, 'do { return } receives caller scalar context');
106@x = sub { do { do { 1; return @a } }; 4 }->();
107is("@x", "7 8 9", 'do { return } receives caller list context');
108
109@a = (7, 8, 9, 10);
110$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
111is($x, 4, 'return do { do { ; } } receives caller scalar context');
112@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
113is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
114
115# More tests about context propagation below return()
116@a = (11, 12);
117@b = (21, 22, 23);
118
119my $test_code = sub {
120    my ($x, $y) = @_;
121    if ($x) {
122	return $y ? do { my $z; @a } : do { my $z; @b };
123    } else {
124	return (
125	    do { my $z; @a },
126	    (do { my$z; @b }) x $y
127	);
128    }
129    'xxx';
130};
131
132$x = $test_code->(1, 1);
133is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
134$x = $test_code->(1, 0);
135is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
136@x = $test_code->(1, 1);
137is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
138@x = $test_code->(1, 0);
139is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
140
141$x = $test_code->(0, 0);
142is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
143$x = $test_code->(0, 1);
144is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
145@x = $test_code->(0, 0);
146is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
147@x = $test_code->(0, 1);
148is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
149
150$test_code = sub {
151    my ($x, $y) = @_;
152    if ($x) {
153	return do {
154	    if ($y == 0) {
155		my $z;
156		@a;
157	    } elsif ($y == 1) {
158		my $z;
159		@b;
160	    } else {
161		my $z;
162		(wantarray ? reverse(@a) : '99');
163	    }
164	};
165    }
166    'xxx';
167};
168
169$x = $test_code->(1, 0);
170is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
171$x = $test_code->(1, 1);
172is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
173$x = $test_code->(1, 2);
174is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
175@x = $test_code->(1, 0);
176is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
177@x = $test_code->(1, 1);
178is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
179@x = $test_code->(1, 2);
180is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
181
182# Do blocks created by constant folding
183# [perl #68108]
184$x = sub { if (1) { 20 } }->();
185is($x, 20, 'if (1) { $x } receives caller scalar context');
186
187@a = (21 .. 23);
188$x = sub { if (1) { @a } }->();
189is($x, 3, 'if (1) { @a } receives caller scalar context');
190@x = sub { if (1) { @a } }->();
191is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
192
193$x = sub { if (1) { 0; 20 } }->();
194is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
195
196@a = (24 .. 27);
197$x = sub { if (1) { 0; @a } }->();
198is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
199@x = sub { if (1) { 0; @a } }->();
200is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
201
202$x = sub { if (1) { 0; 20 } else{} }->();
203is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
204
205@a = (24 .. 27);
206$x = sub { if (1) { 0; @a } else{} }->();
207is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
208@x = sub { if (1) { 0; @a } else{} }->();
209is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
210
211$x = sub { if (0){} else { 0; 20 } }->();
212is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
213
214@a = (24 .. 27);
215$x = sub { if (0){} else { 0; @a } }->();
216is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
217@x = sub { if (0){} else { 0; @a } }->();
218is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
219
220# [rt.cpan.org #72767] do "string" should not propagate warning hints
221SKIP: {
222  skip_if_miniperl("no in-memory files under miniperl", 1);
223
224  my $code = '42; 1';
225  # Based on Eval::WithLexicals::_eval_do
226  local @INC = (sub {
227    if ($_[1] eq '/eval_do') {
228      open my $fh, '<', \$code;
229      $fh;
230    } else {
231      ();
232    }
233  }, @INC);
234  local $^W;
235  use warnings;
236  my $w;
237  local $SIG{__WARN__} = sub { warn shift; ++$w };
238  do '/eval_do' or die $@;
239  is($w, undef, 'do STRING does not propagate warning hints');
240}
241
242# RT#113730 - $@ should be cleared on IO error.
243{
244    $@ = "should not see";
245    $! = 0;
246    my $rv = do("some nonexistent file");
247    my $saved_error = $@;
248    my $saved_errno = $!;
249    ok(!$rv,          "do returns false on io errror");
250    ok(!$saved_error, "\$\@ not set on io error");
251    ok($saved_errno == ENOENT, "\$! is ENOENT for nonexistent file");
252}
253
254# do subname should not be do "subname"
255{
256    my $called;
257    sub fungi { $called .= "fungible" }
258    $@ = "scrimptious scrobblings";
259    do fungi;
260    is $called, "fungible", "do-file does not force bareword";
261    isnt $@, "scrimptious scrobblings", "It was interpreted as do-file";
262}
263
264# do CORE () has always been do-file
265{
266    my $called;
267    sub CORE { $called .= "fungible" }
268    $@ = "scromptious scrimblings";
269    do CORE();
270    is $called, "fungible", "do CORE() calls &CORE";
271    isnt $@, "scromptious scrimblings", "It was interpreted as do-file";
272}
273
274# do subname() and $subname() are no longer allowed
275{
276    sub subname { fail('do subname('. ($_[0] || '') .') called') };
277    my $subref = sub { fail('do $subref('. ($_[0] || '') .') called') };
278    foreach my $mode (qw(subname("arg") subname() $subref("arg") $subref())) {
279        eval "do $mode";
280        like $@, qr/\Asyntax error/, "do $mode is syntax error";
281    }
282}
283
284{
285    # follow-up to [perl #91844]: a do should always return a copy,
286    # not the original
287
288    my %foo;
289    $foo{bar} = 7;
290    my $r = \$foo{bar};
291    sub {
292        $$r++;
293        isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
294    }->(do { 1; delete $foo{bar} });
295}
296
297# A do block should FREETMPS on exit
298# RT #124248
299
300{
301    package p124248;
302    my $d = 0;
303    sub DESTROY { $d++ }
304    sub f { ::is($d, 1, "RT 124248"); }
305    f(do { 1; !!(my $x = bless []); });
306}
307
308
309# do file $!s must be correct
310{
311    local @INC = ('.'); #want EISDIR not ENOENT
312    my $rv = do 'op'; # /t/op dir
313    my $saved_error = $@;
314    my $saved_errno = $!+0;
315    ok(!$rv,                    "do dir returns false");
316    ok(!$saved_error,           "\$\@ is false on do dir");
317    ok($saved_errno == EISDIR,  "\$! is EISDIR on do dir");
318}
319
320done_testing();
321