Commit | Line | Data |
---|---|---|
a0c9a42a NC |
1 | #!./perl -w |
2 | ||
ce9d5336 | 3 | BEGIN { |
ed430ca9 FC |
4 | chdir 't'; |
5 | @INC = '../lib'; | |
ce9d5336 FC |
6 | require './test.pl'; |
7 | } | |
a0c9a42a NC |
8 | use strict; |
9 | no warnings 'void'; | |
8d063cd8 | 10 | |
a0c9a42a | 11 | my $called; |
8c74b414 | 12 | my $result = do{ ++$called; 'value';}; |
a0c9a42a NC |
13 | is($called, 1, 'do block called'); |
14 | is($result, 'value', 'do block returns correct value'); | |
378cc40b | 15 | |
df739378 JH |
16 | unshift @INC, '.'; |
17 | ||
a0c9a42a NC |
18 | my $file16 = tempfile(); |
19 | if (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 | 25 | my $a = do $file16; die $@ if $@; |
df739378 | 26 | |
a0c9a42a NC |
27 | my $file17 = tempfile(); |
28 | if (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 | 34 | my @a = do $file17; die $@ if $@; |
df739378 | 35 | |
a0c9a42a NC |
36 | my $file18 = tempfile(); |
37 | if (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 | 42 | do $file18; die $@ if $@; |
df739378 | 43 | |
5d96a5e0 MS |
44 | # bug ID 20010920.007 |
45 | eval qq{ do qq(a file that does not exist); }; | |
a0c9a42a | 46 | is($@, '', "do on a non-existing file, first try"); |
5d96a5e0 MS |
47 | |
48 | eval qq{ do uc qq(a file that does not exist); }; | |
a0c9a42a | 49 | is($@, '', "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; |
53 | my $do6 = do 6; | |
54 | my $errno = $1; | |
55 | is($do6, undef, 'do 6 must be interpreted as a filename'); | |
56 | isnt($!, 0, 'and should set $!'); | |
d4a8e56c | 57 | |
db80722a | 58 | # [perl #19545] |
a0c9a42a NC |
59 | my ($u, @t); |
60 | { | |
61 | no warnings 'uninitialized'; | |
62 | push @t, ($u = (do {} . "This should be pushed.")); | |
63 | } | |
64 | is($#t, 0, "empty do result value" ); | |
db80722a | 65 | |
a0c9a42a NC |
66 | my $zok = ''; |
67 | my $owww = do { 1 if $zok }; | |
68 | is($owww, '', 'last is unless'); | |
edbe35ea | 69 | $owww = do { 2 unless not $zok }; |
a0c9a42a | 70 | is($owww, 1, 'last is if not'); |
edbe35ea VP |
71 | |
72 | $zok = 'swish'; | |
73 | $owww = do { 3 unless $zok }; | |
a0c9a42a | 74 | is($owww, 'swish', 'last is unless'); |
edbe35ea | 75 | $owww = do { 4 if not $zok }; |
a0c9a42a | 76 | is($owww, '', 'last is if not'); |
edbe35ea | 77 | |
e91684bf | 78 | # [perl #38809] |
1c8a4223 | 79 | @a = (7); |
a0c9a42a NC |
80 | my $x = sub { do { return do { @a } }; 2 }->(); |
81 | is($x, 1, 'return do { } receives caller scalar context'); | |
8c74b414 | 82 | my @x = sub { do { return do { @a } }; 2 }->(); |
a0c9a42a | 83 | is("@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 | 87 | is($x, 2, 'return do { ; } receives caller scalar context'); |
e91684bf | 88 | @x = sub { do { return do { 1; @a } }; 3 }->(); |
a0c9a42a | 89 | is("@x", "7 8", 'return do { ; } receives caller list context'); |
1c8a4223 | 90 | |
a0c9a42a | 91 | my @b = (11 .. 15); |
1c8a4223 | 92 | $x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 93 | is($x, 5, 'return do { ; , } receives caller scalar context'); |
1c8a4223 | 94 | @x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 95 | is("@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 | 98 | is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); |
1c8a4223 | 99 | @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); |
a0c9a42a | 100 | is("@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 | 104 | is($x, 3, 'do { return } receives caller scalar context'); |
e91684bf | 105 | @x = sub { do { do { 1; return @a } }; 4 }->(); |
a0c9a42a | 106 | is("@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 | 110 | is($x, 4, 'return do { do { ; } } receives caller scalar context'); |
e91684bf | 111 | @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); |
a0c9a42a | 112 | is("@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 | ||
118 | my $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); | |
132 | is($x, 2, 'return $y ? do { } : do { } - scalar context 1'); | |
133 | $x = $test_code->(1, 0); | |
134 | is($x, 3, 'return $y ? do { } : do { } - scalar context 2'); | |
135 | @x = $test_code->(1, 1); | |
136 | is("@x", '11 12', 'return $y ? do { } : do { } - list context 1'); | |
137 | @x = $test_code->(1, 0); | |
138 | is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2'); | |
139 | ||
140 | $x = $test_code->(0, 0); | |
141 | is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1'); | |
142 | $x = $test_code->(0, 1); | |
143 | is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2'); | |
144 | @x = $test_code->(0, 0); | |
145 | is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1'); | |
146 | @x = $test_code->(0, 1); | |
147 | is("@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); | |
169 | is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1'); | |
170 | $x = $test_code->(1, 1); | |
171 | is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2'); | |
172 | $x = $test_code->(1, 2); | |
173 | is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3'); | |
174 | @x = $test_code->(1, 0); | |
175 | is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1'); | |
176 | @x = $test_code->(1, 1); | |
177 | is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2'); | |
178 | @x = $test_code->(1, 2); | |
179 | is("@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 | 184 | is($x, 20, 'if (1) { $x } receives caller scalar context'); |
dd3e51dc VP |
185 | |
186 | @a = (21 .. 23); | |
187 | $x = sub { if (1) { @a } }->(); | |
a0c9a42a | 188 | is($x, 3, 'if (1) { @a } receives caller scalar context'); |
dd3e51dc | 189 | @x = sub { if (1) { @a } }->(); |
a0c9a42a | 190 | is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); |
dd3e51dc VP |
191 | |
192 | $x = sub { if (1) { 0; 20 } }->(); | |
a0c9a42a | 193 | is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); |
dd3e51dc VP |
194 | |
195 | @a = (24 .. 27); | |
196 | $x = sub { if (1) { 0; @a } }->(); | |
a0c9a42a | 197 | is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); |
dd3e51dc | 198 | @x = sub { if (1) { 0; @a } }->(); |
a0c9a42a | 199 | is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); |
dd3e51dc | 200 | |
ef9da979 | 201 | $x = sub { if (1) { 0; 20 } else{} }->(); |
a0c9a42a | 202 | is($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 | 206 | is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); |
ef9da979 | 207 | @x = sub { if (1) { 0; @a } else{} }->(); |
a0c9a42a | 208 | is("@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 | 211 | is($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 | 215 | is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); |
ef9da979 | 216 | @x = sub { if (0){} else { 0; @a } }->(); |
a0c9a42a | 217 | is("@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 |
220 | SKIP: { | |
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 | ||
ceaf124e FC |
263 | # do CORE () has always been do-file |
264 | { | |
265 | my $called; | |
266 | sub CORE { $called .= "fungible" } | |
267 | $@ = "scromptious scrimblings"; | |
268 | do CORE(); | |
269 | is $called, "fungible", "do CORE() calls &CORE"; | |
270 | isnt $@, "scromptious scrimblings", "It was interpreted as do-file"; | |
271 | } | |
272 | ||
8c74b414 DIM |
273 | # do subname() and $subname() are no longer allowed |
274 | { | |
275 | sub subname { fail('do subname('. ($_[0] || '') .') called') }; | |
276 | my $subref = sub { fail('do $subref('. ($_[0] || '') .') called') }; | |
277 | foreach my $mode (qw(subname("arg") subname() $subref("arg") $subref())) { | |
278 | eval "do $mode"; | |
279 | like $@, qr/\Asyntax error/, "do $mode is syntax error"; | |
280 | } | |
281 | } | |
282 | ||
a0c9a42a | 283 | done_testing(); |