2 # Tests counting number of FETCHes.
4 # See Bugs #76814 and #87708.
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.
23 sub TIESCALAR {my $pack = shift; bless [@_], $pack;}
24 sub FETCH {$count ++; @{$_ [0]} == 1 ? ${$_ [0]}[0] : shift @{$_ [0]}}
25 sub STORE { unshift @{$_[0]}, $_[1] }
30 my $expected = shift() // 1;
31 local $::Level = $::Level + 1;
34 $expected == 1 ? "just once" :
35 $expected == 2 ? "twice" :
43 tie my $var => 'main', 1;
46 $dummy = $var ; check_count "=";
47 *dummy = $var ; check_count '*glob = $tied';
50 $dummy = +$var ; check_count "unary +";
51 $dummy = -$var ; check_count "unary -";
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 @dummy = $var .. 1 ; check_count '$tied..1';
66 @dummy = 1 .. $var; check_count '1..$tied';
67 tie my $v42 => 'main', "z";
68 @dummy = $v42 .. "a"; check_count '$tied.."a"';
69 @dummy = "a" .. $v42; check_count '"a"..$tied';
71 # Pre/post in/decrement
72 $var ++ ; check_count 'post ++';
73 $var -- ; check_count 'post --';
74 ++ $var ; check_count 'pre ++';
75 -- $var ; check_count 'pre --';
78 $dummy = $var < 1 ; check_count '<';
79 $dummy = $var <= 1 ; check_count '<=';
80 $dummy = $var == 1 ; check_count '==';
81 $dummy = $var >= 1 ; check_count '>=';
82 $dummy = $var > 1 ; check_count '>';
83 $dummy = $var != 1 ; check_count '!=';
84 $dummy = $var <=> 1 ; check_count '<=>';
87 $dummy = $var lt 1 ; check_count 'lt';
88 $dummy = $var le 1 ; check_count 'le';
89 $dummy = $var eq 1 ; check_count 'eq';
90 $dummy = $var ge 1 ; check_count 'ge';
91 $dummy = $var gt 1 ; check_count 'gt';
92 $dummy = $var ne 1 ; check_count 'ne';
93 $dummy = $var cmp 1 ; check_count 'cmp';
96 $dummy = $var & 1 ; check_count '&';
97 $dummy = $var ^ 1 ; check_count '^';
98 $dummy = $var | 1 ; check_count '|';
99 $dummy = ~$var ; check_count '~';
102 $dummy = !$var ; check_count '!';
103 tie my $v_1, "main", 0;
104 $dummy = $v_1 || 1 ; check_count '||';
105 $dummy = ($v_1 or 1); check_count 'or';
106 $dummy = $var && 1 ; check_count '&&';
107 $dummy = ($var and 1); check_count 'and';
108 $dummy = ($var xor 1); check_count 'xor';
109 $dummy = $var ? 1 : 1 ; check_count '?:';
111 # Overloadable functions
112 $dummy = sin $var ; check_count 'sin';
113 $dummy = cos $var ; check_count 'cos';
114 $dummy = exp $var ; check_count 'exp';
115 $dummy = abs $var ; check_count 'abs';
116 $dummy = log $var ; check_count 'log';
117 $dummy = sqrt $var ; check_count 'sqrt';
118 $dummy = int $var ; check_count 'int';
119 $var = "inf" for 1..5;
120 $dummy = int $var ; check_count 'int $tied_inf';
121 $dummy = atan2 $var, 1 ; check_count 'atan2';
124 tie my $var0, "main", \*DATA;
125 $dummy = <$var0> ; check_count '<readline>';
127 $var .= <DATA> ; check_count '$tiedref .= <rcatline>';
129 $var .= <DATA> ; check_count '$tiedstr .= <rcatline>';
131 $var .= <DATA> ; check_count '$tiedglob .= <rcatline>';
132 { no warnings "glob";
133 $dummy = <${var}> ; check_count '<glob>';
137 for (split //, 'rwxoRWXOezsfdpSbctugkTBMAC') {
138 no warnings 'unopened';
139 $dummy = eval "-$_ \$var"; check_count "-$_";
140 # Make $var hold a glob:
141 $var = *dummy; $dummy = $var; $count = 0;
142 $dummy = eval "-$_ \$var"; check_count "-$_ \$tied_glob";
144 $var = *dummy; $dummy = $var; $count = 0;
145 eval "\$dummy = -$_ \\\$var";
146 check_count "-$_ \\\$tied_glob";
148 $dummy = -l $var ; check_count '-l';
150 $dummy = -e -e -e $var ; check_count '-e -e';
154 $dummy = $var =~ m/ / ; check_count 'm//';
155 $dummy = $var =~ s/ //; check_count 's///';
157 no warnings 'experimental::smartmatch';
158 $dummy = $var ~~ 1 ; check_count '~~';
160 $dummy = $var =~ y/ //; check_count 'y///';
162 $dummy = $var =~y/ /-/; check_count '$ref =~ y///';
163 /$var/ ; check_count 'm/pattern/';
164 /$var foo/ ; check_count 'm/$tied foo/';
165 s/$var// ; check_count 's/pattern//';
166 s/$var foo// ; check_count 's/$tied foo//';
167 s/./$var/ ; check_count 's//replacement/';
170 tie my $var1 => 'main', \1;
171 $dummy = $$var1 ; check_count '${}';
172 tie my $var2 => 'main', [];
173 $dummy = @$var2 ; check_count '@{}';
174 tie my $var3 => 'main', {};
175 $dummy = %$var3 ; check_count '%{}';
178 tie my $var4 => 'main', *];
179 $dummy = *$var4 ; check_count '*{}';
182 tie my $var5 => 'main', sub {1};
183 $dummy = &$var5 ; check_count '&{}';
187 tie my $var1 => 'main', 1;
188 $dummy = $$var1 ; check_count 'symbolic ${}';
189 $dummy = @$var1 ; check_count 'symbolic @{}';
190 $dummy = %$var1 ; check_count 'symbolic %{}';
191 $dummy = *$var1 ; check_count 'symbolic *{}';
193 $dummy = &$var1 ; check_count 'symbolic &{}';
195 # This test will not be a complete test if *988 has been created
196 # already. If this dies, change it to use another built-in variable.
197 # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which
198 # is why we need the test this way.
199 if (exists $::{988}) {
200 die "*988 already exists. Please adjust this test"
202 tie my $var6 => main => 988;
204 readdir $var6 ; check_count 'symbolic readdir';
205 if (exists $::{973}) { # Need a different variable here
206 die "*973 already exists. Please adjust this test"
208 tie my $var7 => main => 973;
209 defined $$var7 ; check_count 'symbolic defined ${}';
213 $dummy = {$var,$var} ; check_count '{}', 2;
214 $dummy = [$var] ; check_count '[]';
216 tie my $var8 => 'main', 'main';
218 $var8->bolgy ; check_count '->method';
222 # This must be the name of an existing glob to trigger the maximum
223 # number of fetches in 5.14:
224 tie my $var9 => 'main', 'swibble';
226 use constant glumscrin => 'shreggleboughet';
227 *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}';
230 # Functions that operate on filenames or filehandles
231 for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'],
232 [truncate=>'',',0'],[stat=>''],[lstat=>''],[open=>'my $fh,"<&",'],
233 ['()=sort'=>'',' 1,2,3']) {
234 my($op,$args,$postargs) = @$_; $postargs //= '';
235 # This line makes $var8 hold a glob:
236 $var8 = *dummy; $dummy = $var8; $count = 0;
237 eval "$op $args \$var8 $postargs";
238 check_count "$op $args\$tied_glob$postargs";
239 $var8 = *dummy; $dummy = $var8; $count = 0;
241 eval "$op $args \$ref $postargs";
242 check_count "$op $args\\\$tied_glob$postargs";
245 $dummy = crypt $var,0; check_count 'crypt $tied, ...';
246 $dummy = crypt 0,$var; check_count 'crypt ..., $tied';
247 $var = substr(chr 256,0,0);
248 $dummy = crypt $var,0; check_count 'crypt $tied_utf8, ...';
249 $var = substr(chr 256,0,0);
250 $dummy = crypt 0,$var; check_count 'crypt ..., $tied_utf8';
254 skip "select not implemented on Win32 miniperl", 3
255 if $^O eq "MSWin32" and is_miniperl;
258 $dummy = select $var, undef, undef, 0
259 ; check_count 'select $tied_glob, ...';
261 $dummy = select $var, undef, undef, 0
262 ; check_count 'select $tied_ref, ...';
264 $dummy = select $var, undef, undef, 0
265 ; check_count 'select $tied_undef, ...';
268 chop(my $u = "\xff\x{100}");
269 tie $var, "main", $u;
270 $dummy = pack "u", $var; check_count 'pack "u", $utf8';
272 $dummy = pack "w", $var; check_count 'pack "w", $tied_int';
273 $var = "111111111111111111111111111111111111111111111111111111111111111";
274 $dummy = eval { pack "w", $var };
275 check_count 'pack "w", $tied_huge_int_as_str';
277 tie $var, "main", "\x{100}";
278 pos$var = 0 ; check_count 'lvalue pos $utf8';
279 $dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8';
280 $dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8';
282 tie $var, "main", 23;
283 for (qw(B b c D d i O o p u U X x)) {
284 $dummy=sprintf"%$_",$var; check_count "sprintf '%$_'"
286 tie $var, "main", "Inf";
287 for (qw(B b c D d i O o p u U X x)) {
288 $dummy = eval { sprintf "%$_", $var };
289 check_count "sprintf '%$_', \$tied_inf"
292 tie $var, "main", "\x{100}";
293 $dummy = substr$var,0,1; check_count 'substr $utf8';
294 my $l =\substr$var,0,1;
295 $dummy = $$l ; check_count 'reading lvalue substr($utf8)';
296 $$l = 0 ; check_count 'setting lvalue substr($utf8)';
297 tie $var, "main", "a";
298 $$l = "\x{100}" ; check_count 'assigning $utf8 to lvalue substr';
299 tie $var1, "main", "a";
300 substr$var1,0,0,"\x{100}"; check_count '4-arg substr with utf8 replacement';
303 local $SIG{__WARN__} = sub {};
304 $dummy = warn $var ; check_count 'warn $tied';
305 tie $@, => 'main', 1;
306 $dummy = warn ; check_count 'warn() with $@ tied (num)';
307 tie $@, => 'main', \1;
308 $dummy = warn ; check_count 'warn() with $@ tied (ref)';
309 tie $@, => 'main', "foo\n";
310 $dummy = warn ; check_count 'warn() with $@ tied (str)';
314 ###############################################
315 # Tests for $foo binop $foo #
316 ###############################################
318 # These test that binary ops call FETCH twice if the same scalar is used
319 # for both operands. They also test that both return values from
322 my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^);
331 $int = $int ? 'use integer; ' : '';
333 tie my $var, "main", @fetches;
334 is(eval "$int\$var $op \$var", $exp, "retval of $int\$var $op \$var");
335 check_count "$int$op", 2;
337 return unless $mutators{$op};
339 tie my $var2, "main", @fetches;
340 is(eval "$int \$var2 $op= \$var2", $exp, "retval of $int \$var2 $op= \$var2");
341 check_count "$int$op=", 3;
352 bin_test '**', 2, 3, 8;
353 bin_test '*' , 2, 3, 6;
354 bin_test '/' , 10, 2, 5;
355 bin_test '%' , 11, 2, 1;
356 bin_test 'x' , 11, 2, 1111;
357 bin_test '-' , 11, 2, 9;
358 bin_test '<<', 11, 2, 44;
359 bin_test '>>', 44, 2, 11;
360 bin_test '<' , 1, 2, 1;
361 bin_test '>' , 44, 2, 1;
362 bin_test '<=', 44, 2, "";
363 bin_test '>=', 1, 2, "";
364 bin_test '!=', 1, 2, 1;
365 bin_test '<=>', 1, 2, -1;
366 bin_test 'le', 4, 2, "";
367 bin_test 'lt', 1, 2, 1;
368 bin_test 'gt', 4, 2, 1;
369 bin_test 'ge', 1, 2, "";
370 bin_test 'eq', 1, 2, "";
371 bin_test 'ne', 1, 2, 1;
372 bin_test 'cmp', 1, 2, -1;
373 bin_test '&' , 1, 2, 0;
374 bin_test '|' , 1, 2, 3;
375 bin_test '^' , 3, 5, 6;
376 bin_test '.' , 1, 2, 12;
377 bin_test '==', 1, 2, "";
378 bin_test '+' , 1, 2, 3;
379 bin_int_test '*' , 2, 3, 6;
380 bin_int_test '/' , 10, 2, 5;
381 bin_int_test '%' , 11, 2, 1;
382 bin_int_test '+' , 1, 2, 3;
383 bin_int_test '-' , 11, 2, 9;
384 bin_int_test '<' , 1, 2, 1;
385 bin_int_test '>' , 44, 2, 1;
386 bin_int_test '<=', 44, 2, "";
387 bin_int_test '>=', 1, 2, "";
388 bin_int_test '==', 1, 2, "";
389 bin_int_test '!=', 1, 2, 1;
390 bin_int_test '<=>', 1, 2, -1;
391 tie $var, "main", 1, 4;
392 cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var');
393 check_count 'atan2', 2;