Devel::PPPort: Fix D_PPP_FIX_UTF8_ERRSV macro
[perl.git] / t / op / or.t
1 #!./perl
2
3 # Test || in weird situations.
4
5 BEGIN {
6     chdir 't' if -d 't';
7     require './test.pl';
8     set_up_inc('../lib');
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;
27
28 plan( tests => 14 );
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
40 is($c, $a_str, "comparison of string equality");
41 is($c+0, $a_num, "comparison of numeric equality");   # force numeric context.
42
43 $a =~ /./g or die "Match failed for some reason"; # Make $a magic
44
45 $c = $a || $b;
46
47 is($c, $a_str, "comparison of string equality");
48 is($c+0, $a_num, "comparison of numeric equality");   # force numeric context.
49
50 my $val = 3;
51
52 $c = $val || $b;
53 is($c, 3, "|| short-circuited as expected");
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 }
69
70 $y = " ";
71 for (pos $x || pos $y) {
72     eval { $_++ };
73 }
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");
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");