t/op/state.t

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