Commit | Line | Data |
---|---|---|
0d863452 RH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
37e07c40 | 6 | require './test.pl'; |
0d863452 RH |
7 | } |
8 | ||
9 | use strict; | |
10 | use warnings; | |
0f539b13 | 11 | no warnings 'experimental::smartmatch'; |
0d863452 | 12 | |
87e4a53a | 13 | plan tests => 201; |
0d863452 | 14 | |
a632cb9b FC |
15 | # The behaviour of the feature pragma should be tested by lib/feature.t |
16 | # using the tests in t/lib/feature/*. This file tests the behaviour of | |
0d863452 | 17 | # the switch ops themselves. |
0d863452 | 18 | |
9dcb8368 FC |
19 | |
20 | # Before loading feature, test the switch ops with CORE:: | |
21 | CORE::given(3) { | |
a5c70c4d FC |
22 | CORE::when(3) { pass "CORE::given and CORE::when"; continue } |
23 | CORE::default { pass "continue (without feature) and CORE::default" } | |
9dcb8368 FC |
24 | } |
25 | ||
26 | ||
0d863452 | 27 | use feature 'switch'; |
0d863452 RH |
28 | |
29 | eval { continue }; | |
30 | like($@, qr/^Can't "continue" outside/, "continue outside"); | |
31 | ||
32 | eval { break }; | |
33 | like($@, qr/^Can't "break" outside/, "break outside"); | |
34 | ||
35 | # Scoping rules | |
36 | ||
37 | { | |
38 | my $x = "foo"; | |
39 | given(my $x = "bar") { | |
40 | is($x, "bar", "given scope starts"); | |
41 | } | |
42 | is($x, "foo", "given scope ends"); | |
43 | } | |
44 | ||
45 | sub be_true {1} | |
46 | ||
47 | given(my $x = "foo") { | |
48 | when(be_true(my $x = "bar")) { | |
49 | is($x, "bar", "given scope starts"); | |
50 | } | |
51 | is($x, "foo", "given scope ends"); | |
52 | } | |
53 | ||
54 | $_ = "outside"; | |
55 | given("inside") { check_outside1() } | |
b5a64814 | 56 | sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") } |
0d863452 RH |
57 | |
58 | { | |
dcd695b6 | 59 | no warnings 'experimental::lexical_topic'; |
0d863452 RH |
60 | my $_ = "outside"; |
61 | given("inside") { check_outside2() } | |
62 | sub check_outside2 { | |
63 | is($_, "outside", "\$_ lexically scoped (lexical \$_)") | |
64 | } | |
65 | } | |
66 | ||
67 | # Basic string/numeric comparisons and control flow | |
68 | ||
69 | { | |
cd9c531b | 70 | my $ok; |
0d863452 | 71 | given(3) { |
cd9c531b NC |
72 | when(2) { $ok = 'two'; } |
73 | when(3) { $ok = 'three'; } | |
74 | when(4) { $ok = 'four'; } | |
75 | default { $ok = 'd'; } | |
0d863452 | 76 | } |
cd9c531b | 77 | is($ok, 'three', "numeric comparison"); |
0d863452 RH |
78 | } |
79 | ||
80 | { | |
cd9c531b | 81 | my $ok; |
0d863452 RH |
82 | use integer; |
83 | given(3.14159265) { | |
cd9c531b NC |
84 | when(2) { $ok = 'two'; } |
85 | when(3) { $ok = 'three'; } | |
86 | when(4) { $ok = 'four'; } | |
87 | default { $ok = 'd'; } | |
0d863452 | 88 | } |
cd9c531b | 89 | is($ok, 'three', "integer comparison"); |
0d863452 RH |
90 | } |
91 | ||
92 | { | |
cd9c531b | 93 | my ($ok1, $ok2); |
0d863452 | 94 | given(3) { |
cd9c531b NC |
95 | when(3.1) { $ok1 = 'n'; } |
96 | when(3.0) { $ok1 = 'y'; continue } | |
97 | when("3.0") { $ok2 = 'y'; } | |
98 | default { $ok2 = 'n'; } | |
0d863452 | 99 | } |
cd9c531b NC |
100 | is($ok1, 'y', "more numeric (pt. 1)"); |
101 | is($ok2, 'y', "more numeric (pt. 2)"); | |
0d863452 RH |
102 | } |
103 | ||
104 | { | |
cd9c531b | 105 | my $ok; |
0d863452 | 106 | given("c") { |
cd9c531b NC |
107 | when("b") { $ok = 'B'; } |
108 | when("c") { $ok = 'C'; } | |
109 | when("d") { $ok = 'D'; } | |
110 | default { $ok = 'def'; } | |
0d863452 | 111 | } |
cd9c531b | 112 | is($ok, 'C', "string comparison"); |
0d863452 RH |
113 | } |
114 | ||
115 | { | |
cd9c531b | 116 | my $ok; |
0d863452 | 117 | given("c") { |
cd9c531b NC |
118 | when("b") { $ok = 'B'; } |
119 | when("c") { $ok = 'C'; continue } | |
120 | when("c") { $ok = 'CC'; } | |
121 | default { $ok = 'D'; } | |
0d863452 | 122 | } |
cd9c531b | 123 | is($ok, 'CC', "simple continue"); |
0d863452 RH |
124 | } |
125 | ||
126 | # Definedness | |
127 | { | |
128 | my $ok = 1; | |
129 | given (0) { when(undef) {$ok = 0} } | |
cd9c531b | 130 | is($ok, 1, "Given(0) when(undef)"); |
0d863452 RH |
131 | } |
132 | { | |
133 | my $undef; | |
134 | my $ok = 1; | |
135 | given (0) { when($undef) {$ok = 0} } | |
cd9c531b | 136 | is($ok, 1, 'Given(0) when($undef)'); |
0d863452 RH |
137 | } |
138 | { | |
139 | my $undef; | |
140 | my $ok = 0; | |
141 | given (0) { when($undef++) {$ok = 1} } | |
cd9c531b | 142 | is($ok, 1, "Given(0) when($undef++)"); |
0d863452 RH |
143 | } |
144 | { | |
62ec5f58 | 145 | no warnings "uninitialized"; |
fb51372e RGS |
146 | my $ok = 1; |
147 | given (undef) { when(0) {$ok = 0} } | |
cd9c531b | 148 | is($ok, 1, "Given(undef) when(0)"); |
0d863452 RH |
149 | } |
150 | { | |
62ec5f58 | 151 | no warnings "uninitialized"; |
0d863452 | 152 | my $undef; |
fb51372e RGS |
153 | my $ok = 1; |
154 | given ($undef) { when(0) {$ok = 0} } | |
cd9c531b | 155 | is($ok, 1, 'Given($undef) when(0)'); |
0d863452 RH |
156 | } |
157 | ######## | |
158 | { | |
159 | my $ok = 1; | |
160 | given ("") { when(undef) {$ok = 0} } | |
cd9c531b | 161 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 RH |
162 | } |
163 | { | |
164 | my $undef; | |
165 | my $ok = 1; | |
166 | given ("") { when($undef) {$ok = 0} } | |
cd9c531b | 167 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 RH |
168 | } |
169 | { | |
62ec5f58 | 170 | no warnings "uninitialized"; |
fb51372e RGS |
171 | my $ok = 1; |
172 | given (undef) { when("") {$ok = 0} } | |
cd9c531b | 173 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 RH |
174 | } |
175 | { | |
62ec5f58 | 176 | no warnings "uninitialized"; |
0d863452 | 177 | my $undef; |
fb51372e RGS |
178 | my $ok = 1; |
179 | given ($undef) { when("") {$ok = 0} } | |
cd9c531b | 180 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 RH |
181 | } |
182 | ######## | |
183 | { | |
184 | my $ok = 0; | |
185 | given (undef) { when(undef) {$ok = 1} } | |
cd9c531b | 186 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 RH |
187 | } |
188 | { | |
189 | my $undef; | |
190 | my $ok = 0; | |
191 | given (undef) { when($undef) {$ok = 1} } | |
cd9c531b | 192 | is($ok, 1, 'Given(undef) when($undef)'); |
0d863452 RH |
193 | } |
194 | { | |
195 | my $undef; | |
196 | my $ok = 0; | |
197 | given ($undef) { when(undef) {$ok = 1} } | |
cd9c531b | 198 | is($ok, 1, 'Given($undef) when(undef)'); |
0d863452 RH |
199 | } |
200 | { | |
201 | my $undef; | |
202 | my $ok = 0; | |
203 | given ($undef) { when($undef) {$ok = 1} } | |
cd9c531b | 204 | is($ok, 1, 'Given($undef) when($undef)'); |
0d863452 RH |
205 | } |
206 | ||
207 | ||
208 | # Regular expressions | |
209 | { | |
cd9c531b | 210 | my ($ok1, $ok2); |
0d863452 RH |
211 | given("Hello, world!") { |
212 | when(/lo/) | |
cd9c531b | 213 | { $ok1 = 'y'; continue} |
0d863452 | 214 | when(/no/) |
cd9c531b | 215 | { $ok1 = 'n'; continue} |
0d863452 | 216 | when(/^(Hello,|Goodbye cruel) world[!.?]/) |
cd9c531b | 217 | { $ok2 = 'Y'; continue} |
0d863452 | 218 | when(/^(Hello cruel|Goodbye,) world[!.?]/) |
cd9c531b | 219 | { $ok2 = 'n'; continue} |
0d863452 | 220 | } |
cd9c531b NC |
221 | is($ok1, 'y', "regex 1"); |
222 | is($ok2, 'Y', "regex 2"); | |
0d863452 RH |
223 | } |
224 | ||
225 | # Comparisons | |
226 | { | |
227 | my $test = "explicit numeric comparison (<)"; | |
228 | my $twenty_five = 25; | |
cd9c531b | 229 | my $ok; |
0d863452 | 230 | given($twenty_five) { |
cd9c531b NC |
231 | when ($_ < 10) { $ok = "ten" } |
232 | when ($_ < 20) { $ok = "twenty" } | |
233 | when ($_ < 30) { $ok = "thirty" } | |
234 | when ($_ < 40) { $ok = "forty" } | |
235 | default { $ok = "default" } | |
0d863452 | 236 | } |
cd9c531b | 237 | is($ok, "thirty", $test); |
0d863452 RH |
238 | } |
239 | ||
240 | { | |
241 | use integer; | |
242 | my $test = "explicit numeric comparison (integer <)"; | |
243 | my $twenty_five = 25; | |
cd9c531b | 244 | my $ok; |
0d863452 | 245 | given($twenty_five) { |
cd9c531b NC |
246 | when ($_ < 10) { $ok = "ten" } |
247 | when ($_ < 20) { $ok = "twenty" } | |
248 | when ($_ < 30) { $ok = "thirty" } | |
249 | when ($_ < 40) { $ok = "forty" } | |
250 | default { $ok = "default" } | |
0d863452 | 251 | } |
cd9c531b | 252 | is($ok, "thirty", $test); |
0d863452 RH |
253 | } |
254 | ||
255 | { | |
256 | my $test = "explicit numeric comparison (<=)"; | |
257 | my $twenty_five = 25; | |
cd9c531b | 258 | my $ok; |
0d863452 | 259 | given($twenty_five) { |
cd9c531b NC |
260 | when ($_ <= 10) { $ok = "ten" } |
261 | when ($_ <= 20) { $ok = "twenty" } | |
262 | when ($_ <= 30) { $ok = "thirty" } | |
263 | when ($_ <= 40) { $ok = "forty" } | |
264 | default { $ok = "default" } | |
0d863452 | 265 | } |
cd9c531b | 266 | is($ok, "thirty", $test); |
0d863452 RH |
267 | } |
268 | ||
269 | { | |
270 | use integer; | |
271 | my $test = "explicit numeric comparison (integer <=)"; | |
272 | my $twenty_five = 25; | |
cd9c531b | 273 | my $ok; |
0d863452 | 274 | given($twenty_five) { |
cd9c531b NC |
275 | when ($_ <= 10) { $ok = "ten" } |
276 | when ($_ <= 20) { $ok = "twenty" } | |
277 | when ($_ <= 30) { $ok = "thirty" } | |
278 | when ($_ <= 40) { $ok = "forty" } | |
279 | default { $ok = "default" } | |
0d863452 | 280 | } |
cd9c531b | 281 | is($ok, "thirty", $test); |
0d863452 RH |
282 | } |
283 | ||
284 | ||
285 | { | |
286 | my $test = "explicit numeric comparison (>)"; | |
287 | my $twenty_five = 25; | |
cd9c531b | 288 | my $ok; |
0d863452 | 289 | given($twenty_five) { |
cd9c531b NC |
290 | when ($_ > 40) { $ok = "forty" } |
291 | when ($_ > 30) { $ok = "thirty" } | |
292 | when ($_ > 20) { $ok = "twenty" } | |
293 | when ($_ > 10) { $ok = "ten" } | |
294 | default { $ok = "default" } | |
0d863452 | 295 | } |
cd9c531b | 296 | is($ok, "twenty", $test); |
0d863452 RH |
297 | } |
298 | ||
299 | { | |
300 | my $test = "explicit numeric comparison (>=)"; | |
301 | my $twenty_five = 25; | |
cd9c531b | 302 | my $ok; |
0d863452 | 303 | given($twenty_five) { |
cd9c531b NC |
304 | when ($_ >= 40) { $ok = "forty" } |
305 | when ($_ >= 30) { $ok = "thirty" } | |
306 | when ($_ >= 20) { $ok = "twenty" } | |
307 | when ($_ >= 10) { $ok = "ten" } | |
308 | default { $ok = "default" } | |
0d863452 | 309 | } |
cd9c531b | 310 | is($ok, "twenty", $test); |
0d863452 RH |
311 | } |
312 | ||
313 | { | |
314 | use integer; | |
315 | my $test = "explicit numeric comparison (integer >)"; | |
316 | my $twenty_five = 25; | |
cd9c531b | 317 | my $ok; |
0d863452 | 318 | given($twenty_five) { |
cd9c531b NC |
319 | when ($_ > 40) { $ok = "forty" } |
320 | when ($_ > 30) { $ok = "thirty" } | |
321 | when ($_ > 20) { $ok = "twenty" } | |
322 | when ($_ > 10) { $ok = "ten" } | |
323 | default { $ok = "default" } | |
0d863452 | 324 | } |
cd9c531b | 325 | is($ok, "twenty", $test); |
0d863452 RH |
326 | } |
327 | ||
328 | { | |
329 | use integer; | |
330 | my $test = "explicit numeric comparison (integer >=)"; | |
331 | my $twenty_five = 25; | |
cd9c531b | 332 | my $ok; |
0d863452 | 333 | given($twenty_five) { |
cd9c531b NC |
334 | when ($_ >= 40) { $ok = "forty" } |
335 | when ($_ >= 30) { $ok = "thirty" } | |
336 | when ($_ >= 20) { $ok = "twenty" } | |
337 | when ($_ >= 10) { $ok = "ten" } | |
338 | default { $ok = "default" } | |
0d863452 | 339 | } |
cd9c531b | 340 | is($ok, "twenty", $test); |
0d863452 RH |
341 | } |
342 | ||
343 | ||
344 | { | |
345 | my $test = "explicit string comparison (lt)"; | |
346 | my $twenty_five = "25"; | |
cd9c531b | 347 | my $ok; |
0d863452 | 348 | given($twenty_five) { |
cd9c531b NC |
349 | when ($_ lt "10") { $ok = "ten" } |
350 | when ($_ lt "20") { $ok = "twenty" } | |
351 | when ($_ lt "30") { $ok = "thirty" } | |
352 | when ($_ lt "40") { $ok = "forty" } | |
353 | default { $ok = "default" } | |
0d863452 | 354 | } |
cd9c531b | 355 | is($ok, "thirty", $test); |
0d863452 RH |
356 | } |
357 | ||
358 | { | |
359 | my $test = "explicit string comparison (le)"; | |
360 | my $twenty_five = "25"; | |
cd9c531b | 361 | my $ok; |
0d863452 | 362 | given($twenty_five) { |
cd9c531b NC |
363 | when ($_ le "10") { $ok = "ten" } |
364 | when ($_ le "20") { $ok = "twenty" } | |
365 | when ($_ le "30") { $ok = "thirty" } | |
366 | when ($_ le "40") { $ok = "forty" } | |
367 | default { $ok = "default" } | |
0d863452 | 368 | } |
cd9c531b | 369 | is($ok, "thirty", $test); |
0d863452 RH |
370 | } |
371 | ||
372 | { | |
373 | my $test = "explicit string comparison (gt)"; | |
374 | my $twenty_five = 25; | |
cd9c531b | 375 | my $ok; |
0d863452 | 376 | given($twenty_five) { |
cd9c531b NC |
377 | when ($_ ge "40") { $ok = "forty" } |
378 | when ($_ ge "30") { $ok = "thirty" } | |
379 | when ($_ ge "20") { $ok = "twenty" } | |
380 | when ($_ ge "10") { $ok = "ten" } | |
381 | default { $ok = "default" } | |
0d863452 | 382 | } |
cd9c531b | 383 | is($ok, "twenty", $test); |
0d863452 RH |
384 | } |
385 | ||
386 | { | |
387 | my $test = "explicit string comparison (ge)"; | |
388 | my $twenty_five = 25; | |
cd9c531b | 389 | my $ok; |
0d863452 | 390 | given($twenty_five) { |
cd9c531b NC |
391 | when ($_ ge "40") { $ok = "forty" } |
392 | when ($_ ge "30") { $ok = "thirty" } | |
393 | when ($_ ge "20") { $ok = "twenty" } | |
394 | when ($_ ge "10") { $ok = "ten" } | |
395 | default { $ok = "default" } | |
0d863452 | 396 | } |
cd9c531b | 397 | is($ok, "twenty", $test); |
0d863452 RH |
398 | } |
399 | ||
400 | # Make sure it still works with a lexical $_: | |
401 | { | |
dcd695b6 | 402 | no warnings 'experimental::lexical_topic'; |
0d863452 RH |
403 | my $_; |
404 | my $test = "explicit comparison with lexical \$_"; | |
405 | my $twenty_five = 25; | |
cd9c531b | 406 | my $ok; |
0d863452 | 407 | given($twenty_five) { |
cd9c531b NC |
408 | when ($_ ge "40") { $ok = "forty" } |
409 | when ($_ ge "30") { $ok = "thirty" } | |
410 | when ($_ ge "20") { $ok = "twenty" } | |
411 | when ($_ ge "10") { $ok = "ten" } | |
412 | default { $ok = "default" } | |
0d863452 | 413 | } |
cd9c531b | 414 | is($ok, "twenty", $test); |
0d863452 RH |
415 | } |
416 | ||
417 | # Optimized-away comparisons | |
418 | { | |
cd9c531b | 419 | my $ok; |
0d863452 | 420 | given(23) { |
cd9c531b NC |
421 | when (2 + 2 == 4) { $ok = 'y'; continue } |
422 | when (2 + 2 == 5) { $ok = 'n' } | |
0d863452 | 423 | } |
cd9c531b | 424 | is($ok, 'y', "Optimized-away comparison"); |
0d863452 RH |
425 | } |
426 | ||
5341b2b7 JJ |
427 | { |
428 | my $ok; | |
429 | given(23) { | |
430 | when (scalar 24) { $ok = 'n'; continue } | |
431 | default { $ok = 'y' } | |
432 | } | |
433 | is($ok,'y','scalar()'); | |
434 | } | |
435 | ||
0d863452 RH |
436 | # File tests |
437 | # (How to be both thorough and portable? Pinch a few ideas | |
438 | # from t/op/filetest.t. We err on the side of portability for | |
439 | # the time being.) | |
440 | ||
441 | { | |
442 | my ($ok_d, $ok_f, $ok_r); | |
443 | given("op") { | |
444 | when(-d) {$ok_d = 1; continue} | |
445 | when(!-f) {$ok_f = 1; continue} | |
446 | when(-r) {$ok_r = 1; continue} | |
447 | } | |
448 | ok($ok_d, "Filetest -d"); | |
449 | ok($ok_f, "Filetest -f"); | |
450 | ok($ok_r, "Filetest -r"); | |
451 | } | |
452 | ||
453 | # Sub and method calls | |
84c82fbf | 454 | sub notfoo {"bar"} |
0d863452 RH |
455 | { |
456 | my $ok = 0; | |
457 | given("foo") { | |
84c82fbf | 458 | when(notfoo()) {$ok = 1} |
0d863452 RH |
459 | } |
460 | ok($ok, "Sub call acts as boolean") | |
461 | } | |
462 | ||
463 | { | |
464 | my $ok = 0; | |
465 | given("foo") { | |
84c82fbf | 466 | when(main->notfoo()) {$ok = 1} |
0d863452 RH |
467 | } |
468 | ok($ok, "Class-method call acts as boolean") | |
469 | } | |
470 | ||
471 | { | |
472 | my $ok = 0; | |
473 | my $obj = bless []; | |
474 | given("foo") { | |
84c82fbf | 475 | when($obj->notfoo()) {$ok = 1} |
0d863452 RH |
476 | } |
477 | ok($ok, "Object-method call acts as boolean") | |
478 | } | |
479 | ||
480 | # Other things that should not be smart matched | |
481 | { | |
482 | my $ok = 0; | |
1e1d4b91 JJ |
483 | given(12) { |
484 | when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { | |
485 | $ok = 1; | |
486 | } | |
487 | } | |
488 | ok($ok, "bool not smartmatches"); | |
489 | } | |
490 | ||
491 | { | |
492 | my $ok = 0; | |
0d863452 RH |
493 | given(0) { |
494 | when(eof(DATA)) { | |
495 | $ok = 1; | |
496 | } | |
497 | } | |
498 | ok($ok, "eof() not smartmatched"); | |
499 | } | |
500 | ||
501 | { | |
502 | my $ok = 0; | |
503 | my %foo = ("bar", 0); | |
504 | given(0) { | |
505 | when(exists $foo{bar}) { | |
506 | $ok = 1; | |
507 | } | |
508 | } | |
509 | ok($ok, "exists() not smartmatched"); | |
510 | } | |
511 | ||
512 | { | |
513 | my $ok = 0; | |
514 | given(0) { | |
515 | when(defined $ok) { | |
516 | $ok = 1; | |
517 | } | |
518 | } | |
519 | ok($ok, "defined() not smartmatched"); | |
520 | } | |
521 | ||
522 | { | |
523 | my $ok = 1; | |
524 | given("foo") { | |
525 | when((1 == 1) && "bar") { | |
526 | $ok = 0; | |
527 | } | |
528 | when((1 == 1) && $_ eq "foo") { | |
529 | $ok = 2; | |
530 | } | |
531 | } | |
532 | is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); | |
533 | } | |
534 | ||
535 | { | |
6e03d743 | 536 | my $n = 0; |
ea25a9b2 | 537 | for my $l (qw(a b c d)) { |
6e03d743 | 538 | given ($l) { |
f118ea0d RGS |
539 | when ($_ eq "b" .. $_ eq "c") { $n = 1 } |
540 | default { $n = 0 } | |
541 | } | |
542 | ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context'); | |
543 | } | |
544 | } | |
545 | ||
546 | { | |
547 | my $n = 0; | |
ea25a9b2 | 548 | for my $l (qw(a b c d)) { |
f118ea0d | 549 | given ($l) { |
6e03d743 RGS |
550 | when ($_ eq "b" ... $_ eq "c") { $n = 1 } |
551 | default { $n = 0 } | |
552 | } | |
553 | ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context'); | |
554 | } | |
555 | } | |
556 | ||
557 | { | |
1e1d4b91 JJ |
558 | my $ok = 0; |
559 | given("foo") { | |
0d863452 | 560 | when((1 == $ok) || "foo") { |
1e1d4b91 | 561 | $ok = 1; |
0d863452 RH |
562 | } |
563 | } | |
1e1d4b91 | 564 | ok($ok, '((1 == $ok) || "foo") smartmatched'); |
0d863452 RH |
565 | } |
566 | ||
f92e1a16 RGS |
567 | { |
568 | my $ok = 0; | |
569 | given("foo") { | |
570 | when((1 == $ok || undef) // "foo") { | |
571 | $ok = 1; | |
572 | } | |
573 | } | |
574 | ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); | |
575 | } | |
576 | ||
0d863452 RH |
577 | # Make sure we aren't invoking the get-magic more than once |
578 | ||
579 | { # A helper class to count the number of accesses. | |
580 | package FetchCounter; | |
581 | sub TIESCALAR { | |
582 | my ($class) = @_; | |
583 | bless {value => undef, count => 0}, $class; | |
584 | } | |
585 | sub STORE { | |
586 | my ($self, $val) = @_; | |
587 | $self->{count} = 0; | |
588 | $self->{value} = $val; | |
589 | } | |
590 | sub FETCH { | |
591 | my ($self) = @_; | |
592 | # Avoid pre/post increment here | |
593 | $self->{count} = 1 + $self->{count}; | |
594 | $self->{value}; | |
595 | } | |
596 | sub count { | |
597 | my ($self) = @_; | |
598 | $self->{count}; | |
599 | } | |
600 | } | |
601 | ||
602 | my $f = tie my $v, "FetchCounter"; | |
603 | ||
b5a64814 | 604 | { my $test_name = "Multiple FETCHes in given, due to aliasing"; |
cd9c531b | 605 | my $ok; |
0d863452 RH |
606 | given($v = 23) { |
607 | when(undef) {} | |
608 | when(sub{0}->()) {} | |
609 | when(21) {} | |
610 | when("22") {} | |
611 | when(23) {$ok = 1} | |
612 | when(/24/) {$ok = 0} | |
613 | } | |
cd9c531b | 614 | is($ok, 1, "precheck: $test_name"); |
b5a64814 | 615 | is($f->count(), 4, $test_name); |
0d863452 RH |
616 | } |
617 | ||
618 | { my $test_name = "Only one FETCH (numeric when)"; | |
cd9c531b | 619 | my $ok; |
0d863452 RH |
620 | $v = 23; |
621 | is($f->count(), 0, "Sanity check: $test_name"); | |
622 | given(23) { | |
623 | when(undef) {} | |
624 | when(sub{0}->()) {} | |
625 | when(21) {} | |
626 | when("22") {} | |
627 | when($v) {$ok = 1} | |
628 | when(/24/) {$ok = 0} | |
629 | } | |
cd9c531b | 630 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
631 | is($f->count(), 1, $test_name); |
632 | } | |
633 | ||
634 | { my $test_name = "Only one FETCH (string when)"; | |
cd9c531b | 635 | my $ok; |
0d863452 RH |
636 | $v = "23"; |
637 | is($f->count(), 0, "Sanity check: $test_name"); | |
638 | given("23") { | |
639 | when(undef) {} | |
640 | when(sub{0}->()) {} | |
641 | when("21") {} | |
642 | when("22") {} | |
643 | when($v) {$ok = 1} | |
644 | when(/24/) {$ok = 0} | |
645 | } | |
cd9c531b | 646 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
647 | is($f->count(), 1, $test_name); |
648 | } | |
649 | ||
650 | { my $test_name = "Only one FETCH (undef)"; | |
cd9c531b | 651 | my $ok; |
0d863452 RH |
652 | $v = undef; |
653 | is($f->count(), 0, "Sanity check: $test_name"); | |
62ec5f58 | 654 | no warnings "uninitialized"; |
0d863452 RH |
655 | given(my $undef) { |
656 | when(sub{0}->()) {} | |
657 | when("21") {} | |
658 | when("22") {} | |
659 | when($v) {$ok = 1} | |
660 | when(undef) {$ok = 0} | |
661 | } | |
cd9c531b | 662 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
663 | is($f->count(), 1, $test_name); |
664 | } | |
665 | ||
666 | # Loop topicalizer | |
667 | { | |
668 | my $first = 1; | |
669 | for (1, "two") { | |
670 | when ("two") { | |
671 | is($first, 0, "Loop: second"); | |
672 | eval {break}; | |
673 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
674 | q{Can't "break" in a loop topicalizer}); | |
675 | } | |
676 | when (1) { | |
677 | is($first, 1, "Loop: first"); | |
678 | $first = 0; | |
679 | # Implicit break is okay | |
680 | } | |
681 | } | |
682 | } | |
683 | ||
684 | { | |
685 | my $first = 1; | |
686 | for $_ (1, "two") { | |
687 | when ("two") { | |
688 | is($first, 0, "Explicit \$_: second"); | |
689 | eval {break}; | |
690 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
691 | q{Can't "break" in a loop topicalizer}); | |
692 | } | |
693 | when (1) { | |
694 | is($first, 1, "Explicit \$_: first"); | |
695 | $first = 0; | |
696 | # Implicit break is okay | |
697 | } | |
698 | } | |
699 | } | |
700 | ||
701 | { | |
702 | my $first = 1; | |
dcd695b6 | 703 | no warnings 'experimental::lexical_topic'; |
0d863452 RH |
704 | my $_; |
705 | for (1, "two") { | |
706 | when ("two") { | |
707 | is($first, 0, "Implicitly lexical loop: second"); | |
708 | eval {break}; | |
709 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
710 | q{Can't "break" in a loop topicalizer}); | |
711 | } | |
712 | when (1) { | |
713 | is($first, 1, "Implicitly lexical loop: first"); | |
714 | $first = 0; | |
715 | # Implicit break is okay | |
716 | } | |
717 | } | |
718 | } | |
719 | ||
720 | { | |
721 | my $first = 1; | |
dcd695b6 | 722 | no warnings 'experimental::lexical_topic'; |
0d863452 RH |
723 | my $_; |
724 | for $_ (1, "two") { | |
725 | when ("two") { | |
726 | is($first, 0, "Implicitly lexical, explicit \$_: second"); | |
727 | eval {break}; | |
728 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
729 | q{Can't "break" in a loop topicalizer}); | |
730 | } | |
731 | when (1) { | |
732 | is($first, 1, "Implicitly lexical, explicit \$_: first"); | |
733 | $first = 0; | |
734 | # Implicit break is okay | |
735 | } | |
736 | } | |
737 | } | |
738 | ||
739 | { | |
740 | my $first = 1; | |
dcd695b6 | 741 | no warnings 'experimental::lexical_topic'; |
0d863452 RH |
742 | for my $_ (1, "two") { |
743 | when ("two") { | |
744 | is($first, 0, "Lexical loop: second"); | |
745 | eval {break}; | |
746 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
747 | q{Can't "break" in a loop topicalizer}); | |
748 | } | |
749 | when (1) { | |
1dcb720a | 750 | is($first, 1, "Lexical loop: first"); |
0d863452 RH |
751 | $first = 0; |
752 | # Implicit break is okay | |
753 | } | |
754 | } | |
755 | } | |
756 | ||
757 | ||
758 | # Code references | |
759 | { | |
0d863452 | 760 | my $called_foo = 0; |
84c82fbf | 761 | sub foo {$called_foo = 1; "@_" eq "foo"} |
0d863452 | 762 | my $called_bar = 0; |
84c82fbf | 763 | sub bar {$called_bar = 1; "@_" eq "bar"} |
0d863452 | 764 | my ($matched_foo, $matched_bar) = (0, 0); |
84c82fbf | 765 | given("foo") { |
0d863452 RH |
766 | when(\&bar) {$matched_bar = 1} |
767 | when(\&foo) {$matched_foo = 1} | |
768 | } | |
84c82fbf RGS |
769 | is($called_foo, 1, "foo() was called"); |
770 | is($called_bar, 1, "bar() was called"); | |
771 | is($matched_bar, 0, "bar didn't match"); | |
772 | is($matched_foo, 1, "foo did match"); | |
0d863452 RH |
773 | } |
774 | ||
775 | sub contains_x { | |
776 | my $x = shift; | |
777 | return ($x =~ /x/); | |
778 | } | |
779 | { | |
780 | my ($ok1, $ok2) = (0,0); | |
781 | given("foxy!") { | |
782 | when(contains_x($_)) | |
783 | { $ok1 = 1; continue } | |
784 | when(\&contains_x) | |
785 | { $ok2 = 1; continue } | |
786 | } | |
787 | is($ok1, 1, "Calling sub directly (true)"); | |
788 | is($ok2, 1, "Calling sub indirectly (true)"); | |
789 | ||
790 | given("foggy") { | |
791 | when(contains_x($_)) | |
792 | { $ok1 = 2; continue } | |
793 | when(\&contains_x) | |
794 | { $ok2 = 2; continue } | |
795 | } | |
796 | is($ok1, 1, "Calling sub directly (false)"); | |
797 | is($ok2, 1, "Calling sub indirectly (false)"); | |
798 | } | |
799 | ||
02eafbe2 | 800 | SKIP: { |
f6e0b6da | 801 | skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14); |
02eafbe2 DD |
802 | # Test overloading |
803 | { package OverloadTest; | |
804 | ||
805 | use overload '""' => sub{"string value of obj"}; | |
6d743019 | 806 | use overload 'eq' => sub{"$_[0]" eq "$_[1]"}; |
02eafbe2 DD |
807 | |
808 | use overload "~~" => sub { | |
809 | my ($self, $other, $reversed) = @_; | |
810 | if ($reversed) { | |
811 | $self->{left} = $other; | |
812 | $self->{right} = $self; | |
813 | $self->{reversed} = 1; | |
814 | } else { | |
815 | $self->{left} = $self; | |
816 | $self->{right} = $other; | |
817 | $self->{reversed} = 0; | |
818 | } | |
819 | $self->{called} = 1; | |
820 | return $self->{retval}; | |
821 | }; | |
0d863452 | 822 | |
02eafbe2 DD |
823 | sub new { |
824 | my ($pkg, $retval) = @_; | |
825 | bless { | |
826 | called => 0, | |
827 | retval => $retval, | |
828 | }, $pkg; | |
829 | } | |
830 | } | |
831 | ||
832 | { | |
833 | my $test = "Overloaded obj in given (true)"; | |
834 | my $obj = OverloadTest->new(1); | |
835 | my $matched; | |
836 | given($obj) { | |
837 | when ("other arg") {$matched = 1} | |
838 | default {$matched = 0} | |
839 | } | |
0d863452 | 840 | |
2cb9bde7 RGS |
841 | is($obj->{called}, 1, "$test: called"); |
842 | ok($matched, "$test: matched"); | |
02eafbe2 DD |
843 | } |
844 | ||
845 | { | |
846 | my $test = "Overloaded obj in given (false)"; | |
847 | my $obj = OverloadTest->new(0); | |
848 | my $matched; | |
849 | given($obj) { | |
850 | when ("other arg") {$matched = 1} | |
851 | } | |
0d863452 | 852 | |
2cb9bde7 | 853 | is($obj->{called}, 1, "$test: called"); |
02eafbe2 | 854 | ok(!$matched, "$test: not matched"); |
02eafbe2 DD |
855 | } |
856 | ||
857 | { | |
858 | my $test = "Overloaded obj in when (true)"; | |
859 | my $obj = OverloadTest->new(1); | |
860 | my $matched; | |
861 | given("topic") { | |
862 | when ($obj) {$matched = 1} | |
863 | default {$matched = 0} | |
864 | } | |
0d863452 | 865 | |
02eafbe2 DD |
866 | is($obj->{called}, 1, "$test: called"); |
867 | ok($matched, "$test: matched"); | |
868 | is($obj->{left}, "topic", "$test: left"); | |
869 | is($obj->{right}, "string value of obj", "$test: right"); | |
870 | ok($obj->{reversed}, "$test: reversed"); | |
871 | } | |
872 | ||
873 | { | |
874 | my $test = "Overloaded obj in when (false)"; | |
875 | my $obj = OverloadTest->new(0); | |
876 | my $matched; | |
877 | given("topic") { | |
878 | when ($obj) {$matched = 1} | |
879 | default {$matched = 0} | |
880 | } | |
0d863452 | 881 | |
02eafbe2 DD |
882 | is($obj->{called}, 1, "$test: called"); |
883 | ok(!$matched, "$test: not matched"); | |
884 | is($obj->{left}, "topic", "$test: left"); | |
885 | is($obj->{right}, "string value of obj", "$test: right"); | |
886 | ok($obj->{reversed}, "$test: reversed"); | |
887 | } | |
0d863452 | 888 | } |
f20dcd76 VP |
889 | |
890 | # Postfix when | |
891 | { | |
892 | my $ok; | |
893 | given (undef) { | |
894 | $ok = 1 when undef; | |
895 | } | |
896 | is($ok, 1, "postfix undef"); | |
897 | } | |
898 | { | |
899 | my $ok; | |
900 | given (2) { | |
901 | $ok += 1 when 7; | |
902 | $ok += 2 when 9.1685; | |
903 | $ok += 4 when $_ > 4; | |
904 | $ok += 8 when $_ < 2.5; | |
905 | } | |
906 | is($ok, 8, "postfix numeric"); | |
907 | } | |
908 | { | |
909 | my $ok; | |
910 | given ("apple") { | |
911 | $ok = 1, continue when $_ eq "apple"; | |
912 | $ok += 2; | |
913 | $ok = 0 when "banana"; | |
914 | } | |
915 | is($ok, 3, "postfix string"); | |
916 | } | |
917 | { | |
918 | my $ok; | |
919 | given ("pear") { | |
920 | do { $ok = 1; continue } when /pea/; | |
921 | $ok += 2; | |
922 | $ok = 0 when /pie/; | |
923 | default { $ok += 4 } | |
924 | $ok = 0; | |
925 | } | |
926 | is($ok, 7, "postfix regex"); | |
927 | } | |
928 | # be_true is defined at the beginning of the file | |
929 | { | |
930 | my $x = "what"; | |
931 | given(my $x = "foo") { | |
932 | do { | |
933 | is($x, "foo", "scope inside ... when my \$x = ..."); | |
934 | continue; | |
935 | } when be_true(my $x = "bar"); | |
936 | is($x, "bar", "scope after ... when my \$x = ..."); | |
937 | } | |
938 | } | |
939 | { | |
940 | my $x = 0; | |
941 | given(my $x = 1) { | |
942 | my $x = 2, continue when be_true(); | |
943 | is($x, undef, "scope after my \$x = ... when ..."); | |
944 | } | |
945 | } | |
946 | ||
1ebfab32 RGS |
947 | # Tests for last and next in when clauses |
948 | my $letter; | |
949 | ||
950 | $letter = ''; | |
951 | for ("a".."e") { | |
952 | given ($_) { | |
953 | $letter = $_; | |
954 | when ("b") { last } | |
955 | } | |
956 | $letter = "z"; | |
957 | } | |
958 | is($letter, "b", "last in when"); | |
959 | ||
960 | $letter = ''; | |
961 | LETTER1: for ("a".."e") { | |
962 | given ($_) { | |
963 | $letter = $_; | |
964 | when ("b") { last LETTER1 } | |
965 | } | |
966 | $letter = "z"; | |
967 | } | |
968 | is($letter, "b", "last LABEL in when"); | |
969 | ||
970 | $letter = ''; | |
971 | for ("a".."e") { | |
972 | given ($_) { | |
973 | when (/b|d/) { next } | |
974 | $letter .= $_; | |
975 | } | |
976 | $letter .= ','; | |
977 | } | |
978 | is($letter, "a,c,e,", "next in when"); | |
979 | ||
980 | $letter = ''; | |
981 | LETTER2: for ("a".."e") { | |
982 | given ($_) { | |
983 | when (/b|d/) { next LETTER2 } | |
984 | $letter .= $_; | |
985 | } | |
986 | $letter .= ','; | |
987 | } | |
988 | is($letter, "a,c,e,", "next LABEL in when"); | |
f20dcd76 | 989 | |
bb5aedc1 VP |
990 | # Test goto with given/when |
991 | { | |
992 | my $flag = 0; | |
993 | goto GIVEN1; | |
994 | $flag = 1; | |
995 | GIVEN1: given ($flag) { | |
996 | when (0) { break; } | |
997 | $flag = 2; | |
998 | } | |
999 | is($flag, 0, "goto GIVEN1"); | |
1000 | } | |
1001 | { | |
1002 | my $flag = 0; | |
1003 | given ($flag) { | |
1004 | when (0) { $flag = 1; } | |
1005 | goto GIVEN2; | |
1006 | $flag = 2; | |
1007 | } | |
1008 | GIVEN2: | |
1009 | is($flag, 1, "goto inside given"); | |
1010 | } | |
1011 | { | |
1012 | my $flag = 0; | |
1013 | given ($flag) { | |
1014 | when (0) { $flag = 1; goto GIVEN3; $flag = 2; } | |
1015 | $flag = 3; | |
1016 | } | |
1017 | GIVEN3: | |
1018 | is($flag, 1, "goto inside given and when"); | |
1019 | } | |
1020 | { | |
1021 | my $flag = 0; | |
1022 | for ($flag) { | |
1023 | when (0) { $flag = 1; goto GIVEN4; $flag = 2; } | |
1024 | $flag = 3; | |
1025 | } | |
1026 | GIVEN4: | |
1027 | is($flag, 1, "goto inside for and when"); | |
1028 | } | |
1029 | { | |
1030 | my $flag = 0; | |
1031 | GIVEN5: | |
1032 | given ($flag) { | |
1033 | when (0) { $flag = 1; goto GIVEN5; $flag = 2; } | |
1034 | when (1) { break; } | |
1035 | $flag = 3; | |
1036 | } | |
1037 | is($flag, 1, "goto inside given and when to the given stmt"); | |
1038 | } | |
1039 | ||
69c3dccf RGS |
1040 | # test with unreified @_ in smart match [perl #71078] |
1041 | sub unreified_check { ok([@_] ~~ \@_) } # should always match | |
1042 | unreified_check(1,2,"lala"); | |
1043 | unreified_check(1,2,undef); | |
1044 | unreified_check(undef); | |
1045 | unreified_check(undef,""); | |
1046 | ||
25b991bf VP |
1047 | # Test do { given } as a rvalue |
1048 | ||
1049 | { | |
1050 | # Simple scalar | |
1051 | my $lexical = 5; | |
1052 | my @things = (11 .. 26); # 16 elements | |
1053 | my @exp = (5, 16, 9); | |
1054 | no warnings 'void'; | |
1055 | for (0, 1, 2) { | |
1056 | my $scalar = do { given ($_) { | |
1057 | when (0) { $lexical } | |
1058 | when (2) { 'void'; 8, 9 } | |
1059 | @things; | |
1060 | } }; | |
1061 | is($scalar, shift(@exp), "rvalue given - simple scalar [$_]"); | |
1062 | } | |
1063 | } | |
1064 | { | |
1065 | # Postfix scalar | |
1066 | my $lexical = 5; | |
1067 | my @exp = (5, 7, 9); | |
1068 | for (0, 1, 2) { | |
1069 | no warnings 'void'; | |
1070 | my $scalar = do { given ($_) { | |
1071 | $lexical when 0; | |
1072 | 8, 9 when 2; | |
1073 | 6, 7; | |
1074 | } }; | |
1075 | is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]"); | |
1076 | } | |
1077 | } | |
1078 | { | |
1079 | # Default scalar | |
1080 | my @exp = (5, 9, 9); | |
1081 | for (0, 1, 2) { | |
1082 | my $scalar = do { given ($_) { | |
1083 | no warnings 'void'; | |
1084 | when (0) { 5 } | |
1085 | default { 8, 9 } | |
1086 | 6, 7; | |
1087 | } }; | |
1088 | is($scalar, shift(@exp), "rvalue given - default scalar [$_]"); | |
1089 | } | |
1090 | } | |
1091 | { | |
1092 | # Simple list | |
1093 | my @things = (11 .. 13); | |
1094 | my @exp = ('3 4 5', '11 12 13', '8 9'); | |
1095 | for (0, 1, 2) { | |
1096 | my @list = do { given ($_) { | |
1097 | when (0) { 3 .. 5 } | |
1098 | when (2) { my $fake = 'void'; 8, 9 } | |
1099 | @things; | |
1100 | } }; | |
1101 | is("@list", shift(@exp), "rvalue given - simple list [$_]"); | |
1102 | } | |
1103 | } | |
1104 | { | |
1105 | # Postfix list | |
1106 | my @things = (12); | |
1107 | my @exp = ('3 4 5', '6 7', '12'); | |
1108 | for (0, 1, 2) { | |
1109 | my @list = do { given ($_) { | |
1110 | 3 .. 5 when 0; | |
1111 | @things when 2; | |
1112 | 6, 7; | |
1113 | } }; | |
1114 | is("@list", shift(@exp), "rvalue given - postfix list [$_]"); | |
1115 | } | |
1116 | } | |
1117 | { | |
1118 | # Default list | |
1119 | my @things = (11 .. 20); # 10 elements | |
1120 | my @exp = ('m o o', '8 10', '8 10'); | |
1121 | for (0, 1, 2) { | |
1122 | my @list = do { given ($_) { | |
1123 | when (0) { "moo" =~ /(.)/g } | |
1124 | default { 8, scalar(@things) } | |
1125 | 6, 7; | |
1126 | } }; | |
1127 | is("@list", shift(@exp), "rvalue given - default list [$_]"); | |
1128 | } | |
1129 | } | |
1130 | { | |
1131 | # Switch control | |
1132 | my @exp = ('6 7', '', '6 7'); | |
1133 | for (0, 1, 2, 3) { | |
1134 | my @list = do { given ($_) { | |
1135 | continue when $_ <= 1; | |
1136 | break when 1; | |
1137 | next when 2; | |
1138 | 6, 7; | |
1139 | } }; | |
1140 | is("@list", shift(@exp), "rvalue given - default list [$_]"); | |
1141 | } | |
1142 | } | |
1143 | { | |
1144 | # Context propagation | |
1145 | my $smart_hash = sub { | |
1146 | do { given ($_[0]) { | |
1147 | 'undef' when undef; | |
1148 | when ([ 1 .. 3 ]) { 1 .. 3 } | |
1149 | when (4) { my $fake; do { 4, 5 } } | |
1150 | } }; | |
1151 | }; | |
1152 | ||
1153 | my $scalar; | |
1154 | ||
1155 | $scalar = $smart_hash->(); | |
1156 | is($scalar, 'undef', "rvalue given - scalar context propagation [undef]"); | |
1157 | ||
1158 | $scalar = $smart_hash->(4); | |
1159 | is($scalar, 5, "rvalue given - scalar context propagation [4]"); | |
1160 | ||
1161 | $scalar = $smart_hash->(999); | |
1162 | is($scalar, undef, "rvalue given - scalar context propagation [999]"); | |
1163 | ||
1164 | my @list; | |
1165 | ||
1166 | @list = $smart_hash->(); | |
1167 | is("@list", 'undef', "rvalue given - list context propagation [undef]"); | |
1168 | ||
1169 | @list = $smart_hash->(2); | |
1170 | is("@list", '1 2 3', "rvalue given - list context propagation [2]"); | |
1171 | ||
1172 | @list = $smart_hash->(4); | |
1173 | is("@list", '4 5', "rvalue given - list context propagation [4]"); | |
1174 | ||
1175 | @list = $smart_hash->(999); | |
1176 | is("@list", '', "rvalue given - list context propagation [999]"); | |
1177 | } | |
87f718f1 RGS |
1178 | { |
1179 | # Array slices | |
1180 | my @list = 10 .. 15; | |
1181 | my @in_list; | |
1182 | my @in_slice; | |
1183 | for (5, 10, 15) { | |
1184 | given ($_) { | |
1185 | when (@list) { | |
1186 | push @in_list, $_; | |
1187 | continue; | |
1188 | } | |
1189 | when (@list[0..2]) { | |
1190 | push @in_slice, $_; | |
1191 | } | |
1192 | } | |
1193 | } | |
1194 | is("@in_list", "10 15", "when(array)"); | |
1195 | is("@in_slice", "10", "when(array slice)"); | |
1196 | } | |
1197 | { | |
1198 | # Hash slices | |
1199 | my %list = map { $_ => $_ } "a" .. "f"; | |
1200 | my @in_list; | |
1201 | my @in_slice; | |
1202 | for ("a", "e", "i") { | |
1203 | given ($_) { | |
1204 | when (%list) { | |
1205 | push @in_list, $_; | |
1206 | continue; | |
1207 | } | |
1208 | when (@list{"a".."c"}) { | |
1209 | push @in_slice, $_; | |
1210 | } | |
1211 | } | |
1212 | } | |
1213 | is("@in_list", "a e", "when(hash)"); | |
1214 | is("@in_slice", "a", "when(hash slice)"); | |
1215 | } | |
25b991bf | 1216 | |
fad0c757 | 1217 | { # RT#84526 - Handle magical TARG |
fad0c757 EB |
1218 | my $x = my $y = "aaa"; |
1219 | for ($x, $y) { | |
1220 | given ($_) { | |
1221 | is(pos, undef, "handle magical TARG"); | |
1222 | pos = 1; | |
1223 | } | |
1224 | } | |
1225 | } | |
1226 | ||
c08f093b VP |
1227 | # Test that returned values are correctly propagated through several context |
1228 | # levels (see RT #93548). | |
1229 | { | |
1230 | my $tester = sub { | |
1231 | my $id = shift; | |
1232 | ||
1233 | package fmurrr; | |
1234 | ||
1235 | our ($when_loc, $given_loc, $ext_loc); | |
1236 | ||
1237 | my $ext_lex = 7; | |
1238 | our $ext_glob = 8; | |
1239 | local $ext_loc = 9; | |
1240 | ||
1241 | given ($id) { | |
1242 | my $given_lex = 4; | |
1243 | our $given_glob = 5; | |
1244 | local $given_loc = 6; | |
1245 | ||
1246 | when (0) { 0 } | |
1247 | ||
1248 | when (1) { my $when_lex = 1 } | |
1249 | when (2) { our $when_glob = 2 } | |
1250 | when (3) { local $when_loc = 3 } | |
1251 | ||
1252 | when (4) { $given_lex } | |
1253 | when (5) { $given_glob } | |
1254 | when (6) { $given_loc } | |
1255 | ||
1256 | when (7) { $ext_lex } | |
1257 | when (8) { $ext_glob } | |
1258 | when (9) { $ext_loc } | |
1259 | ||
1260 | 'fallback'; | |
1261 | } | |
1262 | }; | |
1263 | ||
1264 | my @descriptions = qw< | |
1265 | constant | |
1266 | ||
1267 | when-lexical | |
1268 | when-global | |
1269 | when-local | |
1270 | ||
1271 | given-lexical | |
1272 | given-global | |
1273 | given-local | |
1274 | ||
1275 | extern-lexical | |
1276 | extern-global | |
1277 | extern-local | |
1278 | >; | |
1279 | ||
1280 | for my $id (0 .. 9) { | |
1281 | my $desc = $descriptions[$id]; | |
1282 | ||
1283 | my $res = $tester->($id); | |
1284 | is $res, $id, "plain call - $desc"; | |
1285 | ||
1286 | $res = do { | |
1287 | my $id_plus_1 = $id + 1; | |
1288 | given ($id_plus_1) { | |
1289 | do { | |
1290 | when (/\d/) { | |
1291 | --$id_plus_1; | |
1292 | continue; | |
1293 | 456; | |
1294 | } | |
1295 | }; | |
1296 | default { | |
1297 | $tester->($id_plus_1); | |
1298 | } | |
1299 | 'XXX'; | |
1300 | } | |
1301 | }; | |
1302 | is $res, $id, "across continue and default - $desc"; | |
1303 | } | |
1304 | } | |
1305 | ||
1306 | # Check that values returned from given/when are destroyed at the right time. | |
1307 | { | |
1308 | { | |
1309 | package Fmurrr; | |
1310 | ||
1311 | sub new { | |
1312 | bless { | |
1313 | flag => \($_[1]), | |
1314 | id => $_[2], | |
1315 | }, $_[0] | |
1316 | } | |
1317 | ||
1318 | sub DESTROY { | |
1319 | ${$_[0]->{flag}}++; | |
1320 | } | |
1321 | } | |
1322 | ||
1323 | my @descriptions = qw< | |
1324 | when | |
1325 | break | |
1326 | continue | |
1327 | default | |
1328 | >; | |
1329 | ||
1330 | for my $id (0 .. 3) { | |
1331 | my $desc = $descriptions[$id]; | |
1332 | ||
1333 | my $destroyed = 0; | |
1334 | my $res_id; | |
1335 | ||
1336 | { | |
1337 | my $res = do { | |
1338 | given ($id) { | |
1339 | my $x; | |
1340 | when (0) { Fmurrr->new($destroyed, 0) } | |
1341 | when (1) { my $y = Fmurrr->new($destroyed, 1); break } | |
1342 | when (2) { $x = Fmurrr->new($destroyed, 2); continue } | |
1343 | when (2) { $x } | |
1344 | default { Fmurrr->new($destroyed, 3) } | |
1345 | } | |
1346 | }; | |
1347 | $res_id = $res->{id}; | |
1348 | } | |
1349 | $res_id = $id if $id == 1; # break doesn't return anything | |
1350 | ||
1351 | is $res_id, $id, "given/when returns the right object - $desc"; | |
1352 | is $destroyed, 1, "given/when does not leak - $desc"; | |
1353 | }; | |
1354 | } | |
1355 | ||
0787ea8a VP |
1356 | # break() must reset the stack |
1357 | { | |
1358 | my @res = (1, do { | |
1359 | given ("x") { | |
1360 | 2, 3, do { | |
1361 | when (/[a-z]/) { | |
1362 | 4, 5, 6, break | |
1363 | } | |
1364 | } | |
1365 | } | |
1366 | }); | |
1367 | is "@res", "1", "break resets the stack"; | |
1368 | } | |
1369 | ||
87e4a53a DM |
1370 | # RT #94682: |
1371 | # must ensure $_ is initialised and cleared at start/end of given block | |
1372 | ||
1373 | { | |
1374 | sub f1 { | |
dcd695b6 | 1375 | no warnings 'experimental::lexical_topic'; |
b5a64814 | 1376 | my $_; |
87e4a53a DM |
1377 | given(3) { |
1378 | return sub { $_ } # close over lexical $_ | |
1379 | } | |
1380 | } | |
1381 | is(f1()->(), 3, 'closed over $_'); | |
1382 | ||
1383 | package RT94682; | |
1384 | ||
1385 | my $d = 0; | |
1386 | sub DESTROY { $d++ }; | |
1387 | ||
1388 | sub f2 { | |
dcd695b6 | 1389 | no warnings 'experimental::lexical_topic'; |
87e4a53a DM |
1390 | my $_ = 5; |
1391 | given(bless [7]) { | |
1392 | ::is($_->[0], 7, "is [7]"); | |
1393 | } | |
1394 | ::is($_, 5, "is 5"); | |
1395 | ::is($d, 1, "DESTROY called once"); | |
1396 | } | |
1397 | f2(); | |
1398 | } | |
1399 | ||
1400 | ||
1401 | ||
0d863452 | 1402 | # Okay, that'll do for now. The intricacies of the smartmatch |
fa22d357 VP |
1403 | # semantics are tested in t/op/smartmatch.t. Taintedness of |
1404 | # returned values is checked in t/op/taint.t. | |
0d863452 | 1405 | __END__ |