This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make filetest ops handle get-magic correctly for glob(ref)s
[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';
094a3eec 10 plan (tests => 278);
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]}}
9c9a2500 25sub STORE { unshift @{$_[0]}, $_[1] }
60ccc62f
A
26
27
28sub check_count {
29 my $op = shift;
b04496fe 30 my $expected = shift() // 1;
5e0b4493 31 local $::Level = $::Level + 1;
b04496fe
FC
32 is $count, $expected,
33 "FETCH called " . (
34 $expected == 1 ? "just once" :
35 $expected == 2 ? "twice" :
36 "$count times"
37 ) . " using '$op'";
60ccc62f
A
38 $count = 0;
39}
40
41my ($dummy, @dummy);
42
43tie my $var => 'main', 1;
44
45# Assignment.
46$dummy = $var ; check_count "=";
93564729 47*dummy = $var ; check_count '*glob = $tied';
60ccc62f
A
48
49# Unary +/-
50$dummy = +$var ; check_count "unary +";
51$dummy = -$var ; check_count "unary -";
52
53# Basic arithmetic and string operators.
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 << 1 ; check_count '<<';
61$dummy = $var >> 1 ; check_count '>>';
62$dummy = $var x 1 ; check_count 'x';
63@dummy = ($var) x 1 ; check_count 'x';
64$dummy = $var . 1 ; check_count '.';
65
66# Pre/post in/decrement
67 $var ++ ; check_count 'post ++';
68 $var -- ; check_count 'post --';
69 ++ $var ; check_count 'pre ++';
70 -- $var ; check_count 'pre --';
71
72# Numeric comparison
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$dummy = $var != 1 ; check_count '!=';
79$dummy = $var <=> 1 ; check_count '<=>';
80
81# String comparison
078504b2
FC
82$dummy = $var lt 1 ; check_count 'lt';
83$dummy = $var le 1 ; check_count 'le';
84$dummy = $var eq 1 ; check_count 'eq';
85$dummy = $var ge 1 ; check_count 'ge';
86$dummy = $var gt 1 ; check_count 'gt';
87$dummy = $var ne 1 ; check_count 'ne';
88$dummy = $var cmp 1 ; check_count 'cmp';
60ccc62f
A
89
90# Bitwise operators
91$dummy = $var & 1 ; check_count '&';
92$dummy = $var ^ 1 ; check_count '^';
93$dummy = $var | 1 ; check_count '|';
94$dummy = ~$var ; check_count '~';
95
96# Logical operators
06c841cf 97$dummy = !$var ; check_count '!';
1c3caf3f
FC
98tie my $v_1, "main", 0;
99$dummy = $v_1 || 1 ; check_count '||';
100$dummy = ($v_1 or 1); check_count 'or';
60ccc62f
A
101$dummy = $var && 1 ; check_count '&&';
102$dummy = ($var and 1); check_count 'and';
103$dummy = ($var xor 1); check_count 'xor';
104$dummy = $var ? 1 : 1 ; check_count '?:';
105
106# Overloadable functions
107$dummy = sin $var ; check_count 'sin';
108$dummy = cos $var ; check_count 'cos';
109$dummy = exp $var ; check_count 'exp';
110$dummy = abs $var ; check_count 'abs';
111$dummy = log $var ; check_count 'log';
112$dummy = sqrt $var ; check_count 'sqrt';
113$dummy = int $var ; check_count 'int';
114$dummy = atan2 $var, 1 ; check_count 'atan2';
115
116# Readline/glob
117tie my $var0, "main", \*DATA;
118$dummy = <$var0> ; check_count '<readline>';
119$dummy = <${var}> ; check_count '<glob>';
120
121# File operators
094a3eec
FC
122for (split //, 'rwxoRWXOezsfdpSbctugkTBMAC') {
123 no warnings 'unopened';
124 $dummy = eval "-$_ \$var"; check_count "-$_";
125 # Make $var hold a glob:
126 $var = *dummy; $dummy = $var; $count = 0;
127 $dummy = eval "-$_ \$var"; check_count "-$_ \$tied_glob";
128 $var = *dummy; $dummy = $var; $count = 0;
129 $dummy = eval "-$_ \\\$var"; check_count "-$_ \\\$tied_glob";
130}
60ccc62f 131$dummy = -l $var ; check_count '-l';
60ccc62f
A
132
133# Matching
134$_ = "foo";
135$dummy = $var =~ m/ / ; check_count 'm//';
136$dummy = $var =~ s/ //; check_count 's///';
137$dummy = $var ~~ 1 ; check_count '~~';
9138d6ca 138$dummy = $var =~ y/ //; check_count 'y///';
a9984b10
FC
139 /$var/ ; check_count 'm/pattern/';
140 /$var foo/ ; check_count 'm/$tied foo/';
141 s/$var// ; check_count 's/pattern//';
142 s/$var foo// ; check_count 's/$tied foo//';
60ccc62f
A
143 s/./$var/ ; check_count 's//replacement/';
144
145# Dereferencing
146tie my $var1 => 'main', \1;
147$dummy = $$var1 ; check_count '${}';
148tie my $var2 => 'main', [];
149$dummy = @$var2 ; check_count '@{}';
d2d95e13 150$dummy = shift $var2 ; check_count 'shift arrayref';
60ccc62f
A
151tie my $var3 => 'main', {};
152$dummy = %$var3 ; check_count '%{}';
075980ed 153$dummy = keys $var3 ; check_count 'keys hashref';
60ccc62f
A
154{
155 no strict 'refs';
156 tie my $var4 => 'main', **;
157 $dummy = *$var4 ; check_count '*{}';
158}
159
160tie my $var5 => 'main', sub {1};
161$dummy = &$var5 ; check_count '&{}';
162
7ffa7e75
FC
163{
164 no strict 'refs';
165 tie my $var1 => 'main', 1;
166 $dummy = $$var1 ; check_count 'symbolic ${}';
167 $dummy = @$var1 ; check_count 'symbolic @{}';
168 $dummy = %$var1 ; check_count 'symbolic %{}';
169 $dummy = *$var1 ; check_count 'symbolic *{}';
170 local *1 = sub{};
171 $dummy = &$var1 ; check_count 'symbolic &{}';
ed996e63 172
c00274d3 173 # This test will not be a complete test if *988 has been created
ed996e63
FC
174 # already. If this dies, change it to use another built-in variable.
175 # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which
176 # is why we need the test this way.
c00274d3
FC
177 if (exists $::{988}) {
178 die "*988 already exists. Please adjust this test"
ed996e63 179 }
c00274d3 180 tie my $var6 => main => 988;
ed996e63
FC
181 no warnings;
182 readdir $var6 ; check_count 'symbolic readdir';
ad6acfc4
FC
183 if (exists $::{973}) { # Need a different variable here
184 die "*973 already exists. Please adjust this test"
185 }
186 tie my $var7 => main => 973;
187 defined $$var7 ; check_count 'symbolic defined ${}';
7ffa7e75 188}
b04496fe 189
da6b625f
FC
190tie my $var8 => 'main', 'main';
191sub bolgy {}
192$var8->bolgy ; check_count '->method';
33d4ef81 193{
f8ccc5c6 194 no warnings 'once';
33d4ef81
FC
195 () = *swibble;
196 # This must be the name of an existing glob to trigger the maximum
197 # number of fetches in 5.14:
198 tie my $var9 => 'main', 'swibble';
199 no strict 'refs';
200 use constant glumscrin => 'shreggleboughet';
201 *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}';
202}
da6b625f 203
93564729
FC
204# This line makes $var8 hold a glob:
205$var8 = *dummy; $dummy = $var8; $count = 0;
206eval { chdir $var8 } ; check_count 'chdir $tied_glob';
207$var8 = *dummy; $dummy = $var8; $count = 0;
2ea1cce7
FC
208eval { chdir \$var8 } ; check_count 'chdir \$tied_glob';
209$var8 = *dummy; $dummy = $var8; $count = 0;
93564729
FC
210eval { chmod 0, $var8 } ; check_count 'chmod 0,$tied_glob';
211$var8 = *dummy; $dummy = $var8; $count = 0;
2ea1cce7
FC
212eval { chmod 0,\$var8 } ; check_count 'chmod 0,\$tied_glob';
213$var8 = *dummy; $dummy = $var8; $count = 0;
5e0b4493 214eval { chown 0,0,$var8 }; check_count 'chown 0,0,$tied_glob';
2ea1cce7
FC
215$var8 = *dummy; $dummy = $var8; $count = 0;
216eval { chown 0,0,\$var8}; check_count 'chown 0,0,\$tied_glob';
93564729
FC
217
218
b04496fe
FC
219###############################################
220# Tests for $foo binop $foo #
221###############################################
222
223# These test that binary ops call FETCH twice if the same scalar is used
224# for both operands. They also test that both return values from
225# FETCH are used.
226
9c9a2500
DM
227my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^);
228
229
230sub _bin_test {
231 my $int = shift;
b04496fe 232 my $op = shift;
9c9a2500
DM
233 my $exp = pop;
234 my @fetches = @_;
235
236 $int = $int ? 'use integer; ' : '';
237
238 tie my $var, "main", @fetches;
239 is(eval "$int\$var $op \$var", $exp, "retval of $int\$var $op \$var");
240 check_count "$int$op", 2;
241
242 return unless $mutators{$op};
243
244 tie my $var2, "main", @fetches;
245 is(eval "$int \$var2 $op= \$var2", $exp, "retval of $int \$var2 $op= \$var2");
246 check_count "$int$op=", 3;
247}
248
249sub bin_test {
250 _bin_test(0, @_);
b04496fe 251}
9c9a2500 252
b04496fe 253sub bin_int_test {
9c9a2500 254 _bin_test(1, @_);
b04496fe
FC
255}
256
75ea7a12
FC
257bin_test '**', 2, 3, 8;
258bin_test '*' , 2, 3, 6;
259bin_test '/' , 10, 2, 5;
260bin_test '%' , 11, 2, 1;
261bin_test 'x' , 11, 2, 1111;
262bin_test '-' , 11, 2, 9;
263bin_test '<<', 11, 2, 44;
264bin_test '>>', 44, 2, 11;
265bin_test '<' , 1, 2, 1;
266bin_test '>' , 44, 2, 1;
267bin_test '<=', 44, 2, "";
268bin_test '>=', 1, 2, "";
269bin_test '!=', 1, 2, 1;
270bin_test '<=>', 1, 2, -1;
271bin_test 'le', 4, 2, "";
272bin_test 'lt', 1, 2, 1;
273bin_test 'gt', 4, 2, 1;
274bin_test 'ge', 1, 2, "";
275bin_test 'eq', 1, 2, "";
276bin_test 'ne', 1, 2, 1;
277bin_test 'cmp', 1, 2, -1;
278bin_test '&' , 1, 2, 0;
279bin_test '|' , 1, 2, 3;
3216d309 280bin_test '^' , 3, 5, 6;
b04496fe 281bin_test '.' , 1, 2, 12;
7d779b23 282bin_test '==', 1, 2, "";
4c3ac4ba 283bin_test '+' , 1, 2, 3;
96b6b87f 284bin_int_test '*' , 2, 3, 6;
76422f81 285bin_int_test '/' , 10, 2, 5;
96b6b87f 286bin_int_test '%' , 11, 2, 1;
e62ca0f9
FC
287bin_int_test '+' , 1, 2, 3;
288bin_int_test '-' , 11, 2, 9;
9b029393 289bin_int_test '<' , 1, 2, 1;
fd2dbd2b 290bin_int_test '>' , 44, 2, 1;
5c7d20ff 291bin_int_test '<=', 44, 2, "";
f2bd3a8b 292bin_int_test '>=', 1, 2, "";
bfa9dccd 293bin_int_test '==', 1, 2, "";
577914ca 294bin_int_test '!=', 1, 2, 1;
4cdd48d8 295bin_int_test '<=>', 1, 2, -1;
c31c2913
FC
296tie $var, "main", 1, 4;
297cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var');
298check_count 'atan2', 2;
b04496fe 299
60ccc62f 300__DATA__