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