This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #87708] $tied % $tied and $tied * $tied under use integer
[perl5.git] / t / op / tie_fetch_count.t
CommitLineData
60ccc62f
A
1#!./perl
2# Tests counting number of FETCHes.
3#
b04496fe 4# See Bugs #76814 and #87708.
60ccc62f
A
5
6BEGIN {
7 chdir 't' if -d 't';
8 @INC = '../lib';
9 require './test.pl';
b04496fe 10 plan (tests => 172);
60ccc62f
A
11}
12
13use strict;
14use warnings;
15
60ccc62f
A
16my $count = 0;
17
b04496fe
FC
18# Usage:
19# tie $var, "main", $val; # FETCH returns $val
20# tie $var, "main", $val1, $val2; # FETCH returns the values in order,
21# # one at a time, repeating the last
22# # when the list is exhausted.
23sub TIESCALAR {my $pack = shift; bless [@_], $pack;}
24sub FETCH {$count ++; @{$_ [0]} == 1 ? ${$_ [0]}[0] : shift @{$_ [0]}}
60ccc62f
A
25sub STORE {1;}
26
27
28sub check_count {
29 my $op = shift;
b04496fe
FC
30 my $expected = shift() // 1;
31 is $count, $expected,
32 "FETCH called " . (
33 $expected == 1 ? "just once" :
34 $expected == 2 ? "twice" :
35 "$count times"
36 ) . " using '$op'";
60ccc62f
A
37 $count = 0;
38}
39
40my ($dummy, @dummy);
41
42tie my $var => 'main', 1;
43
44# Assignment.
45$dummy = $var ; check_count "=";
46
47# Unary +/-
48$dummy = +$var ; check_count "unary +";
49$dummy = -$var ; check_count "unary -";
50
51# Basic arithmetic and string operators.
52$dummy = $var + 1 ; check_count '+';
53$dummy = $var - 1 ; check_count '-';
54$dummy = $var / 1 ; check_count '/';
55$dummy = $var * 1 ; check_count '*';
56$dummy = $var % 1 ; check_count '%';
57$dummy = $var ** 1 ; check_count '**';
58$dummy = $var << 1 ; check_count '<<';
59$dummy = $var >> 1 ; check_count '>>';
60$dummy = $var x 1 ; check_count 'x';
61@dummy = ($var) x 1 ; check_count 'x';
62$dummy = $var . 1 ; check_count '.';
63
64# Pre/post in/decrement
65 $var ++ ; check_count 'post ++';
66 $var -- ; check_count 'post --';
67 ++ $var ; check_count 'pre ++';
68 -- $var ; check_count 'pre --';
69
70# Numeric comparison
71$dummy = $var < 1 ; check_count '<';
72$dummy = $var <= 1 ; check_count '<=';
73$dummy = $var == 1 ; check_count '==';
74$dummy = $var >= 1 ; check_count '>=';
75$dummy = $var > 1 ; check_count '>';
76$dummy = $var != 1 ; check_count '!=';
77$dummy = $var <=> 1 ; check_count '<=>';
78
79# String comparison
078504b2
FC
80$dummy = $var lt 1 ; check_count 'lt';
81$dummy = $var le 1 ; check_count 'le';
82$dummy = $var eq 1 ; check_count 'eq';
83$dummy = $var ge 1 ; check_count 'ge';
84$dummy = $var gt 1 ; check_count 'gt';
85$dummy = $var ne 1 ; check_count 'ne';
86$dummy = $var cmp 1 ; check_count 'cmp';
60ccc62f
A
87
88# Bitwise operators
89$dummy = $var & 1 ; check_count '&';
90$dummy = $var ^ 1 ; check_count '^';
91$dummy = $var | 1 ; check_count '|';
92$dummy = ~$var ; check_count '~';
93
94# Logical operators
06c841cf 95$dummy = !$var ; check_count '!';
1c3caf3f
FC
96tie my $v_1, "main", 0;
97$dummy = $v_1 || 1 ; check_count '||';
98$dummy = ($v_1 or 1); check_count 'or';
60ccc62f
A
99$dummy = $var && 1 ; check_count '&&';
100$dummy = ($var and 1); check_count 'and';
101$dummy = ($var xor 1); check_count 'xor';
102$dummy = $var ? 1 : 1 ; check_count '?:';
103
104# Overloadable functions
105$dummy = sin $var ; check_count 'sin';
106$dummy = cos $var ; check_count 'cos';
107$dummy = exp $var ; check_count 'exp';
108$dummy = abs $var ; check_count 'abs';
109$dummy = log $var ; check_count 'log';
110$dummy = sqrt $var ; check_count 'sqrt';
111$dummy = int $var ; check_count 'int';
112$dummy = atan2 $var, 1 ; check_count 'atan2';
113
114# Readline/glob
115tie my $var0, "main", \*DATA;
116$dummy = <$var0> ; check_count '<readline>';
117$dummy = <${var}> ; check_count '<glob>';
118
119# File operators
120$dummy = -r $var ; check_count '-r';
121$dummy = -w $var ; check_count '-w';
122$dummy = -x $var ; check_count '-x';
123$dummy = -o $var ; check_count '-o';
124$dummy = -R $var ; check_count '-R';
125$dummy = -W $var ; check_count '-W';
126$dummy = -X $var ; check_count '-X';
127$dummy = -O $var ; check_count '-O';
128$dummy = -e $var ; check_count '-e';
129$dummy = -z $var ; check_count '-z';
130$dummy = -s $var ; check_count '-s';
131$dummy = -f $var ; check_count '-f';
132$dummy = -d $var ; check_count '-d';
133$dummy = -l $var ; check_count '-l';
134$dummy = -p $var ; check_count '-p';
135$dummy = -S $var ; check_count '-S';
136$dummy = -b $var ; check_count '-b';
137$dummy = -c $var ; check_count '-c';
138$dummy = -t $var ; check_count '-t';
139$dummy = -u $var ; check_count '-u';
140$dummy = -g $var ; check_count '-g';
141$dummy = -k $var ; check_count '-k';
142$dummy = -T $var ; check_count '-T';
143$dummy = -B $var ; check_count '-B';
144$dummy = -M $var ; check_count '-M';
145$dummy = -A $var ; check_count '-A';
146$dummy = -C $var ; check_count '-C';
147
148# Matching
149$_ = "foo";
150$dummy = $var =~ m/ / ; check_count 'm//';
151$dummy = $var =~ s/ //; check_count 's///';
152$dummy = $var ~~ 1 ; check_count '~~';
9138d6ca 153$dummy = $var =~ y/ //; check_count 'y///';
a9984b10
FC
154 /$var/ ; check_count 'm/pattern/';
155 /$var foo/ ; check_count 'm/$tied foo/';
156 s/$var// ; check_count 's/pattern//';
157 s/$var foo// ; check_count 's/$tied foo//';
60ccc62f
A
158 s/./$var/ ; check_count 's//replacement/';
159
160# Dereferencing
161tie my $var1 => 'main', \1;
162$dummy = $$var1 ; check_count '${}';
163tie my $var2 => 'main', [];
164$dummy = @$var2 ; check_count '@{}';
165tie my $var3 => 'main', {};
166$dummy = %$var3 ; check_count '%{}';
167{
168 no strict 'refs';
169 tie my $var4 => 'main', **;
170 $dummy = *$var4 ; check_count '*{}';
171}
172
173tie my $var5 => 'main', sub {1};
174$dummy = &$var5 ; check_count '&{}';
175
b04496fe
FC
176
177###############################################
178# Tests for $foo binop $foo #
179###############################################
180
181# These test that binary ops call FETCH twice if the same scalar is used
182# for both operands. They also test that both return values from
183# FETCH are used.
184
185sub bin_test {
186 my $op = shift;
187 tie my $var, "main", @_[0..$#_-1];
188 is(eval "\$var $op \$var", pop, "retval of \$var $op \$var");
189 check_count $op, 2;
190}
191sub bin_int_test {
192 my $op = shift;
193 tie my $var, "main", @_[0..$#_-1];
194 is(eval "use integer; \$var $op \$var", pop,
195 "retval of \$var $op \$var under use integer");
196 check_count "$op under use integer", 2;
197}
198
199our $TODO;
558b5b58 200my $todo = 'bug #87708';
b04496fe
FC
201{
202 local $TODO = $todo;
203 bin_test '**', 2, 3, 8;
204 bin_test '*' , 2, 3, 6;
205 bin_test '/' , 10, 2, 5;
206 bin_test '%' , 11, 2, 1;
207 bin_test 'x' , 11, 2, 1111;
208 bin_test '-' , 11, 2, 9;
209 bin_test '<<', 11, 2, 44;
210 bin_test '>>', 44, 2, 11;
211 bin_test '<' , 1, 2, 1;
212 bin_test '>' , 44, 2, 1;
213 bin_test '<=', 44, 2, "";
214 bin_test '>=', 1, 2, "";
215 bin_test '!=', 1, 2, 1;
216 bin_test '<=>', 1, 2, -1;
217 bin_test 'le', 4, 2, "";
218 bin_test 'lt', 1, 2, 1;
219 bin_test 'gt', 4, 2, 1;
220 bin_test 'ge', 1, 2, "";
221 bin_test 'eq', 1, 2, "";
222 bin_test 'ne', 1, 2, 1;
223 bin_test 'cmp', 1, 2, -1;
224 bin_test '&' , 1, 2, 0;
225 bin_test '|' , 1, 2, 3;
226}
227bin_test '.' , 1, 2, 12;
228{
229 local $TODO = $todo ;
230 bin_test '==', 1, 2, "";
231 bin_test '+' , 1, 2, 3;
96b6b87f
FC
232}
233bin_int_test '*' , 2, 3, 6;
234{
235 local $TODO = $todo ;
b04496fe 236 bin_int_test '/' , 10, 2, 5;
b04496fe 237}
96b6b87f 238bin_int_test '%' , 11, 2, 1;
e62ca0f9
FC
239bin_int_test '+' , 1, 2, 3;
240bin_int_test '-' , 11, 2, 9;
9b029393 241bin_int_test '<' , 1, 2, 1;
fd2dbd2b 242bin_int_test '>' , 44, 2, 1;
5c7d20ff 243bin_int_test '<=', 44, 2, "";
f2bd3a8b 244bin_int_test '>=', 1, 2, "";
bfa9dccd 245bin_int_test '==', 1, 2, "";
577914ca 246bin_int_test '!=', 1, 2, 1;
4cdd48d8 247bin_int_test '<=>', 1, 2, -1;
c31c2913
FC
248tie $var, "main", 1, 4;
249cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var');
250check_count 'atan2', 2;
b04496fe 251
60ccc62f 252__DATA__