t/op/state.t

   1 #!./perl -w
   2 # tests state variables
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     require './test.pl';
   7     set_up_inc('../lib');
   8 }
   9
  10 use strict;
  11
  12 plan tests => 164;
  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 sub stateful_init_array {
 139     state @x = qw(a b c);
 140     push @x, "x";
 141     return join(",", @x);
 142 }
 143
 144 is stateful_init_array(), "a,b,c,x";
 145 is stateful_init_array(), "a,b,c,x,x";
 146 is stateful_init_array(), "a,b,c,x,x,x";
 147
 148 # hash state vars
 149
 150 sub stateful_hash {
 151     state %hx;
 152     return $hx{foo}++;
 153 }
 154
 155 my $xhval = stateful_hash();
 156 is( $xhval, 0, 'uninitialized state hash' );
 157
 158 $xhval = stateful_hash();
 159 is( $xhval, 1, 'uninitialized state hash after one iteration' );
 160
 161 sub stateful_init_hash {
 162     state %x = qw(a b c d);
 163     $x{foo}++;
 164     return join(",", map { ($_, $x{$_}) } sort keys %x);
 165 }
 166
 167 is stateful_init_hash(), "a,b,c,d,foo,1";
 168 is stateful_init_hash(), "a,b,c,d,foo,2";
 169 is stateful_init_hash(), "a,b,c,d,foo,3";
 170
 171 # declarations with attributes
 172
 173 SKIP: {
 174 skip "no attributes in miniperl", 3, if is_miniperl;
 175
 176 eval q{
 177 sub stateful_attr {
 178     state $a :shared;
 179     state $b :shared = 3;
 180     state @c :shared;
 181     state @d :shared = qw(a b c);
 182     state %e :shared;
 183     state %f :shared = qw(a b c d);
 184     $a++;
 185     $b++;
 186     push @c, "x";
 187     push @d, "x";
 188     $e{e}++;
 189     $f{e}++;
 190     return join(",", $a, $b, join(":", @c), join(":", @d), join(":", %e),
 191             join(":", map { ($_, $f{$_}) } sort keys %f));
 192 }
 193 };
 194
 195 is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
 196 is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
 197 is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
 198 }
 199
 200
 201 # Recursion
 202
 203 sub noseworth {
 204     my $level = shift;
 205     state $recursed_state = 123;
 206     is($recursed_state, 123, "state kept through recursion ($level)");
 207     noseworth($level - 1) if $level;
 208 }
 209 noseworth(2);
 210
 211 # Assignment return value
 212
 213 sub pugnax { my $x = state $y = 42; $y++; $x; }
 214
 215 is( pugnax(), 42, 'scalar state assignment return value' );
 216 is( pugnax(), 43, 'scalar state assignment return value' );
 217
 218
 219 #
 220 # Test various blocks.
 221 #
 222 foreach my $x (1 .. 3) {
 223     state $y = $x;
 224     is ($y, 1, "foreach $x");
 225 }
 226
 227 for (my $x = 1; $x < 4; $x ++) {
 228     state $y = $x;
 229     is ($y, 1, "for $x");
 230 }
 231
 232 while ($x < 4) {
 233     state $y = $x;
 234     is ($y, 1, "while $x");
 235     $x ++;
 236 }
 237
 238 $x = 1;
 239 until ($x >= 4) {
 240     state $y = $x;
 241     is ($y, 1, "until $x");
 242     $x ++;
 243 }
 244
 245 $x = 0;
 246 $y = 0;
 247 {
 248     state $z = $x;
 249     $z ++;
 250     $y ++;
 251     is ($z, $y, "bare block $y");
 252     redo if $y < 3
 253 }
 254
 255
 256 #
 257 # Goto.
 258 #
 259 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
 260 again:
 261     my $next = shift @simpsons;
 262     state $simpson = $next;
 263     is $simpson, 'Homer', 'goto 1';
 264     goto again if @simpsons;
 265
 266 my $vi;
 267 {
 268     goto Elvis unless $vi;
 269            state $calvin = ++ $vi;
 270     Elvis: state $vile   = ++ $vi;
 271     redo unless defined $calvin;
 272     is $calvin, 2, "goto 2";
 273     is $vile,   1, "goto 3";
 274     is $vi,     2, "goto 4";
 275 }
 276 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
 277 sub president {
 278     my $next = shift @presidents;
 279     state $president = $next;
 280     goto  &president if @presidents;
 281     $president;
 282 }
 283 my $president_answer = $presidents [0];
 284 is president, $president_answer, '&goto';
 285
 286 my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
 287 foreach my $f (@flowers) {
 288     goto state $flower = $f;
 289     ok 0, 'computed goto 0'; next;
 290     Bluebonnet: ok 1, 'computed goto 1'; next;
 291     Goldenrod:  ok 0, 'computed goto 2'; next;
 292     Hawthorn:   ok 0, 'computed goto 3'; next;
 293     Peony:      ok 0, 'computed goto 4'; next;
 294     ok 0, 'computed goto 5'; next;
 295 }
 296
 297 #
 298 # map/grep
 299 #
 300 my @apollo  = qw [Eagle Antares Odyssey Aquarius];
 301 my @result1 = map  {state $x = $_;}     @apollo;
 302 my @result2 = grep {state $x = /Eagle/} @apollo;
 303 {
 304     local $" = "";
 305     is "@result1", $apollo [0] x @apollo, "map";
 306     is "@result2", "@apollo", "grep";
 307 }
 308
 309 #
 310 # Reference to state variable.
 311 #
 312 sub reference {\state $x}
 313 my $ref1 = reference;
 314 my $ref2 = reference;
 315 is $ref1, $ref2, "Reference to state variable";
 316
 317 #
 318 # Pre/post increment.
 319 #
 320 foreach my $x (1 .. 3) {
 321     ++ state $y;
 322     state $z ++;
 323     is $y, $x, "state pre increment";
 324     is $z, $x, "state post increment";
 325 }
 326
 327
 328 #
 329 # Substr
 330 #
 331 my $tintin = "Tin-Tin";
 332 my @thunderbirds  = qw [Scott Virgel Alan Gordon John];
 333 my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
 334 foreach my $x (0 .. 4) {
 335     state $c = \substr $tintin, $x, 1;
 336     my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
 337     $$c = "x";
 338     $$d = "x";
 339     is $tintin, "xin-Tin", "substr";
 340     is $tb, $thunderbirds2 [$x], "substr";
 341 }
 342
 343
 344 #
 345 # Use with given.
 346 #
 347 my @spam = qw [spam ham bacon beans];
 348 foreach my $spam (@spam) {
 349     no warnings 'experimental::smartmatch';
 350     given (state $spam = $spam) {
 351         when ($spam [0]) {ok 1, "given"}
 352         default          {ok 0, "given"}
 353     }
 354 }
 355
 356 #
 357 # Redefine.
 358 #
 359 {
 360     state $x = "one";
 361     no warnings;
 362     state $x = "two";
 363     is $x, "two", "masked"
 364 }
 365
 366 # normally closureless anon subs share a CV and pad. If the anon sub has a
 367 # state var, this would mean that it is shared. Check that this doesn't
 368 # happen
 369
 370 {
 371     my @f;
 372     push @f, sub { state $x; ++$x } for 1..2;
 373     $f[0]->() for 1..10;
 374     is $f[0]->(), 11;
 375     is $f[1]->(), 1;
 376 }
 377
 378 # each copy of an anon sub should get its own 'once block'
 379
 380 {
 381     my $x; # used to force a closure
 382     my @f;
 383     push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
 384     is $f[0]->(1), 1;
 385     is $f[0]->(2), 1;
 386     is $f[1]->(3), 3;
 387     is $f[1]->(4), 3;
 388 }
 389
 390
 391
 392
 393 foreach my $forbidden (<DATA>) {
 394     SKIP: {
 395         skip_if_miniperl("miniperl can't load attributes.pm", 1)
 396                 if $forbidden =~ /:shared/;
 397
 398         chomp $forbidden;
 399         no strict 'vars';
 400         eval $forbidden;
 401         like $@,
 402             qr/Initialization of state variables in list currently forbidden/,
 403             "Currently forbidden: $forbidden";
 404     }
 405 }
 406
 407 # [perl #49522] state variable not available
 408
 409 {
 410     my @warnings;
 411     local $SIG{__WARN__} = sub { push @warnings, $_[0] };
 412
 413     eval q{
 414         use warnings;
 415
 416         sub f_49522 {
 417             state $s = 88;
 418             sub g_49522 { $s }
 419             sub { $s };
 420         }
 421
 422         sub h_49522 {
 423             state $t = 99;
 424             sub i_49522 {
 425                 sub { $t };
 426             }
 427         }
 428     };
 429     is $@, '', "eval f_49522";
 430     # shouldn't be any 'not available' or 'not stay shared' warnings
 431     ok !@warnings, "suppress warnings part 1 [@warnings]";
 432
 433     @warnings = ();
 434     my $f = f_49522();
 435     is $f->(), 88, "state var closure 1";
 436     is g_49522(), 88, "state var closure 2";
 437     ok !@warnings, "suppress warnings part 2 [@warnings]";
 438
 439
 440     @warnings = ();
 441     $f = i_49522();
 442     h_49522(); # initialise $t
 443     is $f->(), 99, "state var closure 3";
 444     ok !@warnings, "suppress warnings part 3 [@warnings]";
 445
 446
 447 }
 448
 449
 450 # [perl #117095] state var initialisation getting skipped
 451 # the 'if 0' code below causes a call to op_free at compile-time,
 452 # which used to inadvertently mark the state var as initialised.
 453
 454 {
 455     state $f = 1;
 456     foo($f) if 0; # this calls op_free on padmy($f)
 457     ok(defined $f, 'state init not skipped');
 458 }
 459
 460 # [perl #121134] Make sure padrange doesn't mess with these
 461 {
 462     sub thing {
 463         my $expect = shift;
 464         my ($x, $y);
 465         state $z;
 466
 467         is($z, $expect, "State variable is correct");
 468
 469         $z = 5;
 470     }
 471
 472     thing(undef);
 473     thing(5);
 474
 475     sub thing2 {
 476         my $expect = shift;
 477         my $x;
 478         my $y;
 479         state $z;
 480
 481         is($z, $expect, "State variable is correct");
 482
 483         $z = 6;
 484     }
 485
 486     thing2(undef);
 487     thing2(6);
 488 }
 489
 490 # [perl #123029] regression in "state" under PERL_NO_COW
 491 sub rt_123029 {
 492     state $s;
 493     $s = 'foo'x500;
 494     my $c = $s;
 495     return defined $s;
 496 }
 497 ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
 498
 499 # make sure multiconcat doesn't break state
 500
 501 for (1,2) {
 502     state $s = "-$_-";
 503     is($s, "-1-", "state with multiconcat pass $_");
 504 }
 505
 506 __DATA__
 507 (state $a) = 1;
 508 (state @a) = 1;
 509 (state @a :shared) = 1;
 510 (state %a) = ();
 511 (state %a :shared) = ();
 512 state ($a) = 1;
 513 (state ($a)) = 1;
 514 state (@a) = 1;
 515 (state (@a)) = 1;
 516 state (@a) :shared = 1;
 517 (state (@a) :shared) = 1;
 518 state (%a) = ();
 519 (state (%a)) = ();
 520 state (%a) :shared = ();
 521 (state (%a) :shared) = ();
 522 state (undef, $a) = ();
 523 (state (undef, $a)) = ();
 524 state (undef, @a) = ();
 525 (state (undef, @a)) = ();
 526 state ($a, undef) = ();
 527 (state ($a, undef)) = ();
 528 state ($a, $b) = ();
 529 (state ($a, $b)) = ();
 530 state ($a, $b) :shared = ();
 531 (state ($a, $b) :shared) = ();
 532 state ($a, @b) = ();
 533 (state ($a, @b)) = ();
 534 state ($a, @b) :shared = ();
 535 (state ($a, @b) :shared) = ();
 536 state (@a, undef) = ();
 537 (state (@a, undef)) = ();
 538 state (@a, $b) = ();
 539 (state (@a, $b)) = ();
 540 state (@a, $b) :shared = ();
 541 (state (@a, $b) :shared) = ();
 542 state (@a, @b) = ();
 543 (state (@a, @b)) = ();
 544 state (@a, @b) :shared = ();
 545 (state (@a, @b) :shared) = ();
 546 (state $a, state $b) = ();
 547 (state $a, $b) = ();
 548 (state $a, my $b) = ();
 549 (state $a, state @b) = ();
 550 (state $a, local @b) = ();
 551 (state $a, undef, state $b) = ();
 552 state ($a, undef, $b) = ();