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 => 131;
  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     state $_ = $flint;
 215     is $_, $first, 'state $_';
 216     ok /$first/, '/.../ binds to $_';
 217     is ucfirst, $First, '$_ default argument';
 218 }
 219 is $_, "bambam", '$_ is still there';
 220
 221 #
 222 # Goto.
 223 #
 224 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
 225 again:
 226     my $next = shift @simpsons;
 227     state $simpson = $next;
 228     is $simpson, 'Homer', 'goto 1';
 229     goto again if @simpsons;
 230
 231 my $vi;
 232 {
 233     goto Elvis unless $vi;
 234            state $calvin = ++ $vi;
 235     Elvis: state $vile   = ++ $vi;
 236     redo unless defined $calvin;
 237     is $calvin, 2, "goto 2";
 238     is $vile,   1, "goto 3";
 239     is $vi,     2, "goto 4";
 240 }
 241 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
 242 sub president {
 243     my $next = shift @presidents;
 244     state $president = $next;
 245     goto  &president if @presidents;
 246     $president;
 247 }
 248 my $president_answer = $presidents [0];
 249 is president, $president_answer, '&goto';
 250
 251 my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
 252 foreach my $f (@flowers) {
 253     goto state $flower = $f;
 254     ok 0, 'computed goto 0'; next;
 255     Bluebonnet: ok 1, 'computed goto 1'; next;
 256     Goldenrod:  ok 0, 'computed goto 2'; next;
 257     Hawthorn:   ok 0, 'computed goto 3'; next;
 258     Peony:      ok 0, 'computed goto 4'; next;
 259     ok 0, 'computed goto 5'; next;
 260 }
 261
 262 #
 263 # map/grep
 264 #
 265 my @apollo  = qw [Eagle Antares Odyssey Aquarius];
 266 my @result1 = map  {state $x = $_;}     @apollo;
 267 my @result2 = grep {state $x = /Eagle/} @apollo;
 268 {
 269     local $" = "";
 270     is "@result1", $apollo [0] x @apollo, "map";
 271     is "@result2", "@apollo", "grep";
 272 }
 273
 274 #
 275 # Reference to state variable.
 276 #
 277 sub reference {\state $x}
 278 my $ref1 = reference;
 279 my $ref2 = reference;
 280 is $ref1, $ref2, "Reference to state variable";
 281
 282 #
 283 # Pre/post increment.
 284 #
 285 foreach my $x (1 .. 3) {
 286     ++ state $y;
 287     state $z ++;
 288     is $y, $x, "state pre increment";
 289     is $z, $x, "state post increment";
 290 }
 291
 292
 293 #
 294 # Substr
 295 #
 296 my $tintin = "Tin-Tin";
 297 my @thunderbirds  = qw [Scott Virgel Alan Gordon John];
 298 my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
 299 foreach my $x (0 .. 4) {
 300     state $c = \substr $tintin, $x, 1;
 301     my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
 302     $$c = "x";
 303     $$d = "x";
 304     is $tintin, "xin-Tin", "substr";
 305     is $tb, $thunderbirds2 [$x], "substr";
 306 }
 307
 308
 309 #
 310 # Use with given.
 311 #
 312 my @spam = qw [spam ham bacon beans];
 313 foreach my $spam (@spam) {
 314     given (state $spam = $spam) {
 315         when ($spam [0]) {ok 1, "given"}
 316         default          {ok 0, "given"}
 317     }
 318 }
 319
 320 #
 321 # Redefine.
 322 #
 323 {
 324     state $x = "one";
 325     no warnings;
 326     state $x = "two";
 327     is $x, "two", "masked"
 328 }
 329
 330 # normally closureless anon subs share a CV and pad. If the anon sub has a
 331 # state var, this would mean that it is shared. Check that this doesn't
 332 # happen
 333
 334 {
 335     my @f;
 336     push @f, sub { state $x; ++$x } for 1..2;
 337     $f[0]->() for 1..10;
 338     is $f[0]->(), 11;
 339     is $f[1]->(), 1;
 340 }
 341
 342 # each copy of an anon sub should get its own 'once block'
 343
 344 {
 345     my $x; # used to force a closure
 346     my @f;
 347     push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
 348     is $f[0]->(1), 1;
 349     is $f[0]->(2), 1;
 350     is $f[1]->(3), 3;
 351     is $f[1]->(4), 3;
 352 }
 353
 354
 355
 356
 357 foreach my $forbidden (<DATA>) {
 358     chomp $forbidden;
 359     no strict 'vars';
 360     eval $forbidden;
 361     like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
 362 }
 363
 364 # [perl #49522] state variable not available
 365
 366 {
 367     my @warnings;
 368     local $SIG{__WARN__} = sub { push @warnings, $_[0] };
 369
 370     eval q{
 371         use warnings;
 372
 373         sub f_49522 {
 374             state $s = 88;
 375             sub g_49522 { $s }
 376             sub { $s };
 377         }
 378
 379         sub h_49522 {
 380             state $t = 99;
 381             sub i_49522 {
 382                 sub { $t };
 383             }
 384         }
 385     };
 386     is $@, '', "eval f_49522";
 387     # shouldn't be any 'not available' or 'not stay shared' warnings
 388     ok !@warnings, "suppress warnings part 1 [@warnings]";
 389
 390     @warnings = ();
 391     my $f = f_49522();
 392     is $f->(), 88, "state var closure 1";
 393     is g_49522(), 88, "state var closure 2";
 394     ok !@warnings, "suppress warnings part 2 [@warnings]";
 395
 396
 397     @warnings = ();
 398     $f = i_49522();
 399     h_49522(); # initialise $t
 400     is $f->(), 99, "state var closure 3";
 401     ok !@warnings, "suppress warnings part 3 [@warnings]";
 402
 403
 404 }
 405
 406
 407 __DATA__
 408 state ($a) = 1;
 409 (state $a) = 1;
 410 state @a = 1;
 411 state (@a) = 1;
 412 (state @a) = 1;
 413 state %a = ();
 414 state (%a) = ();
 415 (state %a) = ();
 416 state ($a, $b) = ();
 417 state ($a, @b) = ();
 418 (state $a, state $b) = ();
 419 (state $a, $b) = ();
 420 (state $a, my $b) = ();
 421 (state $a, state @b) = ();
 422 (state $a, local @b) = ();
 423 (state $a, undef, state $b) = ();
 424 state ($a, undef, $b) = ();