1#!./perl -w 2# tests state variables 3 4BEGIN { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 require './test.pl'; 8} 9 10use strict; 11use feature ":5.10"; 12 13plan tests => 130; 14 15ok( ! defined state $uninit, q(state vars are undef by default) ); 16 17# basic functionality 18 19sub stateful { 20 state $x; 21 state $y = 1; 22 my $z = 2; 23 state ($t) //= 3; 24 return ($x++, $y++, $z++, $t++); 25} 26 27my ($x, $y, $z, $t) = stateful(); 28is( $x, 0, 'uninitialized state var' ); 29is( $y, 1, 'initialized state var' ); 30is( $z, 2, 'lexical' ); 31is( $t, 3, 'initialized state var, list syntax' ); 32 33($x, $y, $z, $t) = stateful(); 34is( $x, 1, 'incremented state var' ); 35is( $y, 2, 'incremented state var' ); 36is( $z, 2, 'reinitialized lexical' ); 37is( $t, 4, 'incremented state var, list syntax' ); 38 39($x, $y, $z, $t) = stateful(); 40is( $x, 2, 'incremented state var' ); 41is( $y, 3, 'incremented state var' ); 42is( $z, 2, 'reinitialized lexical' ); 43is( $t, 5, 'incremented state var, list syntax' ); 44 45# in a nested block 46 47sub nesting { 48 state $foo = 10; 49 my $t; 50 { state $bar = 12; $t = ++$bar } 51 ++$foo; 52 return ($foo, $t); 53} 54 55($x, $y) = nesting(); 56is( $x, 11, 'outer state var' ); 57is( $y, 13, 'inner state var' ); 58 59($x, $y) = nesting(); 60is( $x, 12, 'outer state var' ); 61is( $y, 14, 'inner state var' ); 62 63# in a closure 64 65sub generator { 66 my $outer; 67 # we use $outer to generate a closure 68 sub { ++$outer; ++state $x } 69} 70 71my $f1 = generator(); 72is( $f1->(), 1, 'generator 1' ); 73is( $f1->(), 2, 'generator 1' ); 74my $f2 = generator(); 75is( $f2->(), 1, 'generator 2' ); 76is( $f1->(), 3, 'generator 1 again' ); 77is( $f2->(), 2, 'generator 2 once more' ); 78 79# with ties 80{ 81 package countfetches; 82 our $fetchcount = 0; 83 sub TIESCALAR {bless {}}; 84 sub FETCH { ++$fetchcount; 18 }; 85 tie my $y, "countfetches"; 86 sub foo { state $x = $y; $x++ } 87 ::is( foo(), 18, "initialisation with tied variable" ); 88 ::is( foo(), 19, "increments correctly" ); 89 ::is( foo(), 20, "increments correctly, twice" ); 90 ::is( $fetchcount, 1, "fetch only called once" ); 91} 92 93# state variables are shared among closures 94 95sub gen_cashier { 96 my $amount = shift; 97 state $cash_in_store = 0; 98 return { 99 add => sub { $cash_in_store += $amount }, 100 del => sub { $cash_in_store -= $amount }, 101 bal => sub { $cash_in_store }, 102 }; 103} 104 105gen_cashier(59)->{add}->(); 106gen_cashier(17)->{del}->(); 107is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' ); 108 109# stateless assignment to a state variable 110 111sub stateless { 112 state $reinitme = 42; 113 ++$reinitme; 114} 115is( stateless(), 43, 'stateless function, first time' ); 116is( stateless(), 44, 'stateless function, second time' ); 117 118# array state vars 119 120sub stateful_array { 121 state @x; 122 push @x, 'x'; 123 return $#x; 124} 125 126my $xsize = stateful_array(); 127is( $xsize, 0, 'uninitialized state array' ); 128 129$xsize = stateful_array(); 130is( $xsize, 1, 'uninitialized state array after one iteration' ); 131 132# hash state vars 133 134sub stateful_hash { 135 state %hx; 136 return $hx{foo}++; 137} 138 139my $xhval = stateful_hash(); 140is( $xhval, 0, 'uninitialized state hash' ); 141 142$xhval = stateful_hash(); 143is( $xhval, 1, 'uninitialized state hash after one iteration' ); 144 145# Recursion 146 147sub noseworth { 148 my $level = shift; 149 state $recursed_state = 123; 150 is($recursed_state, 123, "state kept through recursion ($level)"); 151 noseworth($level - 1) if $level; 152} 153noseworth(2); 154 155# Assignment return value 156 157sub pugnax { my $x = state $y = 42; $y++; $x; } 158 159is( pugnax(), 42, 'scalar state assignment return value' ); 160is( pugnax(), 43, 'scalar state assignment return value' ); 161 162 163# 164# Test various blocks. 165# 166foreach my $x (1 .. 3) { 167 state $y = $x; 168 is ($y, 1, "foreach $x"); 169} 170 171for (my $x = 1; $x < 4; $x ++) { 172 state $y = $x; 173 is ($y, 1, "for $x"); 174} 175 176while ($x < 4) { 177 state $y = $x; 178 is ($y, 1, "while $x"); 179 $x ++; 180} 181 182$x = 1; 183until ($x >= 4) { 184 state $y = $x; 185 is ($y, 1, "until $x"); 186 $x ++; 187} 188 189$x = 0; 190$y = 0; 191{ 192 state $z = $x; 193 $z ++; 194 $y ++; 195 is ($z, $y, "bare block $y"); 196 redo if $y < 3 197} 198 199 200# 201# Check state $_ 202# 203my @stones = qw [fred wilma barny betty]; 204my $first = $stones [0]; 205my $First = ucfirst $first; 206$_ = "bambam"; 207foreach my $flint (@stones) { 208 state $_ = $flint; 209 is $_, $first, 'state $_'; 210 ok /$first/, '/.../ binds to $_'; 211 is ucfirst, $First, '$_ default argument'; 212} 213is $_, "bambam", '$_ is still there'; 214 215# 216# Goto. 217# 218my @simpsons = qw [Homer Marge Bart Lisa Maggie]; 219again: 220 my $next = shift @simpsons; 221 state $simpson = $next; 222 is $simpson, 'Homer', 'goto 1'; 223 goto again if @simpsons; 224 225my $vi; 226{ 227 goto Elvis unless $vi; 228 state $calvin = ++ $vi; 229 Elvis: state $vile = ++ $vi; 230 redo unless defined $calvin; 231 is $calvin, 2, "goto 2"; 232 is $vile, 1, "goto 3"; 233 is $vi, 2, "goto 4"; 234} 235my @presidents = qw [Taylor Garfield Ford Arthur Monroe]; 236sub president { 237 my $next = shift @presidents; 238 state $president = $next; 239 goto &president if @presidents; 240 $president; 241} 242my $president_answer = $presidents [0]; 243is president, $president_answer, '&goto'; 244 245my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony]; 246foreach my $f (@flowers) { 247 goto state $flower = $f; 248 ok 0, 'computed goto 0'; next; 249 Bluebonnet: ok 1, 'computed goto 1'; next; 250 Goldenrod: ok 0, 'computed goto 2'; next; 251 Hawthorn: ok 0, 'computed goto 3'; next; 252 Peony: ok 0, 'computed goto 4'; next; 253 ok 0, 'computed goto 5'; next; 254} 255 256# 257# map/grep 258# 259my @apollo = qw [Eagle Antares Odyssey Aquarius]; 260my @result1 = map {state $x = $_;} @apollo; 261my @result2 = grep {state $x = /Eagle/} @apollo; 262{ 263 local $" = ""; 264 is "@result1", $apollo [0] x @apollo, "map"; 265 is "@result2", "@apollo", "grep"; 266} 267 268# 269# Reference to state variable. 270# 271sub reference {\state $x} 272my $ref1 = reference; 273my $ref2 = reference; 274is $ref1, $ref2, "Reference to state variable"; 275 276# 277# Pre/post increment. 278# 279foreach my $x (1 .. 3) { 280 ++ state $y; 281 state $z ++; 282 is $y, $x, "state pre increment"; 283 is $z, $x, "state post increment"; 284} 285 286 287# 288# Substr 289# 290my $tintin = "Tin-Tin"; 291my @thunderbirds = qw [Scott Virgel Alan Gordon John]; 292my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx]; 293foreach my $x (0 .. 4) { 294 state $c = \substr $tintin, $x, 1; 295 my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1); 296 $$c = "x"; 297 $$d = "x"; 298 is $tintin, "xin-Tin", "substr"; 299 is $tb, $thunderbirds2 [$x], "substr"; 300} 301 302 303# 304# Use with given. 305# 306my @spam = qw [spam ham bacon beans]; 307foreach my $spam (@spam) { 308 given (state $spam = $spam) { 309 when ($spam [0]) {ok 1, "given"} 310 default {ok 0, "given"} 311 } 312} 313 314# 315# Redefine. 316# 317{ 318 state $x = "one"; 319 no warnings; 320 state $x = "two"; 321 is $x, "two", "masked" 322} 323 324# normally closureless anon subs share a CV and pad. If the anon sub has a 325# state var, this would mean that it is shared. Check that this doesn't 326# happen 327 328{ 329 my @f; 330 push @f, sub { state $x; ++$x } for 1..2; 331 $f[0]->() for 1..10; 332 is $f[0]->(), 11; 333 is $f[1]->(), 1; 334} 335 336# each copy of an anon sub should get its own 'once block' 337 338{ 339 my $x; # used to force a closure 340 my @f; 341 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2; 342 is $f[0]->(1), 1; 343 is $f[0]->(2), 1; 344 is $f[1]->(3), 3; 345 is $f[1]->(4), 3; 346} 347 348 349 350 351foreach my $forbidden (<DATA>) { 352 chomp $forbidden; 353 no strict 'vars'; 354 eval $forbidden; 355 like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden"; 356} 357 358# [perl #49522] state variable not available 359 360{ 361 my @warnings; 362 local $SIG{__WARN__} = sub { push @warnings, $_[0] }; 363 364 eval q{ 365 use warnings; 366 367 sub f_49522 { 368 state $s = 88; 369 sub g_49522 { $s } 370 sub { $s }; 371 } 372 373 sub h_49522 { 374 state $t = 99; 375 sub i_49522 { 376 sub { $t }; 377 } 378 } 379 }; 380 is $@, '', "eval f_49522"; 381 # shouldn't be any 'not available' or 'not stay shared' warnings 382 ok !@warnings, "suppress warnings part 1 [@warnings]"; 383 384 @warnings = (); 385 my $f = f_49522(); 386 is $f->(), 88, "state var closure 1"; 387 is g_49522(), 88, "state var closure 2"; 388 ok !@warnings, "suppress warnings part 2 [@warnings]"; 389 390 391 @warnings = (); 392 $f = i_49522(); 393 h_49522(); # initialise $t 394 is $f->(), 99, "state var closure 3"; 395 ok !@warnings, "suppress warnings part 3 [@warnings]"; 396 397 398} 399 400 401__DATA__ 402state ($a) = 1; 403(state $a) = 1; 404state @a = 1; 405state (@a) = 1; 406(state @a) = 1; 407state %a = (); 408state (%a) = (); 409(state %a) = (); 410state ($a, $b) = (); 411state ($a, @b) = (); 412(state $a, state $b) = (); 413(state $a, $b) = (); 414(state $a, my $b) = (); 415(state $a, state @b) = (); 416(state $a, local @b) = (); 417(state $a, undef, state $b) = (); 418state ($a, undef, $b) = (); 419