This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tests to check if FETCH of a tied variable isn't called more
[perl5.git] / t / op / tie_fetch_count.t
CommitLineData
60ccc62f
A
1#!./perl
2# Tests counting number of FETCHes.
3#
4# See Bug #76814.
5
6BEGIN {
7 chdir 't' if -d 't';
8 @INC = '../lib';
9 require './test.pl';
10 plan (tests => 92);
11}
12
13use strict;
14use warnings;
15
16my $TODO = "Bug 76814";
17
18my $count = 0;
19
20sub TIESCALAR {bless \do {my $var = $_ [1]} => $_ [0];}
21sub FETCH {$count ++; ${$_ [0]}}
22sub STORE {1;}
23
24
25sub check_count {
26 my $op = shift;
27 ok $count == 1, "FETCH called just once using '$op'",
28 "FETCH called $count times";
29 $count = 0;
30}
31
32my ($dummy, @dummy);
33
34tie my $var => 'main', 1;
35
36# Assignment.
37$dummy = $var ; check_count "=";
38
39# Unary +/-
40$dummy = +$var ; check_count "unary +";
41$dummy = -$var ; check_count "unary -";
42
43# Basic arithmetic and string operators.
44$dummy = $var + 1 ; check_count '+';
45$dummy = $var - 1 ; check_count '-';
46$dummy = $var / 1 ; check_count '/';
47$dummy = $var * 1 ; check_count '*';
48$dummy = $var % 1 ; check_count '%';
49$dummy = $var ** 1 ; check_count '**';
50$dummy = $var << 1 ; check_count '<<';
51$dummy = $var >> 1 ; check_count '>>';
52$dummy = $var x 1 ; check_count 'x';
53@dummy = ($var) x 1 ; check_count 'x';
54$dummy = $var . 1 ; check_count '.';
55
56# Pre/post in/decrement
57 $var ++ ; check_count 'post ++';
58 $var -- ; check_count 'post --';
59 ++ $var ; check_count 'pre ++';
60 -- $var ; check_count 'pre --';
61
62# Numeric comparison
63$dummy = $var < 1 ; check_count '<';
64$dummy = $var <= 1 ; check_count '<=';
65$dummy = $var == 1 ; check_count '==';
66$dummy = $var >= 1 ; check_count '>=';
67$dummy = $var > 1 ; check_count '>';
68$dummy = $var != 1 ; check_count '!=';
69$dummy = $var <=> 1 ; check_count '<=>';
70
71# String comparison
72TODO: {
73 local $::TODO = $TODO;
74 $dummy = $var lt 1 ; check_count 'lt';
75 $dummy = $var le 1 ; check_count 'le';
76 $dummy = $var eq 1 ; check_count 'eq';
77 $dummy = $var ge 1 ; check_count 'ge';
78 $dummy = $var gt 1 ; check_count 'gt';
79 $dummy = $var ne 1 ; check_count 'ne';
80 $dummy = $var cmp 1 ; check_count 'cmp';
81}
82
83# Bitwise operators
84$dummy = $var & 1 ; check_count '&';
85$dummy = $var ^ 1 ; check_count '^';
86$dummy = $var | 1 ; check_count '|';
87$dummy = ~$var ; check_count '~';
88
89# Logical operators
90TODO: {
91 local $::TODO = $TODO;
92 $dummy = !$var ; check_count '!';
93 $dummy = $var || 1 ; check_count '||';
94 $dummy = ($var or 1); check_count 'or';
95}
96$dummy = $var && 1 ; check_count '&&';
97$dummy = ($var and 1); check_count 'and';
98$dummy = ($var xor 1); check_count 'xor';
99$dummy = $var ? 1 : 1 ; check_count '?:';
100
101# Overloadable functions
102$dummy = sin $var ; check_count 'sin';
103$dummy = cos $var ; check_count 'cos';
104$dummy = exp $var ; check_count 'exp';
105$dummy = abs $var ; check_count 'abs';
106$dummy = log $var ; check_count 'log';
107$dummy = sqrt $var ; check_count 'sqrt';
108$dummy = int $var ; check_count 'int';
109$dummy = atan2 $var, 1 ; check_count 'atan2';
110
111# Readline/glob
112tie my $var0, "main", \*DATA;
113$dummy = <$var0> ; check_count '<readline>';
114$dummy = <${var}> ; check_count '<glob>';
115
116# File operators
117$dummy = -r $var ; check_count '-r';
118$dummy = -w $var ; check_count '-w';
119$dummy = -x $var ; check_count '-x';
120$dummy = -o $var ; check_count '-o';
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 = -e $var ; check_count '-e';
126$dummy = -z $var ; check_count '-z';
127$dummy = -s $var ; check_count '-s';
128$dummy = -f $var ; check_count '-f';
129$dummy = -d $var ; check_count '-d';
130$dummy = -l $var ; check_count '-l';
131$dummy = -p $var ; check_count '-p';
132$dummy = -S $var ; check_count '-S';
133$dummy = -b $var ; check_count '-b';
134$dummy = -c $var ; check_count '-c';
135$dummy = -t $var ; check_count '-t';
136$dummy = -u $var ; check_count '-u';
137$dummy = -g $var ; check_count '-g';
138$dummy = -k $var ; check_count '-k';
139$dummy = -T $var ; check_count '-T';
140$dummy = -B $var ; check_count '-B';
141$dummy = -M $var ; check_count '-M';
142$dummy = -A $var ; check_count '-A';
143$dummy = -C $var ; check_count '-C';
144
145# Matching
146$_ = "foo";
147$dummy = $var =~ m/ / ; check_count 'm//';
148$dummy = $var =~ s/ //; check_count 's///';
149$dummy = $var ~~ 1 ; check_count '~~';
150TODO: {
151 local $::TODO = $TODO;
152 $dummy = $var =~ y/ //; check_count 'y///';
153 /$var/ ; check_count 'm/pattern/';
154 s/$var// ; check_count 's/pattern//';
155}
156 s/./$var/ ; check_count 's//replacement/';
157
158# Dereferencing
159tie my $var1 => 'main', \1;
160$dummy = $$var1 ; check_count '${}';
161tie my $var2 => 'main', [];
162$dummy = @$var2 ; check_count '@{}';
163tie my $var3 => 'main', {};
164$dummy = %$var3 ; check_count '%{}';
165{
166 no strict 'refs';
167 tie my $var4 => 'main', **;
168 $dummy = *$var4 ; check_count '*{}';
169}
170
171tie my $var5 => 'main', sub {1};
172$dummy = &$var5 ; check_count '&{}';
173
174__DATA__