Commit | Line | Data |
0d863452 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use strict; |
9 | use warnings; |
10 | |
f92e1a16 |
11 | use Test::More tests => 112; |
0d863452 |
12 | |
13 | # The behaviour of the feature pragma should be tested by lib/switch.t |
14 | # using the tests in t/lib/switch/*. This file tests the behaviour of |
15 | # the switch ops themselves. |
16 | |
17 | |
18 | use feature 'switch'; |
19 | no warnings "numeric"; |
20 | |
21 | eval { continue }; |
22 | like($@, qr/^Can't "continue" outside/, "continue outside"); |
23 | |
24 | eval { break }; |
25 | like($@, qr/^Can't "break" outside/, "break outside"); |
26 | |
27 | # Scoping rules |
28 | |
29 | { |
30 | my $x = "foo"; |
31 | given(my $x = "bar") { |
32 | is($x, "bar", "given scope starts"); |
33 | } |
34 | is($x, "foo", "given scope ends"); |
35 | } |
36 | |
37 | sub be_true {1} |
38 | |
39 | given(my $x = "foo") { |
40 | when(be_true(my $x = "bar")) { |
41 | is($x, "bar", "given scope starts"); |
42 | } |
43 | is($x, "foo", "given scope ends"); |
44 | } |
45 | |
46 | $_ = "outside"; |
47 | given("inside") { check_outside1() } |
48 | sub check_outside1 { is($_, "outside", "\$_ lexically scoped") } |
49 | |
50 | { |
51 | my $_ = "outside"; |
52 | given("inside") { check_outside2() } |
53 | sub check_outside2 { |
54 | is($_, "outside", "\$_ lexically scoped (lexical \$_)") |
55 | } |
56 | } |
57 | |
58 | # Basic string/numeric comparisons and control flow |
59 | |
60 | { |
cd9c531b |
61 | my $ok; |
0d863452 |
62 | given(3) { |
cd9c531b |
63 | when(2) { $ok = 'two'; } |
64 | when(3) { $ok = 'three'; } |
65 | when(4) { $ok = 'four'; } |
66 | default { $ok = 'd'; } |
0d863452 |
67 | } |
cd9c531b |
68 | is($ok, 'three', "numeric comparison"); |
0d863452 |
69 | } |
70 | |
71 | { |
cd9c531b |
72 | my $ok; |
0d863452 |
73 | use integer; |
74 | given(3.14159265) { |
cd9c531b |
75 | when(2) { $ok = 'two'; } |
76 | when(3) { $ok = 'three'; } |
77 | when(4) { $ok = 'four'; } |
78 | default { $ok = 'd'; } |
0d863452 |
79 | } |
cd9c531b |
80 | is($ok, 'three', "integer comparison"); |
0d863452 |
81 | } |
82 | |
83 | { |
cd9c531b |
84 | my ($ok1, $ok2); |
0d863452 |
85 | given(3) { |
cd9c531b |
86 | when(3.1) { $ok1 = 'n'; } |
87 | when(3.0) { $ok1 = 'y'; continue } |
88 | when("3.0") { $ok2 = 'y'; } |
89 | default { $ok2 = 'n'; } |
0d863452 |
90 | } |
cd9c531b |
91 | is($ok1, 'y', "more numeric (pt. 1)"); |
92 | is($ok2, 'y', "more numeric (pt. 2)"); |
0d863452 |
93 | } |
94 | |
95 | { |
cd9c531b |
96 | my $ok; |
0d863452 |
97 | given("c") { |
cd9c531b |
98 | when("b") { $ok = 'B'; } |
99 | when("c") { $ok = 'C'; } |
100 | when("d") { $ok = 'D'; } |
101 | default { $ok = 'def'; } |
0d863452 |
102 | } |
cd9c531b |
103 | is($ok, 'C', "string comparison"); |
0d863452 |
104 | } |
105 | |
106 | { |
cd9c531b |
107 | my $ok; |
0d863452 |
108 | given("c") { |
cd9c531b |
109 | when("b") { $ok = 'B'; } |
110 | when("c") { $ok = 'C'; continue } |
111 | when("c") { $ok = 'CC'; } |
112 | default { $ok = 'D'; } |
0d863452 |
113 | } |
cd9c531b |
114 | is($ok, 'CC', "simple continue"); |
0d863452 |
115 | } |
116 | |
117 | # Definedness |
118 | { |
119 | my $ok = 1; |
120 | given (0) { when(undef) {$ok = 0} } |
cd9c531b |
121 | is($ok, 1, "Given(0) when(undef)"); |
0d863452 |
122 | } |
123 | { |
124 | my $undef; |
125 | my $ok = 1; |
126 | given (0) { when($undef) {$ok = 0} } |
cd9c531b |
127 | is($ok, 1, 'Given(0) when($undef)'); |
0d863452 |
128 | } |
129 | { |
130 | my $undef; |
131 | my $ok = 0; |
132 | given (0) { when($undef++) {$ok = 1} } |
cd9c531b |
133 | is($ok, 1, "Given(0) when($undef++)"); |
0d863452 |
134 | } |
135 | { |
136 | my $ok = 1; |
137 | given (undef) { when(0) {$ok = 0} } |
cd9c531b |
138 | is($ok, 1, "Given(undef) when(0)"); |
0d863452 |
139 | } |
140 | { |
141 | my $undef; |
142 | my $ok = 1; |
143 | given ($undef) { when(0) {$ok = 0} } |
cd9c531b |
144 | is($ok, 1, 'Given($undef) when(0)'); |
0d863452 |
145 | } |
146 | ######## |
147 | { |
148 | my $ok = 1; |
149 | given ("") { when(undef) {$ok = 0} } |
cd9c531b |
150 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 |
151 | } |
152 | { |
153 | my $undef; |
154 | my $ok = 1; |
155 | given ("") { when($undef) {$ok = 0} } |
cd9c531b |
156 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 |
157 | } |
158 | { |
159 | my $ok = 1; |
160 | given (undef) { when("") {$ok = 0} } |
cd9c531b |
161 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 |
162 | } |
163 | { |
164 | my $undef; |
165 | my $ok = 1; |
166 | given ($undef) { when("") {$ok = 0} } |
cd9c531b |
167 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 |
168 | } |
169 | ######## |
170 | { |
171 | my $ok = 0; |
172 | given (undef) { when(undef) {$ok = 1} } |
cd9c531b |
173 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 |
174 | } |
175 | { |
176 | my $undef; |
177 | my $ok = 0; |
178 | given (undef) { when($undef) {$ok = 1} } |
cd9c531b |
179 | is($ok, 1, 'Given(undef) when($undef)'); |
0d863452 |
180 | } |
181 | { |
182 | my $undef; |
183 | my $ok = 0; |
184 | given ($undef) { when(undef) {$ok = 1} } |
cd9c531b |
185 | is($ok, 1, 'Given($undef) when(undef)'); |
0d863452 |
186 | } |
187 | { |
188 | my $undef; |
189 | my $ok = 0; |
190 | given ($undef) { when($undef) {$ok = 1} } |
cd9c531b |
191 | is($ok, 1, 'Given($undef) when($undef)'); |
0d863452 |
192 | } |
193 | |
194 | |
195 | # Regular expressions |
196 | { |
cd9c531b |
197 | my ($ok1, $ok2); |
0d863452 |
198 | given("Hello, world!") { |
199 | when(/lo/) |
cd9c531b |
200 | { $ok1 = 'y'; continue} |
0d863452 |
201 | when(/no/) |
cd9c531b |
202 | { $ok1 = 'n'; continue} |
0d863452 |
203 | when(/^(Hello,|Goodbye cruel) world[!.?]/) |
cd9c531b |
204 | { $ok2 = 'Y'; continue} |
0d863452 |
205 | when(/^(Hello cruel|Goodbye,) world[!.?]/) |
cd9c531b |
206 | { $ok2 = 'n'; continue} |
0d863452 |
207 | } |
cd9c531b |
208 | is($ok1, 'y', "regex 1"); |
209 | is($ok2, 'Y', "regex 2"); |
0d863452 |
210 | } |
211 | |
212 | # Comparisons |
213 | { |
214 | my $test = "explicit numeric comparison (<)"; |
215 | my $twenty_five = 25; |
cd9c531b |
216 | my $ok; |
0d863452 |
217 | given($twenty_five) { |
cd9c531b |
218 | when ($_ < 10) { $ok = "ten" } |
219 | when ($_ < 20) { $ok = "twenty" } |
220 | when ($_ < 30) { $ok = "thirty" } |
221 | when ($_ < 40) { $ok = "forty" } |
222 | default { $ok = "default" } |
0d863452 |
223 | } |
cd9c531b |
224 | is($ok, "thirty", $test); |
0d863452 |
225 | } |
226 | |
227 | { |
228 | use integer; |
229 | my $test = "explicit numeric comparison (integer <)"; |
230 | my $twenty_five = 25; |
cd9c531b |
231 | my $ok; |
0d863452 |
232 | given($twenty_five) { |
cd9c531b |
233 | when ($_ < 10) { $ok = "ten" } |
234 | when ($_ < 20) { $ok = "twenty" } |
235 | when ($_ < 30) { $ok = "thirty" } |
236 | when ($_ < 40) { $ok = "forty" } |
237 | default { $ok = "default" } |
0d863452 |
238 | } |
cd9c531b |
239 | is($ok, "thirty", $test); |
0d863452 |
240 | } |
241 | |
242 | { |
243 | my $test = "explicit numeric comparison (<=)"; |
244 | my $twenty_five = 25; |
cd9c531b |
245 | my $ok; |
0d863452 |
246 | given($twenty_five) { |
cd9c531b |
247 | when ($_ <= 10) { $ok = "ten" } |
248 | when ($_ <= 20) { $ok = "twenty" } |
249 | when ($_ <= 30) { $ok = "thirty" } |
250 | when ($_ <= 40) { $ok = "forty" } |
251 | default { $ok = "default" } |
0d863452 |
252 | } |
cd9c531b |
253 | is($ok, "thirty", $test); |
0d863452 |
254 | } |
255 | |
256 | { |
257 | use integer; |
258 | my $test = "explicit numeric comparison (integer <=)"; |
259 | my $twenty_five = 25; |
cd9c531b |
260 | my $ok; |
0d863452 |
261 | given($twenty_five) { |
cd9c531b |
262 | when ($_ <= 10) { $ok = "ten" } |
263 | when ($_ <= 20) { $ok = "twenty" } |
264 | when ($_ <= 30) { $ok = "thirty" } |
265 | when ($_ <= 40) { $ok = "forty" } |
266 | default { $ok = "default" } |
0d863452 |
267 | } |
cd9c531b |
268 | is($ok, "thirty", $test); |
0d863452 |
269 | } |
270 | |
271 | |
272 | { |
273 | my $test = "explicit numeric comparison (>)"; |
274 | my $twenty_five = 25; |
cd9c531b |
275 | my $ok; |
0d863452 |
276 | given($twenty_five) { |
cd9c531b |
277 | when ($_ > 40) { $ok = "forty" } |
278 | when ($_ > 30) { $ok = "thirty" } |
279 | when ($_ > 20) { $ok = "twenty" } |
280 | when ($_ > 10) { $ok = "ten" } |
281 | default { $ok = "default" } |
0d863452 |
282 | } |
cd9c531b |
283 | is($ok, "twenty", $test); |
0d863452 |
284 | } |
285 | |
286 | { |
287 | my $test = "explicit numeric comparison (>=)"; |
288 | my $twenty_five = 25; |
cd9c531b |
289 | my $ok; |
0d863452 |
290 | given($twenty_five) { |
cd9c531b |
291 | when ($_ >= 40) { $ok = "forty" } |
292 | when ($_ >= 30) { $ok = "thirty" } |
293 | when ($_ >= 20) { $ok = "twenty" } |
294 | when ($_ >= 10) { $ok = "ten" } |
295 | default { $ok = "default" } |
0d863452 |
296 | } |
cd9c531b |
297 | is($ok, "twenty", $test); |
0d863452 |
298 | } |
299 | |
300 | { |
301 | use integer; |
302 | my $test = "explicit numeric comparison (integer >)"; |
303 | my $twenty_five = 25; |
cd9c531b |
304 | my $ok; |
0d863452 |
305 | given($twenty_five) { |
cd9c531b |
306 | when ($_ > 40) { $ok = "forty" } |
307 | when ($_ > 30) { $ok = "thirty" } |
308 | when ($_ > 20) { $ok = "twenty" } |
309 | when ($_ > 10) { $ok = "ten" } |
310 | default { $ok = "default" } |
0d863452 |
311 | } |
cd9c531b |
312 | is($ok, "twenty", $test); |
0d863452 |
313 | } |
314 | |
315 | { |
316 | use integer; |
317 | my $test = "explicit numeric comparison (integer >=)"; |
318 | my $twenty_five = 25; |
cd9c531b |
319 | my $ok; |
0d863452 |
320 | given($twenty_five) { |
cd9c531b |
321 | when ($_ >= 40) { $ok = "forty" } |
322 | when ($_ >= 30) { $ok = "thirty" } |
323 | when ($_ >= 20) { $ok = "twenty" } |
324 | when ($_ >= 10) { $ok = "ten" } |
325 | default { $ok = "default" } |
0d863452 |
326 | } |
cd9c531b |
327 | is($ok, "twenty", $test); |
0d863452 |
328 | } |
329 | |
330 | |
331 | { |
332 | my $test = "explicit string comparison (lt)"; |
333 | my $twenty_five = "25"; |
cd9c531b |
334 | my $ok; |
0d863452 |
335 | given($twenty_five) { |
cd9c531b |
336 | when ($_ lt "10") { $ok = "ten" } |
337 | when ($_ lt "20") { $ok = "twenty" } |
338 | when ($_ lt "30") { $ok = "thirty" } |
339 | when ($_ lt "40") { $ok = "forty" } |
340 | default { $ok = "default" } |
0d863452 |
341 | } |
cd9c531b |
342 | is($ok, "thirty", $test); |
0d863452 |
343 | } |
344 | |
345 | { |
346 | my $test = "explicit string comparison (le)"; |
347 | my $twenty_five = "25"; |
cd9c531b |
348 | my $ok; |
0d863452 |
349 | given($twenty_five) { |
cd9c531b |
350 | when ($_ le "10") { $ok = "ten" } |
351 | when ($_ le "20") { $ok = "twenty" } |
352 | when ($_ le "30") { $ok = "thirty" } |
353 | when ($_ le "40") { $ok = "forty" } |
354 | default { $ok = "default" } |
0d863452 |
355 | } |
cd9c531b |
356 | is($ok, "thirty", $test); |
0d863452 |
357 | } |
358 | |
359 | { |
360 | my $test = "explicit string comparison (gt)"; |
361 | my $twenty_five = 25; |
cd9c531b |
362 | my $ok; |
0d863452 |
363 | given($twenty_five) { |
cd9c531b |
364 | when ($_ ge "40") { $ok = "forty" } |
365 | when ($_ ge "30") { $ok = "thirty" } |
366 | when ($_ ge "20") { $ok = "twenty" } |
367 | when ($_ ge "10") { $ok = "ten" } |
368 | default { $ok = "default" } |
0d863452 |
369 | } |
cd9c531b |
370 | is($ok, "twenty", $test); |
0d863452 |
371 | } |
372 | |
373 | { |
374 | my $test = "explicit string comparison (ge)"; |
375 | my $twenty_five = 25; |
cd9c531b |
376 | my $ok; |
0d863452 |
377 | given($twenty_five) { |
cd9c531b |
378 | when ($_ ge "40") { $ok = "forty" } |
379 | when ($_ ge "30") { $ok = "thirty" } |
380 | when ($_ ge "20") { $ok = "twenty" } |
381 | when ($_ ge "10") { $ok = "ten" } |
382 | default { $ok = "default" } |
0d863452 |
383 | } |
cd9c531b |
384 | is($ok, "twenty", $test); |
0d863452 |
385 | } |
386 | |
387 | # Make sure it still works with a lexical $_: |
388 | { |
389 | my $_; |
390 | my $test = "explicit comparison with lexical \$_"; |
391 | my $twenty_five = 25; |
cd9c531b |
392 | my $ok; |
0d863452 |
393 | given($twenty_five) { |
cd9c531b |
394 | when ($_ ge "40") { $ok = "forty" } |
395 | when ($_ ge "30") { $ok = "thirty" } |
396 | when ($_ ge "20") { $ok = "twenty" } |
397 | when ($_ ge "10") { $ok = "ten" } |
398 | default { $ok = "default" } |
0d863452 |
399 | } |
cd9c531b |
400 | is($ok, "twenty", $test); |
0d863452 |
401 | } |
402 | |
403 | # Optimized-away comparisons |
404 | { |
cd9c531b |
405 | my $ok; |
0d863452 |
406 | given(23) { |
cd9c531b |
407 | when (2 + 2 == 4) { $ok = 'y'; continue } |
408 | when (2 + 2 == 5) { $ok = 'n' } |
0d863452 |
409 | } |
cd9c531b |
410 | is($ok, 'y', "Optimized-away comparison"); |
0d863452 |
411 | } |
412 | |
413 | # File tests |
414 | # (How to be both thorough and portable? Pinch a few ideas |
415 | # from t/op/filetest.t. We err on the side of portability for |
416 | # the time being.) |
417 | |
418 | { |
419 | my ($ok_d, $ok_f, $ok_r); |
420 | given("op") { |
421 | when(-d) {$ok_d = 1; continue} |
422 | when(!-f) {$ok_f = 1; continue} |
423 | when(-r) {$ok_r = 1; continue} |
424 | } |
425 | ok($ok_d, "Filetest -d"); |
426 | ok($ok_f, "Filetest -f"); |
427 | ok($ok_r, "Filetest -r"); |
428 | } |
429 | |
430 | # Sub and method calls |
431 | sub bar {"bar"} |
432 | { |
433 | my $ok = 0; |
434 | given("foo") { |
435 | when(bar()) {$ok = 1} |
436 | } |
437 | ok($ok, "Sub call acts as boolean") |
438 | } |
439 | |
440 | { |
441 | my $ok = 0; |
442 | given("foo") { |
443 | when(main->bar()) {$ok = 1} |
444 | } |
445 | ok($ok, "Class-method call acts as boolean") |
446 | } |
447 | |
448 | { |
449 | my $ok = 0; |
450 | my $obj = bless []; |
451 | given("foo") { |
452 | when($obj->bar()) {$ok = 1} |
453 | } |
454 | ok($ok, "Object-method call acts as boolean") |
455 | } |
456 | |
457 | # Other things that should not be smart matched |
458 | { |
459 | my $ok = 0; |
1e1d4b91 |
460 | given(12) { |
461 | when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { |
462 | $ok = 1; |
463 | } |
464 | } |
465 | ok($ok, "bool not smartmatches"); |
466 | } |
467 | |
468 | { |
469 | my $ok = 0; |
0d863452 |
470 | given(0) { |
471 | when(eof(DATA)) { |
472 | $ok = 1; |
473 | } |
474 | } |
475 | ok($ok, "eof() not smartmatched"); |
476 | } |
477 | |
478 | { |
479 | my $ok = 0; |
480 | my %foo = ("bar", 0); |
481 | given(0) { |
482 | when(exists $foo{bar}) { |
483 | $ok = 1; |
484 | } |
485 | } |
486 | ok($ok, "exists() not smartmatched"); |
487 | } |
488 | |
489 | { |
490 | my $ok = 0; |
491 | given(0) { |
492 | when(defined $ok) { |
493 | $ok = 1; |
494 | } |
495 | } |
496 | ok($ok, "defined() not smartmatched"); |
497 | } |
498 | |
499 | { |
500 | my $ok = 1; |
501 | given("foo") { |
502 | when((1 == 1) && "bar") { |
503 | $ok = 0; |
504 | } |
505 | when((1 == 1) && $_ eq "foo") { |
506 | $ok = 2; |
507 | } |
508 | } |
509 | is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); |
510 | } |
511 | |
512 | { |
1e1d4b91 |
513 | my $ok = 0; |
514 | given("foo") { |
0d863452 |
515 | when((1 == $ok) || "foo") { |
1e1d4b91 |
516 | $ok = 1; |
0d863452 |
517 | } |
518 | } |
1e1d4b91 |
519 | ok($ok, '((1 == $ok) || "foo") smartmatched'); |
0d863452 |
520 | } |
521 | |
f92e1a16 |
522 | { |
523 | my $ok = 0; |
524 | given("foo") { |
525 | when((1 == $ok || undef) // "foo") { |
526 | $ok = 1; |
527 | } |
528 | } |
529 | ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); |
530 | } |
531 | |
1dcb720a |
532 | TODO: { |
533 | local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match"; |
534 | { # this should smart match on each side of && |
535 | my @n = qw(fred barney betty); |
536 | my @m = @n; |
537 | |
538 | my $ok = 0; |
539 | given( "fred" ) { |
540 | when( @n ) { |
541 | $ok++; continue; |
542 | } |
543 | when( @m ) { |
544 | $ok++; continue; |
545 | } |
546 | when( @m && @n ) { |
547 | $ok++; |
548 | } |
549 | } |
550 | |
551 | is($ok, 3, '(@n && @m) smart-matched'); |
552 | } |
553 | |
554 | { # this should smart match on each side of && |
555 | my @n = qw(fred barney betty); |
556 | my %n = map { $_, 1 } @n; |
557 | |
558 | my $ok = 0; |
559 | given( "fred" ) { |
560 | when( @n ) { |
561 | $ok++; continue; |
562 | } |
563 | when( %n ) { |
564 | $ok++; continue; |
565 | } |
566 | when( @n && %n ) { |
567 | $ok++; |
568 | } |
569 | } |
570 | |
571 | is($ok, 3, '(@n && %n) smart-matched'); |
572 | } |
573 | |
574 | { # this should smart match on each side of && |
575 | my %n = map { $_, 1 } qw(fred barney betty); |
576 | my %m = %n; |
577 | |
578 | my $ok = 0; |
579 | given( "fred" ) { |
580 | when( %m ) { |
581 | $ok++; continue; |
582 | } |
583 | when( %n ) { |
584 | $ok++; continue; |
585 | } |
586 | when( %m && %n ) { |
587 | $ok++; |
588 | } |
589 | } |
590 | |
591 | is($ok, 3, '(%m && %n) smart-matched'); |
592 | } |
593 | } |
0d863452 |
594 | |
595 | # Make sure we aren't invoking the get-magic more than once |
596 | |
597 | { # A helper class to count the number of accesses. |
598 | package FetchCounter; |
599 | sub TIESCALAR { |
600 | my ($class) = @_; |
601 | bless {value => undef, count => 0}, $class; |
602 | } |
603 | sub STORE { |
604 | my ($self, $val) = @_; |
605 | $self->{count} = 0; |
606 | $self->{value} = $val; |
607 | } |
608 | sub FETCH { |
609 | my ($self) = @_; |
610 | # Avoid pre/post increment here |
611 | $self->{count} = 1 + $self->{count}; |
612 | $self->{value}; |
613 | } |
614 | sub count { |
615 | my ($self) = @_; |
616 | $self->{count}; |
617 | } |
618 | } |
619 | |
620 | my $f = tie my $v, "FetchCounter"; |
621 | |
622 | { my $test_name = "Only one FETCH (in given)"; |
cd9c531b |
623 | my $ok; |
0d863452 |
624 | given($v = 23) { |
625 | when(undef) {} |
626 | when(sub{0}->()) {} |
627 | when(21) {} |
628 | when("22") {} |
629 | when(23) {$ok = 1} |
630 | when(/24/) {$ok = 0} |
631 | } |
cd9c531b |
632 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
633 | is($f->count(), 1, $test_name); |
634 | } |
635 | |
636 | { my $test_name = "Only one FETCH (numeric when)"; |
cd9c531b |
637 | my $ok; |
0d863452 |
638 | $v = 23; |
639 | is($f->count(), 0, "Sanity check: $test_name"); |
640 | given(23) { |
641 | when(undef) {} |
642 | when(sub{0}->()) {} |
643 | when(21) {} |
644 | when("22") {} |
645 | when($v) {$ok = 1} |
646 | when(/24/) {$ok = 0} |
647 | } |
cd9c531b |
648 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
649 | is($f->count(), 1, $test_name); |
650 | } |
651 | |
652 | { my $test_name = "Only one FETCH (string when)"; |
cd9c531b |
653 | my $ok; |
0d863452 |
654 | $v = "23"; |
655 | is($f->count(), 0, "Sanity check: $test_name"); |
656 | given("23") { |
657 | when(undef) {} |
658 | when(sub{0}->()) {} |
659 | when("21") {} |
660 | when("22") {} |
661 | when($v) {$ok = 1} |
662 | when(/24/) {$ok = 0} |
663 | } |
cd9c531b |
664 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
665 | is($f->count(), 1, $test_name); |
666 | } |
667 | |
668 | { my $test_name = "Only one FETCH (undef)"; |
cd9c531b |
669 | my $ok; |
0d863452 |
670 | $v = undef; |
671 | is($f->count(), 0, "Sanity check: $test_name"); |
672 | given(my $undef) { |
673 | when(sub{0}->()) {} |
674 | when("21") {} |
675 | when("22") {} |
676 | when($v) {$ok = 1} |
677 | when(undef) {$ok = 0} |
678 | } |
cd9c531b |
679 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
680 | is($f->count(), 1, $test_name); |
681 | } |
682 | |
683 | # Loop topicalizer |
684 | { |
685 | my $first = 1; |
686 | for (1, "two") { |
687 | when ("two") { |
688 | is($first, 0, "Loop: 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, "Loop: first"); |
695 | $first = 0; |
696 | # Implicit break is okay |
697 | } |
698 | } |
699 | } |
700 | |
701 | { |
702 | my $first = 1; |
703 | for $_ (1, "two") { |
704 | when ("two") { |
705 | is($first, 0, "Explicit \$_: second"); |
706 | eval {break}; |
707 | like($@, qr/^Can't "break" in a loop topicalizer/, |
708 | q{Can't "break" in a loop topicalizer}); |
709 | } |
710 | when (1) { |
711 | is($first, 1, "Explicit \$_: first"); |
712 | $first = 0; |
713 | # Implicit break is okay |
714 | } |
715 | } |
716 | } |
717 | |
718 | { |
719 | my $first = 1; |
720 | my $_; |
721 | for (1, "two") { |
722 | when ("two") { |
723 | is($first, 0, "Implicitly lexical loop: second"); |
724 | eval {break}; |
725 | like($@, qr/^Can't "break" in a loop topicalizer/, |
726 | q{Can't "break" in a loop topicalizer}); |
727 | } |
728 | when (1) { |
729 | is($first, 1, "Implicitly lexical loop: first"); |
730 | $first = 0; |
731 | # Implicit break is okay |
732 | } |
733 | } |
734 | } |
735 | |
736 | { |
737 | my $first = 1; |
738 | my $_; |
739 | for $_ (1, "two") { |
740 | when ("two") { |
741 | is($first, 0, "Implicitly lexical, explicit \$_: second"); |
742 | eval {break}; |
743 | like($@, qr/^Can't "break" in a loop topicalizer/, |
744 | q{Can't "break" in a loop topicalizer}); |
745 | } |
746 | when (1) { |
747 | is($first, 1, "Implicitly lexical, explicit \$_: first"); |
748 | $first = 0; |
749 | # Implicit break is okay |
750 | } |
751 | } |
752 | } |
753 | |
754 | { |
755 | my $first = 1; |
756 | for my $_ (1, "two") { |
757 | when ("two") { |
758 | is($first, 0, "Lexical loop: second"); |
759 | eval {break}; |
760 | like($@, qr/^Can't "break" in a loop topicalizer/, |
761 | q{Can't "break" in a loop topicalizer}); |
762 | } |
763 | when (1) { |
1dcb720a |
764 | is($first, 1, "Lexical loop: first"); |
0d863452 |
765 | $first = 0; |
766 | # Implicit break is okay |
767 | } |
768 | } |
769 | } |
770 | |
771 | |
772 | # Code references |
773 | { |
774 | no warnings "redefine"; |
775 | my $called_foo = 0; |
776 | sub foo {$called_foo = 1} |
777 | my $called_bar = 0; |
778 | sub bar {$called_bar = 1} |
779 | my ($matched_foo, $matched_bar) = (0, 0); |
780 | given(\&foo) { |
781 | when(\&bar) {$matched_bar = 1} |
782 | when(\&foo) {$matched_foo = 1} |
783 | } |
784 | is($called_foo, 0, "Code ref comparison: foo not called"); |
785 | is($called_bar, 0, "Code ref comparison: bar not called"); |
786 | is($matched_bar, 0, "Code ref didn't match different one"); |
787 | is($matched_foo, 1, "Code ref did match itself"); |
788 | } |
789 | |
790 | sub contains_x { |
791 | my $x = shift; |
792 | return ($x =~ /x/); |
793 | } |
794 | { |
795 | my ($ok1, $ok2) = (0,0); |
796 | given("foxy!") { |
797 | when(contains_x($_)) |
798 | { $ok1 = 1; continue } |
799 | when(\&contains_x) |
800 | { $ok2 = 1; continue } |
801 | } |
802 | is($ok1, 1, "Calling sub directly (true)"); |
803 | is($ok2, 1, "Calling sub indirectly (true)"); |
804 | |
805 | given("foggy") { |
806 | when(contains_x($_)) |
807 | { $ok1 = 2; continue } |
808 | when(\&contains_x) |
809 | { $ok2 = 2; continue } |
810 | } |
811 | is($ok1, 1, "Calling sub directly (false)"); |
812 | is($ok2, 1, "Calling sub indirectly (false)"); |
813 | } |
814 | |
02eafbe2 |
815 | SKIP: { |
816 | skip "Scalar/Util.pm not yet available", 20 |
817 | unless -r "$INC[0]/Scalar/Util.pm"; |
818 | # Test overloading |
819 | { package OverloadTest; |
820 | |
821 | use overload '""' => sub{"string value of obj"}; |
822 | |
823 | use overload "~~" => sub { |
824 | my ($self, $other, $reversed) = @_; |
825 | if ($reversed) { |
826 | $self->{left} = $other; |
827 | $self->{right} = $self; |
828 | $self->{reversed} = 1; |
829 | } else { |
830 | $self->{left} = $self; |
831 | $self->{right} = $other; |
832 | $self->{reversed} = 0; |
833 | } |
834 | $self->{called} = 1; |
835 | return $self->{retval}; |
836 | }; |
0d863452 |
837 | |
02eafbe2 |
838 | sub new { |
839 | my ($pkg, $retval) = @_; |
840 | bless { |
841 | called => 0, |
842 | retval => $retval, |
843 | }, $pkg; |
844 | } |
845 | } |
846 | |
847 | { |
848 | my $test = "Overloaded obj in given (true)"; |
849 | my $obj = OverloadTest->new(1); |
850 | my $matched; |
851 | given($obj) { |
852 | when ("other arg") {$matched = 1} |
853 | default {$matched = 0} |
854 | } |
0d863452 |
855 | |
02eafbe2 |
856 | is($obj->{called}, 1, "$test: called"); |
857 | ok($matched, "$test: matched"); |
858 | is($obj->{left}, "string value of obj", "$test: left"); |
859 | is($obj->{right}, "other arg", "$test: right"); |
860 | ok(!$obj->{reversed}, "$test: not reversed"); |
861 | } |
862 | |
863 | { |
864 | my $test = "Overloaded obj in given (false)"; |
865 | my $obj = OverloadTest->new(0); |
866 | my $matched; |
867 | given($obj) { |
868 | when ("other arg") {$matched = 1} |
869 | } |
0d863452 |
870 | |
02eafbe2 |
871 | is($obj->{called}, 1, "$test: called"); |
872 | ok(!$matched, "$test: not matched"); |
873 | is($obj->{left}, "string value of obj", "$test: left"); |
874 | is($obj->{right}, "other arg", "$test: right"); |
875 | ok(!$obj->{reversed}, "$test: not reversed"); |
876 | } |
877 | |
878 | { |
879 | my $test = "Overloaded obj in when (true)"; |
880 | my $obj = OverloadTest->new(1); |
881 | my $matched; |
882 | given("topic") { |
883 | when ($obj) {$matched = 1} |
884 | default {$matched = 0} |
885 | } |
0d863452 |
886 | |
02eafbe2 |
887 | is($obj->{called}, 1, "$test: called"); |
888 | ok($matched, "$test: matched"); |
889 | is($obj->{left}, "topic", "$test: left"); |
890 | is($obj->{right}, "string value of obj", "$test: right"); |
891 | ok($obj->{reversed}, "$test: reversed"); |
892 | } |
893 | |
894 | { |
895 | my $test = "Overloaded obj in when (false)"; |
896 | my $obj = OverloadTest->new(0); |
897 | my $matched; |
898 | given("topic") { |
899 | when ($obj) {$matched = 1} |
900 | default {$matched = 0} |
901 | } |
0d863452 |
902 | |
02eafbe2 |
903 | is($obj->{called}, 1, "$test: called"); |
904 | ok(!$matched, "$test: not matched"); |
905 | is($obj->{left}, "topic", "$test: left"); |
906 | is($obj->{right}, "string value of obj", "$test: right"); |
907 | ok($obj->{reversed}, "$test: reversed"); |
908 | } |
0d863452 |
909 | } |
0d863452 |
910 | # Okay, that'll do for now. The intricacies of the smartmatch |
911 | # semantics are tested in t/op/smartmatch.t |
912 | __END__ |