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