Commit | Line | Data |
---|---|---|
1a28061a MS |
1 | #!./perl |
2 | ||
3 | # Test || in weird situations. | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
624c42e2 N |
7 | require './test.pl'; |
8 | set_up_inc('../lib'); | |
1a28061a MS |
9 | } |
10 | ||
11 | ||
12 | package Countdown; | |
13 | ||
14 | sub TIESCALAR { | |
15 | my $class = shift; | |
16 | my $instance = shift || undef; | |
17 | return bless \$instance => $class; | |
18 | } | |
19 | ||
20 | sub FETCH { | |
21 | print "# FETCH! ${$_[0]}\n"; | |
22 | return ${$_[0]}--; | |
23 | } | |
24 | ||
25 | ||
26 | package main; | |
1a28061a | 27 | |
375879aa | 28 | plan( tests => 14 ); |
1a28061a MS |
29 | |
30 | ||
31 | my ($a, $b, $c); | |
32 | ||
33 | $! = 1; | |
34 | $a = $!; | |
35 | my $a_str = sprintf "%s", $a; | |
36 | my $a_num = sprintf "%d", $a; | |
37 | ||
38 | $c = $a || $b; | |
39 | ||
236d1a76 JK |
40 | is($c, $a_str, "comparison of string equality"); |
41 | is($c+0, $a_num, "comparison of numeric equality"); # force numeric context. | |
1a28061a MS |
42 | |
43 | $a =~ /./g or die "Match failed for some reason"; # Make $a magic | |
44 | ||
45 | $c = $a || $b; | |
46 | ||
236d1a76 JK |
47 | is($c, $a_str, "comparison of string equality"); |
48 | is($c+0, $a_num, "comparison of numeric equality"); # force numeric context. | |
1a28061a MS |
49 | |
50 | my $val = 3; | |
51 | ||
52 | $c = $val || $b; | |
236d1a76 | 53 | is($c, 3, "|| short-circuited as expected"); |
1a28061a MS |
54 | |
55 | tie $a, 'Countdown', $val; | |
56 | ||
57 | $c = $a; | |
58 | is($c, 3, 'Single FETCH on tied scalar'); | |
59 | ||
60 | $c = $a; | |
61 | is($c, 2, ' $tied = $var'); | |
62 | ||
63 | $c = $a || $b; | |
64 | ||
65 | { | |
66 | local $TODO = 'Double FETCH'; | |
67 | is($c, 1, ' $tied || $var'); | |
68 | } | |
2e73d70e FC |
69 | |
70 | $y = " "; | |
71 | for (pos $x || pos $y) { | |
72 | eval { $_++ }; | |
73 | } | |
375879aa FC |
74 | is(pos($y) || $@, 1, "|| propagates lvaluish context to its rhs"); |
75 | ||
76 | $x = " "; | |
77 | pos $x = 1; | |
78 | for (pos $x || pos $y) { | |
79 | eval { $_++ }; | |
80 | } | |
81 | is(pos($x) || $@, 2, "|| propagates lvaluish context to its lhs"); | |
82 | ||
83 | for ($h{k} || $h{l}) {} | |
84 | ok(!exists $h{k}, | |
85 | "|| does not propagate lvaluish cx to a subscript on its lhs"); | |
86 | ok(!exists $h{l}, | |
87 | "|| does not propagate lvaluish cx to a subscript on its rhs"); | |
e45d8982 MH |
88 | |
89 | my $aa, $bb, $cc; | |
90 | $bb = 1; | |
91 | ||
92 | my $res = 0; | |
93 | # Well, really testing OP_DOR I guess | |
94 | unless ($aa || $bb // $cc) { | |
95 | $res = 1; | |
96 | } | |
97 | is($res, 0, "res is 0 after mixed OR/DOR"); | |
98 | ||
99 | $res = 0; | |
100 | unless ($aa // $bb || $cc) { | |
101 | $res = 1; | |
102 | } | |
103 | is($res, 0, "res is 0 after mixed DOR/OR"); |