Commit | Line | Data |
---|---|---|
a0c9a42a NC |
1 | #!./perl -w |
2 | ||
3 | require './test.pl'; | |
4 | use strict; | |
5 | no warnings 'void'; | |
8d063cd8 | 6 | |
8d063cd8 LW |
7 | sub foo1 |
8 | { | |
a0c9a42a | 9 | ok($_[0], 'in foo1'); |
8d063cd8 LW |
10 | 'value'; |
11 | } | |
12 | ||
13 | sub foo2 | |
14 | { | |
6d4ff0d2 | 15 | shift; |
a0c9a42a NC |
16 | ok($_[0], 'in foo2'); |
17 | my $x = 'value'; | |
8d063cd8 LW |
18 | $x; |
19 | } | |
20 | ||
a0c9a42a | 21 | my $result; |
5d96a5e0 | 22 | $_[0] = 0; |
96ccdd02 NC |
23 | { |
24 | no warnings 'deprecated'; | |
25 | $result = do foo1(1); | |
26 | } | |
8d063cd8 | 27 | |
a0c9a42a NC |
28 | is($result, 'value', 'do &sub and proper @_ handling'); |
29 | cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); | |
8d063cd8 | 30 | |
5d96a5e0 | 31 | $_[0] = 0; |
96ccdd02 NC |
32 | { |
33 | no warnings 'deprecated'; | |
34 | $result = do foo2(0,1,0); | |
35 | } | |
a0c9a42a NC |
36 | is($result, 'value', 'do &sub and proper @_ handling'); |
37 | cmp_ok($_[0], '==', 0, 'do &sub and proper @_ handling'); | |
5d96a5e0 | 38 | |
a0c9a42a NC |
39 | my $called; |
40 | $result = do{ ++$called; 'value';}; | |
41 | is($called, 1, 'do block called'); | |
42 | is($result, 'value', 'do block returns correct value'); | |
378cc40b | 43 | |
a0c9a42a | 44 | my @blathered; |
378cc40b | 45 | sub blather { |
a0c9a42a | 46 | push @blathered, $_ foreach @_; |
378cc40b LW |
47 | } |
48 | ||
96ccdd02 NC |
49 | { |
50 | no warnings 'deprecated'; | |
51 | do blather("ayep","sho nuff"); | |
a0c9a42a | 52 | is("@blathered", "ayep sho nuff", 'blathered called with list'); |
96ccdd02 | 53 | } |
a0c9a42a NC |
54 | @blathered = (); |
55 | ||
56 | my @x = ("jeepers", "okydoke"); | |
57 | my @y = ("uhhuh", "yeppers"); | |
96ccdd02 NC |
58 | { |
59 | no warnings 'deprecated'; | |
60 | do blather(@x,"noofie",@y); | |
a0c9a42a | 61 | is("@blathered", "@x noofie @y", 'blathered called with arrays too'); |
96ccdd02 | 62 | } |
df739378 JH |
63 | |
64 | unshift @INC, '.'; | |
65 | ||
a0c9a42a NC |
66 | my $file16 = tempfile(); |
67 | if (open my $do, '>', $file16) { | |
68 | print $do "isnt(wantarray, undef, 'do in scalar context');\n"; | |
69 | print $do "cmp_ok(wantarray, '==', 0, 'do in scalar context');\n"; | |
70 | close $do or die "Could not close: $!"; | |
df739378 JH |
71 | } |
72 | ||
a0c9a42a | 73 | my $a = do $file16; die $@ if $@; |
df739378 | 74 | |
a0c9a42a NC |
75 | my $file17 = tempfile(); |
76 | if (open my $do, '>', $file17) { | |
77 | print $do "isnt(wantarray, undef, 'do in list context');\n"; | |
78 | print $do "cmp_ok(wantarray, '!=', 0, 'do in list context');\n"; | |
79 | close $do or die "Could not close: $!"; | |
df739378 JH |
80 | } |
81 | ||
a0c9a42a | 82 | my @a = do $file17; die $@ if $@; |
df739378 | 83 | |
a0c9a42a NC |
84 | my $file18 = tempfile(); |
85 | if (open my $do, '>', $file18) { | |
86 | print $do "is(wantarray, undef, 'do in void context');\n"; | |
87 | close $do or die "Could not close: $!"; | |
df739378 JH |
88 | } |
89 | ||
a0c9a42a | 90 | do $file18; die $@ if $@; |
df739378 | 91 | |
5d96a5e0 MS |
92 | # bug ID 20010920.007 |
93 | eval qq{ do qq(a file that does not exist); }; | |
a0c9a42a | 94 | is($@, '', "do on a non-existing file, first try"); |
5d96a5e0 MS |
95 | |
96 | eval qq{ do uc qq(a file that does not exist); }; | |
a0c9a42a | 97 | is($@, '', "do on a non-existing file, second try"); |
5d96a5e0 | 98 | |
d4a8e56c | 99 | # 6 must be interpreted as a file name here |
a0c9a42a NC |
100 | $! = 0; |
101 | my $do6 = do 6; | |
102 | my $errno = $1; | |
103 | is($do6, undef, 'do 6 must be interpreted as a filename'); | |
104 | isnt($!, 0, 'and should set $!'); | |
d4a8e56c | 105 | |
db80722a | 106 | # [perl #19545] |
a0c9a42a NC |
107 | my ($u, @t); |
108 | { | |
109 | no warnings 'uninitialized'; | |
110 | push @t, ($u = (do {} . "This should be pushed.")); | |
111 | } | |
112 | is($#t, 0, "empty do result value" ); | |
db80722a | 113 | |
a0c9a42a NC |
114 | my $zok = ''; |
115 | my $owww = do { 1 if $zok }; | |
116 | is($owww, '', 'last is unless'); | |
edbe35ea | 117 | $owww = do { 2 unless not $zok }; |
a0c9a42a | 118 | is($owww, 1, 'last is if not'); |
edbe35ea VP |
119 | |
120 | $zok = 'swish'; | |
121 | $owww = do { 3 unless $zok }; | |
a0c9a42a | 122 | is($owww, 'swish', 'last is unless'); |
edbe35ea | 123 | $owww = do { 4 if not $zok }; |
a0c9a42a | 124 | is($owww, '', 'last is if not'); |
edbe35ea | 125 | |
e91684bf | 126 | # [perl #38809] |
1c8a4223 | 127 | @a = (7); |
a0c9a42a NC |
128 | my $x = sub { do { return do { @a } }; 2 }->(); |
129 | is($x, 1, 'return do { } receives caller scalar context'); | |
1c8a4223 | 130 | @x = sub { do { return do { @a } }; 2 }->(); |
a0c9a42a | 131 | is("@x", "7", 'return do { } receives caller list context'); |
1c8a4223 | 132 | |
e91684bf VP |
133 | @a = (7, 8); |
134 | $x = sub { do { return do { 1; @a } }; 3 }->(); | |
a0c9a42a | 135 | is($x, 2, 'return do { ; } receives caller scalar context'); |
e91684bf | 136 | @x = sub { do { return do { 1; @a } }; 3 }->(); |
a0c9a42a | 137 | is("@x", "7 8", 'return do { ; } receives caller list context'); |
1c8a4223 | 138 | |
a0c9a42a | 139 | my @b = (11 .. 15); |
1c8a4223 | 140 | $x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 141 | is($x, 5, 'return do { ; , } receives caller scalar context'); |
1c8a4223 | 142 | @x = sub { do { return do { 1; @a, @b } }; 3 }->(); |
a0c9a42a | 143 | is("@x", "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context'); |
1c8a4223 VP |
144 | |
145 | $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); | |
a0c9a42a | 146 | is($x, 5, 'return do { ; }, do { ; } receives caller scalar context'); |
1c8a4223 | 147 | @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->(); |
a0c9a42a | 148 | is("@x", "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context'); |
1c8a4223 | 149 | |
e91684bf VP |
150 | @a = (7, 8, 9); |
151 | $x = sub { do { do { 1; return @a } }; 4 }->(); | |
a0c9a42a | 152 | is($x, 3, 'do { return } receives caller scalar context'); |
e91684bf | 153 | @x = sub { do { do { 1; return @a } }; 4 }->(); |
a0c9a42a | 154 | is("@x", "7 8 9", 'do { return } receives caller list context'); |
1c8a4223 | 155 | |
e91684bf VP |
156 | @a = (7, 8, 9, 10); |
157 | $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); | |
a0c9a42a | 158 | is($x, 4, 'return do { do { ; } } receives caller scalar context'); |
e91684bf | 159 | @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); |
a0c9a42a | 160 | is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context'); |
e91684bf | 161 | |
7c2d9d03 VP |
162 | # More tests about context propagation below return() |
163 | @a = (11, 12); | |
164 | @b = (21, 22, 23); | |
165 | ||
166 | my $test_code = sub { | |
167 | my ($x, $y) = @_; | |
168 | if ($x) { | |
169 | return $y ? do { my $z; @a } : do { my $z; @b }; | |
170 | } else { | |
171 | return ( | |
172 | do { my $z; @a }, | |
173 | (do { my$z; @b }) x $y | |
174 | ); | |
175 | } | |
176 | 'xxx'; | |
177 | }; | |
178 | ||
179 | $x = $test_code->(1, 1); | |
180 | is($x, 2, 'return $y ? do { } : do { } - scalar context 1'); | |
181 | $x = $test_code->(1, 0); | |
182 | is($x, 3, 'return $y ? do { } : do { } - scalar context 2'); | |
183 | @x = $test_code->(1, 1); | |
184 | is("@x", '11 12', 'return $y ? do { } : do { } - list context 1'); | |
185 | @x = $test_code->(1, 0); | |
186 | is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2'); | |
187 | ||
188 | $x = $test_code->(0, 0); | |
189 | is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1'); | |
190 | $x = $test_code->(0, 1); | |
191 | is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2'); | |
192 | @x = $test_code->(0, 0); | |
193 | is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1'); | |
194 | @x = $test_code->(0, 1); | |
195 | is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2'); | |
196 | ||
197 | $test_code = sub { | |
198 | my ($x, $y) = @_; | |
199 | if ($x) { | |
200 | return do { | |
201 | if ($y == 0) { | |
202 | my $z; | |
203 | @a; | |
204 | } elsif ($y == 1) { | |
205 | my $z; | |
206 | @b; | |
207 | } else { | |
208 | my $z; | |
209 | (wantarray ? reverse(@a) : '99'); | |
210 | } | |
211 | }; | |
212 | } | |
213 | 'xxx'; | |
214 | }; | |
215 | ||
216 | $x = $test_code->(1, 0); | |
217 | is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1'); | |
218 | $x = $test_code->(1, 1); | |
219 | is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2'); | |
220 | $x = $test_code->(1, 2); | |
221 | is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3'); | |
222 | @x = $test_code->(1, 0); | |
223 | is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1'); | |
224 | @x = $test_code->(1, 1); | |
225 | is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2'); | |
226 | @x = $test_code->(1, 2); | |
227 | is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3'); | |
228 | ||
dd3e51dc VP |
229 | # Do blocks created by constant folding |
230 | # [perl #68108] | |
231 | $x = sub { if (1) { 20 } }->(); | |
a0c9a42a | 232 | is($x, 20, 'if (1) { $x } receives caller scalar context'); |
dd3e51dc VP |
233 | |
234 | @a = (21 .. 23); | |
235 | $x = sub { if (1) { @a } }->(); | |
a0c9a42a | 236 | is($x, 3, 'if (1) { @a } receives caller scalar context'); |
dd3e51dc | 237 | @x = sub { if (1) { @a } }->(); |
a0c9a42a | 238 | is("@x", "21 22 23", 'if (1) { @a } receives caller list context'); |
dd3e51dc VP |
239 | |
240 | $x = sub { if (1) { 0; 20 } }->(); | |
a0c9a42a | 241 | is($x, 20, 'if (1) { ...; $x } receives caller scalar context'); |
dd3e51dc VP |
242 | |
243 | @a = (24 .. 27); | |
244 | $x = sub { if (1) { 0; @a } }->(); | |
a0c9a42a | 245 | is($x, 4, 'if (1) { ...; @a } receives caller scalar context'); |
dd3e51dc | 246 | @x = sub { if (1) { 0; @a } }->(); |
a0c9a42a | 247 | is("@x", "24 25 26 27", 'if (1) { ...; @a } receives caller list context'); |
dd3e51dc | 248 | |
ef9da979 | 249 | $x = sub { if (1) { 0; 20 } else{} }->(); |
a0c9a42a | 250 | is($x, 20, 'if (1) { ...; $x } else{} receives caller scalar context'); |
ef9da979 FC |
251 | |
252 | @a = (24 .. 27); | |
253 | $x = sub { if (1) { 0; @a } else{} }->(); | |
a0c9a42a | 254 | is($x, 4, 'if (1) { ...; @a } else{} receives caller scalar context'); |
ef9da979 | 255 | @x = sub { if (1) { 0; @a } else{} }->(); |
a0c9a42a | 256 | is("@x", "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context'); |
ef9da979 FC |
257 | |
258 | $x = sub { if (0){} else { 0; 20 } }->(); | |
a0c9a42a | 259 | is($x, 20, 'if (0){} else { ...; $x } receives caller scalar context'); |
ef9da979 FC |
260 | |
261 | @a = (24 .. 27); | |
262 | $x = sub { if (0){} else { 0; @a } }->(); | |
a0c9a42a | 263 | is($x, 4, 'if (0){} else { ...; @a } receives caller scalar context'); |
ef9da979 | 264 | @x = sub { if (0){} else { 0; @a } }->(); |
a0c9a42a | 265 | is("@x", "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context'); |
ef9da979 | 266 | |
a0c9a42a | 267 | done_testing(); |