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