fix for Module/CoreList.pm 5.029009
[perl.git] / t / op / do.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc( '../lib' );
7 }
8 use strict;
9 no warnings 'void';
10 use Errno qw(ENOENT EISDIR);
11
12 my $called;
13 my $result = do{ ++$called; 'value';};
14 is($called, 1, 'do block called');
15 is($result, 'value', 'do block returns correct value');
16
17 unshift @INC, '.';
18
19 my $file16 = tempfile();
20 if (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
26 my $a = do $file16; die $@ if $@;
27
28 my $file17 = tempfile();
29 if (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
35 my @a = do $file17; die $@ if $@;
36
37 my $file18 = tempfile();
38 if (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
43 do $file18; die $@ if $@;
44
45 # bug ID 20010920.007 (#7713)
46 eval qq{ do qq(a file that does not exist); };
47 is($@, '', "do on a non-existing file, first try");
48
49 eval qq{ do uc qq(a file that does not exist); };
50 is($@, '', "do on a non-existing file, second try");
51
52 # 6 must be interpreted as a file name here
53 $! = 0;
54 my $do6 = do 6;
55 my $errno = $1;
56 is($do6, undef, 'do 6 must be interpreted as a filename');
57 isnt($!, 0, 'and should set $!');
58
59 # [perl #19545]
60 my ($u, @t);
61 {
62     no warnings 'uninitialized';
63     push @t, ($u = (do {} . "This should be pushed."));
64 }
65 is($#t, 0, "empty do result value" );
66
67 my $zok = '';
68 my $owww = do { 1 if $zok };
69 is($owww, '', 'last is unless');
70 $owww = do { 2 unless not $zok };
71 is($owww, 1, 'last is if not');
72
73 $zok = 'swish';
74 $owww = do { 3 unless $zok };
75 is($owww, 'swish', 'last is unless');
76 $owww = do { 4 if not $zok };
77 is($owww, '', 'last is if not');
78
79 # [perl #38809]
80 @a = (7);
81 my $x = sub { do { return do { @a } }; 2 }->();
82 is($x, 1, 'return do { } receives caller scalar context');
83 my @x = sub { do { return do { @a } }; 2 }->();
84 is("@x", "7", 'return do { } receives caller list context');
85
86 @a = (7, 8);
87 $x = sub { do { return do { 1; @a } }; 3 }->();
88 is($x, 2, 'return do { ; } receives caller scalar context');
89 @x = sub { do { return do { 1; @a } }; 3 }->();
90 is("@x", "7 8", 'return do { ; } receives caller list context');
91
92 my @b = (11 .. 15);
93 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
94 is($x, 5, 'return do { ; , } receives caller scalar context');
95 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
96 is("@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 }->();
99 is($x, 5, 'return do { ; }, do { ; } receives caller scalar context');
100 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
101 is("@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 }->();
105 is($x, 3, 'do { return } receives caller scalar context');
106 @x = sub { do { do { 1; return @a } }; 4 }->();
107 is("@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 }->();
111 is($x, 4, 'return do { do { ; } } receives caller scalar context');
112 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
113 is("@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
119 my $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);
133 is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
134 $x = $test_code->(1, 0);
135 is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
136 @x = $test_code->(1, 1);
137 is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
138 @x = $test_code->(1, 0);
139 is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
140
141 $x = $test_code->(0, 0);
142 is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
143 $x = $test_code->(0, 1);
144 is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
145 @x = $test_code->(0, 0);
146 is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
147 @x = $test_code->(0, 1);
148 is("@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);
170 is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
171 $x = $test_code->(1, 1);
172 is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
173 $x = $test_code->(1, 2);
174 is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
175 @x = $test_code->(1, 0);
176 is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
177 @x = $test_code->(1, 1);
178 is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
179 @x = $test_code->(1, 2);
180 is("@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 } }->();
185 is($x, 20, 'if (1) { $x } receives caller scalar context');
186
187 @a = (21 .. 23);
188 $x = sub { if (1) { @a } }->();
189 is($x, 3, 'if (1) { @a } receives caller scalar context');
190 @x = sub { if (1) { @a } }->();
191 is("@x", "21 22 23", 'if (1) { @a } receives caller list context');
192
193 $x = sub { if (1) { 0; 20 } }->();
194 is($x, 20, 'if (1) { ...; $x } receives caller scalar context');
195
196 @a = (24 .. 27);
197 $x = sub { if (1) { 0; @a } }->();
198 is($x, 4, 'if (1) { ...; @a } receives caller scalar context');
199 @x = sub { if (1) { 0; @a } }->();
200 is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
201
202 $x = sub { if (1) { 0; 20 } else{} }->();
203 is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context');
204
205 @a = (24 .. 27);
206 $x = sub { if (1) { 0; @a } else{} }->();
207 is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context');
208 @x = sub { if (1) { 0; @a } else{} }->();
209 is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
210
211 $x = sub { if (0){} else { 0; 20 } }->();
212 is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context');
213
214 @a = (24 .. 27);
215 $x = sub { if (0){} else { 0; @a } }->();
216 is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context');
217 @x = sub { if (0){} else { 0; @a } }->();
218 is("@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
221 SKIP: {
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
320 done_testing();