| 1 | #!./perl |
| 2 | # Tests counting number of FETCHes. |
| 3 | # |
| 4 | # See Bugs #76814 and #87708. |
| 5 | |
| 6 | BEGIN { |
| 7 | chdir 't' if -d 't'; |
| 8 | require './test.pl'; |
| 9 | set_up_inc('../lib'); |
| 10 | } |
| 11 | |
| 12 | plan (tests => 343); |
| 13 | |
| 14 | use strict; |
| 15 | use warnings; |
| 16 | |
| 17 | my $can_config = eval { require Config; 1 }; |
| 18 | |
| 19 | my $count = 0; |
| 20 | |
| 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]}} |
| 28 | sub STORE { unshift @{$_[0]}, $_[1] } |
| 29 | |
| 30 | |
| 31 | sub check_count { |
| 32 | my $op = shift; |
| 33 | my $expected = shift() // 1; |
| 34 | local $::Level = $::Level + 1; |
| 35 | is $count, $expected, |
| 36 | "FETCH called " . ( |
| 37 | $expected == 1 ? "just once" : |
| 38 | $expected == 2 ? "twice" : |
| 39 | "$count times" |
| 40 | ) . " using '$op'"; |
| 41 | $count = 0; |
| 42 | } |
| 43 | |
| 44 | my ($dummy, @dummy); |
| 45 | |
| 46 | tie my $var => 'main', 1; |
| 47 | |
| 48 | # Assignment. |
| 49 | $dummy = $var ; check_count "="; |
| 50 | *dummy = $var ; check_count '*glob = $tied'; |
| 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 '.'; |
| 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'; |
| 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 |
| 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'; |
| 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 |
| 105 | $dummy = !$var ; check_count '!'; |
| 106 | tie my $v_1, "main", 0; |
| 107 | $dummy = $v_1 || 1 ; check_count '||'; |
| 108 | $dummy = ($v_1 or 1); check_count 'or'; |
| 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'; |
| 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 | } |
| 129 | $var = "inf" for 1..5; |
| 130 | $dummy = int $var ; check_count 'int $tied_inf'; |
| 131 | } |
| 132 | $dummy = atan2 $var, 1 ; check_count 'atan2'; |
| 133 | |
| 134 | # Readline/glob |
| 135 | tie my $var0, "main", \*DATA; |
| 136 | $dummy = <$var0> ; check_count '<readline>'; |
| 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>'; |
| 143 | { no warnings "glob"; |
| 144 | $dummy = <${var}> ; check_count '<glob>'; |
| 145 | } |
| 146 | |
| 147 | # File operators |
| 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"; |
| 154 | next if /[guk]/; |
| 155 | $var = *dummy; $dummy = $var; $count = 0; |
| 156 | eval "\$dummy = -$_ \\\$var"; |
| 157 | check_count "-$_ \\\$tied_glob"; |
| 158 | } |
| 159 | $dummy = -l $var ; check_count '-l'; |
| 160 | $var = "test.pl"; |
| 161 | $dummy = -e -e -e $var ; check_count '-e -e'; |
| 162 | |
| 163 | # Matching |
| 164 | $_ = "foo"; |
| 165 | $dummy = $var =~ m/ / ; check_count 'm//'; |
| 166 | $dummy = $var =~ s/ //; check_count 's///'; |
| 167 | { |
| 168 | no warnings 'deprecated'; |
| 169 | $dummy = $var ~~ 1 ; check_count '~~'; |
| 170 | } |
| 171 | $dummy = $var =~ y/ //; check_count 'y///'; |
| 172 | $var = \1; |
| 173 | $dummy = $var =~y/ /-/; check_count '$ref =~ y///'; |
| 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//'; |
| 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 '%{}'; |
| 187 | { |
| 188 | no strict 'refs'; |
| 189 | tie my $var4 => 'main', *]; |
| 190 | $dummy = *$var4 ; check_count '*{}'; |
| 191 | } |
| 192 | |
| 193 | tie my $var5 => 'main', sub {1}; |
| 194 | $dummy = &$var5 ; check_count '&{}'; |
| 195 | |
| 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 &{}'; |
| 205 | |
| 206 | # This test will not be a complete test if *988 has been created |
| 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. |
| 210 | if (exists $::{988}) { |
| 211 | die "*988 already exists. Please adjust this test" |
| 212 | } |
| 213 | tie my $var6 => main => 988; |
| 214 | no warnings; |
| 215 | readdir $var6 ; check_count 'symbolic readdir'; |
| 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 ${}'; |
| 221 | } |
| 222 | |
| 223 | # Constructors |
| 224 | $dummy = {$var,$var} ; check_count '{}', 2; |
| 225 | $dummy = [$var] ; check_count '[]'; |
| 226 | |
| 227 | tie my $var8 => 'main', 'main'; |
| 228 | sub bolgy {} |
| 229 | $var8->bolgy ; check_count '->method'; |
| 230 | { |
| 231 | no warnings 'once'; |
| 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 | } |
| 240 | |
| 241 | # Functions that operate on filenames or filehandles |
| 242 | for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'], |
| 243 | [truncate=>'',',0'],[stat=>''],[lstat=>''],[open=>'my $fh,"<&",'], |
| 244 | ['()=sort'=>'',' 1,2,3']) { |
| 245 | my($op,$args,$postargs) = @$_; $postargs //= ''; |
| 246 | # This line makes $var8 hold a glob: |
| 247 | $var8 = *dummy; $dummy = $var8; $count = 0; |
| 248 | eval "$op $args \$var8 $postargs"; |
| 249 | check_count "$op $args\$tied_glob$postargs"; |
| 250 | $var8 = *dummy; $dummy = $var8; $count = 0; |
| 251 | my $ref = \$var8; |
| 252 | eval "$op $args \$ref $postargs"; |
| 253 | check_count "$op $args\\\$tied_glob$postargs"; |
| 254 | } |
| 255 | |
| 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 | } |
| 267 | |
| 268 | SKIP: |
| 269 | { |
| 270 | skip "select not implemented on Win32 miniperl", 3 |
| 271 | if $^O eq "MSWin32" and is_miniperl; |
| 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 | |
| 284 | chop(my $u = "\xff\x{100}"); |
| 285 | tie $var, "main", $u; |
| 286 | $dummy = pack "u", $var; check_count 'pack "u", $utf8'; |
| 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'; |
| 292 | |
| 293 | tie $var, "main", "\x{100}"; |
| 294 | pos$var = 0 ; check_count 'lvalue pos $utf8'; |
| 295 | $dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8'; |
| 296 | $dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8'; |
| 297 | |
| 298 | my @fmt = qw(B b c D d i O o u U X x); |
| 299 | |
| 300 | tie $var, "main", 23; |
| 301 | for (@fmt) { |
| 302 | $dummy=sprintf"%$_",$var; check_count "sprintf '%$_'" |
| 303 | } |
| 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 | } |
| 311 | tie $var, "main", "Inf"; |
| 312 | for (@fmt) { |
| 313 | $dummy = eval { sprintf "%$_", $var }; |
| 314 | check_count "sprintf '%$_', \$tied_inf" |
| 315 | } |
| 316 | } |
| 317 | |
| 318 | tie $var, "main", "\x{100}"; |
| 319 | $dummy = substr$var,0,1; check_count 'substr $utf8'; |
| 320 | my $l =\substr$var,0,1; |
| 321 | $dummy = $$l ; check_count 'reading lvalue substr($utf8)'; |
| 322 | $$l = 0 ; check_count 'setting lvalue substr($utf8)'; |
| 323 | tie $var, "main", "a"; |
| 324 | $$l = "\x{100}" ; check_count 'assigning $utf8 to lvalue substr'; |
| 325 | tie $var1, "main", "a"; |
| 326 | substr$var1,0,0,"\x{100}"; check_count '4-arg substr with utf8 replacement'; |
| 327 | |
| 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 | |
| 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 | |
| 348 | my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^); |
| 349 | |
| 350 | |
| 351 | sub _bin_test { |
| 352 | my $int = shift; |
| 353 | my $op = shift; |
| 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, @_); |
| 372 | } |
| 373 | |
| 374 | sub bin_int_test { |
| 375 | _bin_test(1, @_); |
| 376 | } |
| 377 | |
| 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; |
| 401 | bin_test '^' , 3, 5, 6; |
| 402 | bin_test '.' , 1, 2, 12; |
| 403 | bin_test '==', 1, 2, ""; |
| 404 | bin_test '+' , 1, 2, 3; |
| 405 | bin_int_test '*' , 2, 3, 6; |
| 406 | bin_int_test '/' , 10, 2, 5; |
| 407 | bin_int_test '%' , 11, 2, 1; |
| 408 | bin_int_test '+' , 1, 2, 3; |
| 409 | bin_int_test '-' , 11, 2, 9; |
| 410 | bin_int_test '<' , 1, 2, 1; |
| 411 | bin_int_test '>' , 44, 2, 1; |
| 412 | bin_int_test '<=', 44, 2, ""; |
| 413 | bin_int_test '>=', 1, 2, ""; |
| 414 | bin_int_test '==', 1, 2, ""; |
| 415 | bin_int_test '!=', 1, 2, 1; |
| 416 | bin_int_test '<=>', 1, 2, -1; |
| 417 | tie $var, "main", 1, 4; |
| 418 | cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var'); |
| 419 | check_count 'atan2', 2; |
| 420 | |
| 421 | __DATA__ |