Commit | Line | Data |
---|---|---|
60ccc62f A |
1 | #!./perl |
2 | # Tests counting number of FETCHes. | |
3 | # | |
b04496fe | 4 | # See Bugs #76814 and #87708. |
60ccc62f A |
5 | |
6 | BEGIN { | |
7 | chdir 't' if -d 't'; | |
60ccc62f | 8 | require './test.pl'; |
43ece5b1 | 9 | set_up_inc('../lib'); |
60ccc62f A |
10 | } |
11 | ||
7896dde7 | 12 | plan (tests => 343); |
624c42e2 | 13 | |
60ccc62f A |
14 | use strict; |
15 | use warnings; | |
16 | ||
aa3ecafd JH |
17 | my $can_config = eval { require Config; 1 }; |
18 | ||
60ccc62f A |
19 | my $count = 0; |
20 | ||
b04496fe FC |
21 | # Usage: |
22 | # tie $var, "main", $val; # FETCH returns $val | |
23 | # tie $var, "main", $val1, $val2; # FETCH returns the values in order, | |
24 | # # one at a time, repeating the last | |
25 | # # when the list is exhausted. | |
26 | sub TIESCALAR {my $pack = shift; bless [@_], $pack;} | |
27 | sub FETCH {$count ++; @{$_ [0]} == 1 ? ${$_ [0]}[0] : shift @{$_ [0]}} | |
9c9a2500 | 28 | sub STORE { unshift @{$_[0]}, $_[1] } |
60ccc62f A |
29 | |
30 | ||
31 | sub check_count { | |
32 | my $op = shift; | |
b04496fe | 33 | my $expected = shift() // 1; |
5e0b4493 | 34 | local $::Level = $::Level + 1; |
b04496fe FC |
35 | is $count, $expected, |
36 | "FETCH called " . ( | |
37 | $expected == 1 ? "just once" : | |
38 | $expected == 2 ? "twice" : | |
39 | "$count times" | |
40 | ) . " using '$op'"; | |
60ccc62f A |
41 | $count = 0; |
42 | } | |
43 | ||
44 | my ($dummy, @dummy); | |
45 | ||
46 | tie my $var => 'main', 1; | |
47 | ||
48 | # Assignment. | |
49 | $dummy = $var ; check_count "="; | |
93564729 | 50 | *dummy = $var ; check_count '*glob = $tied'; |
60ccc62f A |
51 | |
52 | # Unary +/- | |
53 | $dummy = +$var ; check_count "unary +"; | |
54 | $dummy = -$var ; check_count "unary -"; | |
55 | ||
56 | # Basic arithmetic and string operators. | |
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 ** 1 ; check_count '**'; | |
63 | $dummy = $var << 1 ; check_count '<<'; | |
64 | $dummy = $var >> 1 ; check_count '>>'; | |
65 | $dummy = $var x 1 ; check_count 'x'; | |
66 | @dummy = ($var) x 1 ; check_count 'x'; | |
67 | $dummy = $var . 1 ; check_count '.'; | |
f52e41ad FC |
68 | @dummy = $var .. 1 ; check_count '$tied..1'; |
69 | @dummy = 1 .. $var; check_count '1..$tied'; | |
70 | tie my $v42 => 'main', "z"; | |
71 | @dummy = $v42 .. "a"; check_count '$tied.."a"'; | |
72 | @dummy = "a" .. $v42; check_count '"a"..$tied'; | |
60ccc62f A |
73 | |
74 | # Pre/post in/decrement | |
75 | $var ++ ; check_count 'post ++'; | |
76 | $var -- ; check_count 'post --'; | |
77 | ++ $var ; check_count 'pre ++'; | |
78 | -- $var ; check_count 'pre --'; | |
79 | ||
80 | # Numeric comparison | |
81 | $dummy = $var < 1 ; check_count '<'; | |
82 | $dummy = $var <= 1 ; check_count '<='; | |
83 | $dummy = $var == 1 ; check_count '=='; | |
84 | $dummy = $var >= 1 ; check_count '>='; | |
85 | $dummy = $var > 1 ; check_count '>'; | |
86 | $dummy = $var != 1 ; check_count '!='; | |
87 | $dummy = $var <=> 1 ; check_count '<=>'; | |
88 | ||
89 | # String comparison | |
078504b2 FC |
90 | $dummy = $var lt 1 ; check_count 'lt'; |
91 | $dummy = $var le 1 ; check_count 'le'; | |
92 | $dummy = $var eq 1 ; check_count 'eq'; | |
93 | $dummy = $var ge 1 ; check_count 'ge'; | |
94 | $dummy = $var gt 1 ; check_count 'gt'; | |
95 | $dummy = $var ne 1 ; check_count 'ne'; | |
96 | $dummy = $var cmp 1 ; check_count 'cmp'; | |
60ccc62f A |
97 | |
98 | # Bitwise operators | |
99 | $dummy = $var & 1 ; check_count '&'; | |
100 | $dummy = $var ^ 1 ; check_count '^'; | |
101 | $dummy = $var | 1 ; check_count '|'; | |
102 | $dummy = ~$var ; check_count '~'; | |
103 | ||
104 | # Logical operators | |
06c841cf | 105 | $dummy = !$var ; check_count '!'; |
1c3caf3f FC |
106 | tie my $v_1, "main", 0; |
107 | $dummy = $v_1 || 1 ; check_count '||'; | |
108 | $dummy = ($v_1 or 1); check_count 'or'; | |
60ccc62f A |
109 | $dummy = $var && 1 ; check_count '&&'; |
110 | $dummy = ($var and 1); check_count 'and'; | |
111 | $dummy = ($var xor 1); check_count 'xor'; | |
112 | $dummy = $var ? 1 : 1 ; check_count '?:'; | |
113 | ||
114 | # Overloadable functions | |
115 | $dummy = sin $var ; check_count 'sin'; | |
116 | $dummy = cos $var ; check_count 'cos'; | |
117 | $dummy = exp $var ; check_count 'exp'; | |
118 | $dummy = abs $var ; check_count 'abs'; | |
119 | $dummy = log $var ; check_count 'log'; | |
120 | $dummy = sqrt $var ; check_count 'sqrt'; | |
121 | $dummy = int $var ; check_count 'int'; | |
aa3ecafd JH |
122 | SKIP: { |
123 | unless ($can_config) { | |
124 | skip "no config (no infinity for int)", 1; | |
125 | } | |
126 | unless ($Config::Config{d_double_has_inf}) { | |
127 | skip "no infinity for int", 1; | |
128 | } | |
b9d05018 FC |
129 | $var = "inf" for 1..5; |
130 | $dummy = int $var ; check_count 'int $tied_inf'; | |
aa3ecafd | 131 | } |
60ccc62f A |
132 | $dummy = atan2 $var, 1 ; check_count 'atan2'; |
133 | ||
134 | # Readline/glob | |
135 | tie my $var0, "main", \*DATA; | |
136 | $dummy = <$var0> ; check_count '<readline>'; | |
5668452f FC |
137 | $var = \1; |
138 | $var .= <DATA> ; check_count '$tiedref .= <rcatline>'; | |
139 | $var = "tied"; | |
140 | $var .= <DATA> ; check_count '$tiedstr .= <rcatline>'; | |
141 | $var = *foo; | |
142 | $var .= <DATA> ; check_count '$tiedglob .= <rcatline>'; | |
d03ce4f5 FC |
143 | { no warnings "glob"; |
144 | $dummy = <${var}> ; check_count '<glob>'; | |
145 | } | |
60ccc62f A |
146 | |
147 | # File operators | |
094a3eec FC |
148 | for (split //, 'rwxoRWXOezsfdpSbctugkTBMAC') { |
149 | no warnings 'unopened'; | |
150 | $dummy = eval "-$_ \$var"; check_count "-$_"; | |
151 | # Make $var hold a glob: | |
152 | $var = *dummy; $dummy = $var; $count = 0; | |
153 | $dummy = eval "-$_ \$var"; check_count "-$_ \$tied_glob"; | |
026624ed | 154 | next if /[guk]/; |
094a3eec | 155 | $var = *dummy; $dummy = $var; $count = 0; |
026624ed FC |
156 | eval "\$dummy = -$_ \\\$var"; |
157 | check_count "-$_ \\\$tied_glob"; | |
094a3eec | 158 | } |
60ccc62f | 159 | $dummy = -l $var ; check_count '-l'; |
c5780028 FC |
160 | $var = "test.pl"; |
161 | $dummy = -e -e -e $var ; check_count '-e -e'; | |
60ccc62f A |
162 | |
163 | # Matching | |
164 | $_ = "foo"; | |
165 | $dummy = $var =~ m/ / ; check_count 'm//'; | |
166 | $dummy = $var =~ s/ //; check_count 's///'; | |
7896dde7 Z |
167 | { |
168 | no warnings 'experimental::smartmatch'; | |
169 | $dummy = $var ~~ 1 ; check_count '~~'; | |
170 | } | |
9138d6ca | 171 | $dummy = $var =~ y/ //; check_count 'y///'; |
b4cc4d79 FC |
172 | $var = \1; |
173 | $dummy = $var =~y/ /-/; check_count '$ref =~ y///'; | |
a9984b10 FC |
174 | /$var/ ; check_count 'm/pattern/'; |
175 | /$var foo/ ; check_count 'm/$tied foo/'; | |
176 | s/$var// ; check_count 's/pattern//'; | |
177 | s/$var foo// ; check_count 's/$tied foo//'; | |
60ccc62f A |
178 | s/./$var/ ; check_count 's//replacement/'; |
179 | ||
180 | # Dereferencing | |
181 | tie my $var1 => 'main', \1; | |
182 | $dummy = $$var1 ; check_count '${}'; | |
183 | tie my $var2 => 'main', []; | |
184 | $dummy = @$var2 ; check_count '@{}'; | |
185 | tie my $var3 => 'main', {}; | |
186 | $dummy = %$var3 ; check_count '%{}'; | |
0953b66b | 187 | { |
60ccc62f | 188 | no strict 'refs'; |
05c5ed48 | 189 | tie my $var4 => 'main', *]; |
60ccc62f A |
190 | $dummy = *$var4 ; check_count '*{}'; |
191 | } | |
192 | ||
193 | tie my $var5 => 'main', sub {1}; | |
194 | $dummy = &$var5 ; check_count '&{}'; | |
195 | ||
7ffa7e75 FC |
196 | { |
197 | no strict 'refs'; | |
198 | tie my $var1 => 'main', 1; | |
199 | $dummy = $$var1 ; check_count 'symbolic ${}'; | |
200 | $dummy = @$var1 ; check_count 'symbolic @{}'; | |
201 | $dummy = %$var1 ; check_count 'symbolic %{}'; | |
202 | $dummy = *$var1 ; check_count 'symbolic *{}'; | |
203 | local *1 = sub{}; | |
204 | $dummy = &$var1 ; check_count 'symbolic &{}'; | |
ed996e63 | 205 | |
c00274d3 | 206 | # This test will not be a complete test if *988 has been created |
ed996e63 FC |
207 | # already. If this dies, change it to use another built-in variable. |
208 | # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which | |
209 | # is why we need the test this way. | |
c00274d3 FC |
210 | if (exists $::{988}) { |
211 | die "*988 already exists. Please adjust this test" | |
ed996e63 | 212 | } |
c00274d3 | 213 | tie my $var6 => main => 988; |
ed996e63 FC |
214 | no warnings; |
215 | readdir $var6 ; check_count 'symbolic readdir'; | |
ad6acfc4 FC |
216 | if (exists $::{973}) { # Need a different variable here |
217 | die "*973 already exists. Please adjust this test" | |
218 | } | |
219 | tie my $var7 => main => 973; | |
220 | defined $$var7 ; check_count 'symbolic defined ${}'; | |
7ffa7e75 | 221 | } |
b04496fe | 222 | |
d187b712 FC |
223 | # Constructors |
224 | $dummy = {$var,$var} ; check_count '{}', 2; | |
225 | $dummy = [$var] ; check_count '[]'; | |
226 | ||
da6b625f FC |
227 | tie my $var8 => 'main', 'main'; |
228 | sub bolgy {} | |
229 | $var8->bolgy ; check_count '->method'; | |
33d4ef81 | 230 | { |
f8ccc5c6 | 231 | no warnings 'once'; |
33d4ef81 FC |
232 | () = *swibble; |
233 | # This must be the name of an existing glob to trigger the maximum | |
234 | # number of fetches in 5.14: | |
235 | tie my $var9 => 'main', 'swibble'; | |
236 | no strict 'refs'; | |
237 | use constant glumscrin => 'shreggleboughet'; | |
238 | *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}'; | |
239 | } | |
da6b625f | 240 | |
d06f995a | 241 | # Functions that operate on filenames or filehandles |
5e0adc2d | 242 | for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'], |
8d9d90d5 FC |
243 | [truncate=>'',',0'],[stat=>''],[lstat=>''],[open=>'my $fh,"<&",'], |
244 | ['()=sort'=>'',' 1,2,3']) { | |
5e0adc2d | 245 | my($op,$args,$postargs) = @$_; $postargs //= ''; |
d06f995a FC |
246 | # This line makes $var8 hold a glob: |
247 | $var8 = *dummy; $dummy = $var8; $count = 0; | |
5e0adc2d FC |
248 | eval "$op $args \$var8 $postargs"; |
249 | check_count "$op $args\$tied_glob$postargs"; | |
d06f995a | 250 | $var8 = *dummy; $dummy = $var8; $count = 0; |
8d9d90d5 FC |
251 | my $ref = \$var8; |
252 | eval "$op $args \$ref $postargs"; | |
5e0adc2d | 253 | check_count "$op $args\\\$tied_glob$postargs"; |
d06f995a | 254 | } |
93564729 | 255 | |
48d9c427 TC |
256 | SKIP: |
257 | { | |
258 | skip "No Config", 4 unless $can_config; | |
259 | skip "No crypt()", 4 unless $Config::Config{d_crypt}; | |
260 | $dummy = crypt $var,0; check_count 'crypt $tied, ...'; | |
261 | $dummy = crypt 0,$var; check_count 'crypt ..., $tied'; | |
262 | $var = substr(chr 256,0,0); | |
263 | $dummy = crypt $var,0; check_count 'crypt $tied_utf8, ...'; | |
264 | $var = substr(chr 256,0,0); | |
265 | $dummy = crypt 0,$var; check_count 'crypt ..., $tied_utf8'; | |
266 | } | |
659fbb76 | 267 | |
74416803 | 268 | SKIP: |
9d6d5a79 | 269 | { |
74416803 TC |
270 | skip "select not implemented on Win32 miniperl", 3 |
271 | if $^O eq "MSWin32" and is_miniperl; | |
9d6d5a79 FC |
272 | no warnings; |
273 | $var = *foo; | |
274 | $dummy = select $var, undef, undef, 0 | |
275 | ; check_count 'select $tied_glob, ...'; | |
276 | $var = \1; | |
277 | $dummy = select $var, undef, undef, 0 | |
278 | ; check_count 'select $tied_ref, ...'; | |
279 | $var = undef; | |
280 | $dummy = select $var, undef, undef, 0 | |
281 | ; check_count 'select $tied_undef, ...'; | |
282 | } | |
283 | ||
3f63b0e5 FC |
284 | chop(my $u = "\xff\x{100}"); |
285 | tie $var, "main", $u; | |
286 | $dummy = pack "u", $var; check_count 'pack "u", $utf8'; | |
1e9a122e FC |
287 | $var = 0; |
288 | $dummy = pack "w", $var; check_count 'pack "w", $tied_int'; | |
289 | $var = "111111111111111111111111111111111111111111111111111111111111111"; | |
290 | $dummy = eval { pack "w", $var }; | |
291 | check_count 'pack "w", $tied_huge_int_as_str'; | |
3f63b0e5 | 292 | |
92cf6698 FC |
293 | tie $var, "main", "\x{100}"; |
294 | pos$var = 0 ; check_count 'lvalue pos $utf8'; | |
4b8b6103 | 295 | $dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8'; |
d8f2f090 | 296 | $dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8'; |
77b030b5 | 297 | |
84a826ef | 298 | my @fmt = qw(B b c D d i O o u U X x); |
aa3ecafd | 299 | |
77b030b5 | 300 | tie $var, "main", 23; |
aa3ecafd | 301 | for (@fmt) { |
77b030b5 FC |
302 | $dummy=sprintf"%$_",$var; check_count "sprintf '%$_'" |
303 | } | |
aa3ecafd JH |
304 | SKIP: { |
305 | unless ($can_config) { | |
306 | skip "no Config (no infinity for sprintf @fmt)", scalar @fmt; | |
307 | } | |
308 | unless ($Config::Config{d_double_has_inf}) { | |
309 | skip "no infinity for sprintf @fmt", scalar @fmt; | |
310 | } | |
77b030b5 | 311 | tie $var, "main", "Inf"; |
aa3ecafd | 312 | for (@fmt) { |
77b030b5 FC |
313 | $dummy = eval { sprintf "%$_", $var }; |
314 | check_count "sprintf '%$_', \$tied_inf" | |
315 | } | |
aa3ecafd | 316 | } |
77b030b5 FC |
317 | |
318 | tie $var, "main", "\x{100}"; | |
864329c3 | 319 | $dummy = substr$var,0,1; check_count 'substr $utf8'; |
a4036ec1 FC |
320 | my $l =\substr$var,0,1; |
321 | $dummy = $$l ; check_count 'reading lvalue substr($utf8)'; | |
ab445a17 | 322 | $$l = 0 ; check_count 'setting lvalue substr($utf8)'; |
73a087f0 FC |
323 | tie $var, "main", "a"; |
324 | $$l = "\x{100}" ; check_count 'assigning $utf8 to lvalue substr'; | |
01680ee9 FC |
325 | tie $var1, "main", "a"; |
326 | substr$var1,0,0,"\x{100}"; check_count '4-arg substr with utf8 replacement'; | |
864329c3 | 327 | |
ef5fe392 FC |
328 | { |
329 | local $SIG{__WARN__} = sub {}; | |
330 | $dummy = warn $var ; check_count 'warn $tied'; | |
331 | tie $@, => 'main', 1; | |
332 | $dummy = warn ; check_count 'warn() with $@ tied (num)'; | |
333 | tie $@, => 'main', \1; | |
334 | $dummy = warn ; check_count 'warn() with $@ tied (ref)'; | |
335 | tie $@, => 'main', "foo\n"; | |
336 | $dummy = warn ; check_count 'warn() with $@ tied (str)'; | |
337 | untie $@; | |
338 | } | |
339 | ||
b04496fe FC |
340 | ############################################### |
341 | # Tests for $foo binop $foo # | |
342 | ############################################### | |
343 | ||
344 | # These test that binary ops call FETCH twice if the same scalar is used | |
345 | # for both operands. They also test that both return values from | |
346 | # FETCH are used. | |
347 | ||
9c9a2500 DM |
348 | my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^); |
349 | ||
350 | ||
351 | sub _bin_test { | |
352 | my $int = shift; | |
b04496fe | 353 | my $op = shift; |
9c9a2500 DM |
354 | my $exp = pop; |
355 | my @fetches = @_; | |
356 | ||
357 | $int = $int ? 'use integer; ' : ''; | |
358 | ||
359 | tie my $var, "main", @fetches; | |
360 | is(eval "$int\$var $op \$var", $exp, "retval of $int\$var $op \$var"); | |
361 | check_count "$int$op", 2; | |
362 | ||
363 | return unless $mutators{$op}; | |
364 | ||
365 | tie my $var2, "main", @fetches; | |
366 | is(eval "$int \$var2 $op= \$var2", $exp, "retval of $int \$var2 $op= \$var2"); | |
367 | check_count "$int$op=", 3; | |
368 | } | |
369 | ||
370 | sub bin_test { | |
371 | _bin_test(0, @_); | |
b04496fe | 372 | } |
9c9a2500 | 373 | |
b04496fe | 374 | sub bin_int_test { |
9c9a2500 | 375 | _bin_test(1, @_); |
b04496fe FC |
376 | } |
377 | ||
75ea7a12 FC |
378 | bin_test '**', 2, 3, 8; |
379 | bin_test '*' , 2, 3, 6; | |
380 | bin_test '/' , 10, 2, 5; | |
381 | bin_test '%' , 11, 2, 1; | |
382 | bin_test 'x' , 11, 2, 1111; | |
383 | bin_test '-' , 11, 2, 9; | |
384 | bin_test '<<', 11, 2, 44; | |
385 | bin_test '>>', 44, 2, 11; | |
386 | bin_test '<' , 1, 2, 1; | |
387 | bin_test '>' , 44, 2, 1; | |
388 | bin_test '<=', 44, 2, ""; | |
389 | bin_test '>=', 1, 2, ""; | |
390 | bin_test '!=', 1, 2, 1; | |
391 | bin_test '<=>', 1, 2, -1; | |
392 | bin_test 'le', 4, 2, ""; | |
393 | bin_test 'lt', 1, 2, 1; | |
394 | bin_test 'gt', 4, 2, 1; | |
395 | bin_test 'ge', 1, 2, ""; | |
396 | bin_test 'eq', 1, 2, ""; | |
397 | bin_test 'ne', 1, 2, 1; | |
398 | bin_test 'cmp', 1, 2, -1; | |
399 | bin_test '&' , 1, 2, 0; | |
400 | bin_test '|' , 1, 2, 3; | |
3216d309 | 401 | bin_test '^' , 3, 5, 6; |
b04496fe | 402 | bin_test '.' , 1, 2, 12; |
7d779b23 | 403 | bin_test '==', 1, 2, ""; |
4c3ac4ba | 404 | bin_test '+' , 1, 2, 3; |
96b6b87f | 405 | bin_int_test '*' , 2, 3, 6; |
76422f81 | 406 | bin_int_test '/' , 10, 2, 5; |
96b6b87f | 407 | bin_int_test '%' , 11, 2, 1; |
e62ca0f9 FC |
408 | bin_int_test '+' , 1, 2, 3; |
409 | bin_int_test '-' , 11, 2, 9; | |
9b029393 | 410 | bin_int_test '<' , 1, 2, 1; |
fd2dbd2b | 411 | bin_int_test '>' , 44, 2, 1; |
5c7d20ff | 412 | bin_int_test '<=', 44, 2, ""; |
f2bd3a8b | 413 | bin_int_test '>=', 1, 2, ""; |
bfa9dccd | 414 | bin_int_test '==', 1, 2, ""; |
577914ca | 415 | bin_int_test '!=', 1, 2, 1; |
4cdd48d8 | 416 | bin_int_test '<=>', 1, 2, -1; |
c31c2913 FC |
417 | tie $var, "main", 1, 4; |
418 | cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var'); | |
419 | check_count 'atan2', 2; | |
b04496fe | 420 | |
60ccc62f | 421 | __DATA__ |