1#!./perl 2# Tests counting number of FETCHes. 3# 4# See Bugs #76814 and #87708. 5 6BEGIN { 7 chdir 't' if -d 't'; 8 @INC = '../lib'; 9 require './test.pl'; 10 plan (tests => 312); 11} 12 13use strict; 14use warnings; 15 16my $count = 0; 17 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]}} 25sub STORE { unshift @{$_[0]}, $_[1] } 26 27 28sub check_count { 29 my $op = shift; 30 my $expected = shift() // 1; 31 local $::Level = $::Level + 1; 32 is $count, $expected, 33 "FETCH called " . ( 34 $expected == 1 ? "just once" : 35 $expected == 2 ? "twice" : 36 "$count times" 37 ) . " using '$op'"; 38 $count = 0; 39} 40 41my ($dummy, @dummy); 42 43tie my $var => 'main', 1; 44 45# Assignment. 46$dummy = $var ; check_count "="; 47*dummy = $var ; check_count '*glob = $tied'; 48 49# Unary +/- 50$dummy = +$var ; check_count "unary +"; 51$dummy = -$var ; check_count "unary -"; 52 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'; 67tie my $v42 => 'main', "z"; 68@dummy = $v42 .. "a"; check_count '$tied.."a"'; 69@dummy = "a" .. $v42; check_count '"a"..$tied'; 70 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 --'; 76 77# Numeric comparison 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 '<=>'; 85 86# String comparison 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'; 94 95# Bitwise operators 96$dummy = $var & 1 ; check_count '&'; 97$dummy = $var ^ 1 ; check_count '^'; 98$dummy = $var | 1 ; check_count '|'; 99$dummy = ~$var ; check_count '~'; 100 101# Logical operators 102$dummy = !$var ; check_count '!'; 103tie 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 '?:'; 110 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$dummy = atan2 $var, 1 ; check_count 'atan2'; 120 121# Readline/glob 122tie my $var0, "main", \*DATA; 123$dummy = <$var0> ; check_count '<readline>'; 124$var = \1; 125$var .= <DATA> ; check_count '$tiedref .= <rcatline>'; 126$var = "tied"; 127$var .= <DATA> ; check_count '$tiedstr .= <rcatline>'; 128$var = *foo; 129$var .= <DATA> ; check_count '$tiedglob .= <rcatline>'; 130{ no warnings "glob"; 131 $dummy = <${var}> ; check_count '<glob>'; 132} 133 134# File operators 135for (split //, 'rwxoRWXOezsfdpSbctugkTBMAC') { 136 no warnings 'unopened'; 137 $dummy = eval "-$_ \$var"; check_count "-$_"; 138 # Make $var hold a glob: 139 $var = *dummy; $dummy = $var; $count = 0; 140 $dummy = eval "-$_ \$var"; check_count "-$_ \$tied_glob"; 141 next if /[guk]/; 142 $var = *dummy; $dummy = $var; $count = 0; 143 eval "\$dummy = -$_ \\\$var"; 144 check_count "-$_ \\\$tied_glob"; 145} 146$dummy = -l $var ; check_count '-l'; 147$var = "test.pl"; 148$dummy = -e -e -e $var ; check_count '-e -e'; 149 150# Matching 151$_ = "foo"; 152$dummy = $var =~ m/ / ; check_count 'm//'; 153$dummy = $var =~ s/ //; check_count 's///'; 154{ 155 no warnings 'experimental::smartmatch'; 156 $dummy = $var ~~ 1 ; check_count '~~'; 157} 158$dummy = $var =~ y/ //; check_count 'y///'; 159 $var = \1; 160$dummy = $var =~y/ /-/; check_count '$ref =~ y///'; 161 /$var/ ; check_count 'm/pattern/'; 162 /$var foo/ ; check_count 'm/$tied foo/'; 163 s/$var// ; check_count 's/pattern//'; 164 s/$var foo// ; check_count 's/$tied foo//'; 165 s/./$var/ ; check_count 's//replacement/'; 166 167# Dereferencing 168tie my $var1 => 'main', \1; 169$dummy = $$var1 ; check_count '${}'; 170tie my $var2 => 'main', []; 171$dummy = @$var2 ; check_count '@{}'; 172{ 173 no warnings 'experimental::autoderef'; 174 $dummy = shift $var2 ; check_count 'shift arrayref'; 175} 176tie my $var3 => 'main', {}; 177$dummy = %$var3 ; check_count '%{}'; 178{ 179 no warnings 'experimental::autoderef'; 180 $dummy = keys $var3 ; check_count 'keys hashref'; 181} 182{ 183 no strict 'refs'; 184 tie my $var4 => 'main', *]; 185 $dummy = *$var4 ; check_count '*{}'; 186} 187 188tie my $var5 => 'main', sub {1}; 189$dummy = &$var5 ; check_count '&{}'; 190 191{ 192 no strict 'refs'; 193 tie my $var1 => 'main', 1; 194 $dummy = $$var1 ; check_count 'symbolic ${}'; 195 $dummy = @$var1 ; check_count 'symbolic @{}'; 196 $dummy = %$var1 ; check_count 'symbolic %{}'; 197 $dummy = *$var1 ; check_count 'symbolic *{}'; 198 local *1 = sub{}; 199 $dummy = &$var1 ; check_count 'symbolic &{}'; 200 201 # This test will not be a complete test if *988 has been created 202 # already. If this dies, change it to use another built-in variable. 203 # In 5.10-14, rv2gv calls get-magic more times for built-in vars, which 204 # is why we need the test this way. 205 if (exists $::{988}) { 206 die "*988 already exists. Please adjust this test" 207 } 208 tie my $var6 => main => 988; 209 no warnings; 210 readdir $var6 ; check_count 'symbolic readdir'; 211 if (exists $::{973}) { # Need a different variable here 212 die "*973 already exists. Please adjust this test" 213 } 214 tie my $var7 => main => 973; 215 defined $$var7 ; check_count 'symbolic defined ${}'; 216} 217 218tie my $var8 => 'main', 'main'; 219sub bolgy {} 220$var8->bolgy ; check_count '->method'; 221{ 222 no warnings 'once'; 223 () = *swibble; 224 # This must be the name of an existing glob to trigger the maximum 225 # number of fetches in 5.14: 226 tie my $var9 => 'main', 'swibble'; 227 no strict 'refs'; 228 use constant glumscrin => 'shreggleboughet'; 229 *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}'; 230} 231 232# Functions that operate on filenames or filehandles 233for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'], 234 [truncate=>'',',0'],[stat=>''],[lstat=>''],[open=>'my $fh,"<&",'], 235 ['()=sort'=>'',' 1,2,3']) { 236 my($op,$args,$postargs) = @$_; $postargs //= ''; 237 # This line makes $var8 hold a glob: 238 $var8 = *dummy; $dummy = $var8; $count = 0; 239 eval "$op $args \$var8 $postargs"; 240 check_count "$op $args\$tied_glob$postargs"; 241 $var8 = *dummy; $dummy = $var8; $count = 0; 242 my $ref = \$var8; 243 eval "$op $args \$ref $postargs"; 244 check_count "$op $args\\\$tied_glob$postargs"; 245} 246 247{ 248 no warnings; 249 $var = *foo; 250 $dummy = select $var, undef, undef, 0 251 ; check_count 'select $tied_glob, ...'; 252 $var = \1; 253 $dummy = select $var, undef, undef, 0 254 ; check_count 'select $tied_ref, ...'; 255 $var = undef; 256 $dummy = select $var, undef, undef, 0 257 ; check_count 'select $tied_undef, ...'; 258} 259 260chop(my $u = "\xff\x{100}"); 261tie $var, "main", $u; 262$dummy = pack "u", $var; check_count 'pack "u", $utf8'; 263 264tie $var, "main", "\x{100}"; 265pos$var = 0 ; check_count 'lvalue pos $utf8'; 266$dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8'; 267$dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8'; 268$dummy = substr$var,0,1; check_count 'substr $utf8'; 269my $l =\substr$var,0,1; 270$dummy = $$l ; check_count 'reading lvalue substr($utf8)'; 271$$l = 0 ; check_count 'setting lvalue substr($utf8)'; 272tie $var, "main", "a"; 273$$l = "\x{100}" ; check_count 'assigning $utf8 to lvalue substr'; 274tie $var1, "main", "a"; 275substr$var1,0,0,"\x{100}"; check_count '4-arg substr with utf8 replacement'; 276 277{ 278 local $SIG{__WARN__} = sub {}; 279 $dummy = warn $var ; check_count 'warn $tied'; 280 tie $@, => 'main', 1; 281 $dummy = warn ; check_count 'warn() with $@ tied (num)'; 282 tie $@, => 'main', \1; 283 $dummy = warn ; check_count 'warn() with $@ tied (ref)'; 284 tie $@, => 'main', "foo\n"; 285 $dummy = warn ; check_count 'warn() with $@ tied (str)'; 286 untie $@; 287} 288 289############################################### 290# Tests for $foo binop $foo # 291############################################### 292 293# These test that binary ops call FETCH twice if the same scalar is used 294# for both operands. They also test that both return values from 295# FETCH are used. 296 297my %mutators = map { ($_ => 1) } qw(. + - * / % ** << >> & | ^); 298 299 300sub _bin_test { 301 my $int = shift; 302 my $op = shift; 303 my $exp = pop; 304 my @fetches = @_; 305 306 $int = $int ? 'use integer; ' : ''; 307 308 tie my $var, "main", @fetches; 309 is(eval "$int\$var $op \$var", $exp, "retval of $int\$var $op \$var"); 310 check_count "$int$op", 2; 311 312 return unless $mutators{$op}; 313 314 tie my $var2, "main", @fetches; 315 is(eval "$int \$var2 $op= \$var2", $exp, "retval of $int \$var2 $op= \$var2"); 316 check_count "$int$op=", 3; 317} 318 319sub bin_test { 320 _bin_test(0, @_); 321} 322 323sub bin_int_test { 324 _bin_test(1, @_); 325} 326 327bin_test '**', 2, 3, 8; 328bin_test '*' , 2, 3, 6; 329bin_test '/' , 10, 2, 5; 330bin_test '%' , 11, 2, 1; 331bin_test 'x' , 11, 2, 1111; 332bin_test '-' , 11, 2, 9; 333bin_test '<<', 11, 2, 44; 334bin_test '>>', 44, 2, 11; 335bin_test '<' , 1, 2, 1; 336bin_test '>' , 44, 2, 1; 337bin_test '<=', 44, 2, ""; 338bin_test '>=', 1, 2, ""; 339bin_test '!=', 1, 2, 1; 340bin_test '<=>', 1, 2, -1; 341bin_test 'le', 4, 2, ""; 342bin_test 'lt', 1, 2, 1; 343bin_test 'gt', 4, 2, 1; 344bin_test 'ge', 1, 2, ""; 345bin_test 'eq', 1, 2, ""; 346bin_test 'ne', 1, 2, 1; 347bin_test 'cmp', 1, 2, -1; 348bin_test '&' , 1, 2, 0; 349bin_test '|' , 1, 2, 3; 350bin_test '^' , 3, 5, 6; 351bin_test '.' , 1, 2, 12; 352bin_test '==', 1, 2, ""; 353bin_test '+' , 1, 2, 3; 354bin_int_test '*' , 2, 3, 6; 355bin_int_test '/' , 10, 2, 5; 356bin_int_test '%' , 11, 2, 1; 357bin_int_test '+' , 1, 2, 3; 358bin_int_test '-' , 11, 2, 9; 359bin_int_test '<' , 1, 2, 1; 360bin_int_test '>' , 44, 2, 1; 361bin_int_test '<=', 44, 2, ""; 362bin_int_test '>=', 1, 2, ""; 363bin_int_test '==', 1, 2, ""; 364bin_int_test '!=', 1, 2, 1; 365bin_int_test '<=>', 1, 2, -1; 366tie $var, "main", 1, 4; 367cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var'); 368check_count 'atan2', 2; 369 370__DATA__ 371