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