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 use feature ":5.10";
  12
  13 plan tests => 108;
  14
  15 ok( ! defined state $uninit, q(state vars are undef by default) );
  16
  17 # basic functionality
  18
  19 sub stateful {
  20     state $x;
  21     state $y = 1;
  22     my $z = 2;
  23     state ($t) //= 3;
  24     return ($x++, $y++, $z++, $t++);
  25 }
  26
  27 my ($x, $y, $z, $t) = stateful();
  28 is( $x, 0, 'uninitialized state var' );
  29 is( $y, 1, 'initialized state var' );
  30 is( $z, 2, 'lexical' );
  31 is( $t, 3, 'initialized state var, list syntax' );
  32
  33 ($x, $y, $z, $t) = stateful();
  34 is( $x, 1, 'incremented state var' );
  35 is( $y, 2, 'incremented state var' );
  36 is( $z, 2, 'reinitialized lexical' );
  37 is( $t, 4, 'incremented state var, list syntax' );
  38
  39 ($x, $y, $z, $t) = stateful();
  40 is( $x, 2, 'incremented state var' );
  41 is( $y, 3, 'incremented state var' );
  42 is( $z, 2, 'reinitialized lexical' );
  43 is( $t, 5, 'incremented state var, list syntax' );
  44
  45 # in a nested block
  46
  47 sub 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();
  56 is( $x, 11, 'outer state var' );
  57 is( $y, 13, 'inner state var' );
  58
  59 ($x, $y) = nesting();
  60 is( $x, 12, 'outer state var' );
  61 is( $y, 14, 'inner state var' );
  62
  63 # in a closure
  64
  65 sub generator {
  66     my $outer;
  67     # we use $outer to generate a closure
  68     sub { ++$outer; ++state $x }
  69 }
  70
  71 my $f1 = generator();
  72 is( $f1->(), 1, 'generator 1' );
  73 is( $f1->(), 2, 'generator 1' );
  74 my $f2 = generator();
  75 is( $f2->(), 1, 'generator 2' );
  76 is( $f1->(), 3, 'generator 1 again' );
  77 is( $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
  95 sub 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
 105 gen_cashier(59)->{add}->();
 106 gen_cashier(17)->{del}->();
 107 is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
 108
 109 # stateless assignment to a state variable
 110
 111 sub stateless {
 112     state $reinitme = 42;
 113     ++$reinitme;
 114 }
 115 is( stateless(), 43, 'stateless function, first time' );
 116 is( stateless(), 44, 'stateless function, second time' );
 117
 118 # array state vars
 119
 120 sub stateful_array {
 121     state @x;
 122     push @x, 'x';
 123     return $#x;
 124 }
 125
 126 my $xsize = stateful_array();
 127 is( $xsize, 0, 'uninitialized state array' );
 128
 129 $xsize = stateful_array();
 130 is( $xsize, 1, 'uninitialized state array after one iteration' );
 131
 132 # hash state vars
 133
 134 sub stateful_hash {
 135     state %hx;
 136     return $hx{foo}++;
 137 }
 138
 139 my $xhval = stateful_hash();
 140 is( $xhval, 0, 'uninitialized state hash' );
 141
 142 $xhval = stateful_hash();
 143 is( $xhval, 1, 'uninitialized state hash after one iteration' );
 144
 145 # Recursion
 146
 147 sub 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 }
 153 noseworth(2);
 154
 155 # Assignment return value
 156
 157 sub pugnax { my $x = state $y = 42; $y++; $x; }
 158
 159 is( pugnax(), 42, 'scalar state assignment return value' );
 160 is( pugnax(), 43, 'scalar state assignment return value' );
 161
 162
 163 #
 164 # Test various blocks.
 165 #
 166 foreach my $x (1 .. 3) {
 167     state $y = $x;
 168     is ($y, 1, "foreach $x");
 169 }
 170
 171 for (my $x = 1; $x < 4; $x ++) {
 172     state $y = $x;
 173     is ($y, 1, "for $x");
 174 }
 175
 176 while ($x < 4) {
 177     state $y = $x;
 178     is ($y, 1, "while $x");
 179     $x ++;
 180 }
 181
 182 $x = 1;
 183 until ($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 #
 203 my @stones = qw [fred wilma barny betty];
 204 my $first  = $stones [0];
 205 my $First  = ucfirst $first;
 206 $_ = "bambam";
 207 foreach my $flint (@stones) {
 208     state $_ = $flint;
 209     is $_, $first, 'state $_';
 210     ok /$first/, '/.../ binds to $_';
 211     is ucfirst, $First, '$_ default argument';
 212 }
 213 is $_, "bambam", '$_ is still there';
 214
 215 #
 216 # Goto.
 217 #
 218 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
 219 again:
 220     my $next = shift @simpsons;
 221     state $simpson = $next;
 222     is $simpson, 'Homer', 'goto 1';
 223     goto again if @simpsons;
 224
 225 goto Elvis;
 226 my $vi;
 227 {
 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 }
 235 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
 236 sub president {
 237     my $next = shift @presidents;
 238     state $president = $next;
 239     goto  &president if @presidents;
 240     $president;
 241 }
 242 my $president_answer = $presidents [0];
 243 is president, $president_answer, '&goto';
 244
 245 my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
 246 foreach 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 #
 259 my @apollo  = qw [Eagle Antares Odyssey Aquarius];
 260 my @result1 = map  {state $x = $_;}     @apollo;
 261 my @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 #
 271 sub reference {\state $x}
 272 my $ref1 = reference;
 273 my $ref2 = reference;
 274 is $ref1, $ref2, "Reference to state variable";
 275
 276 #
 277 # Pre/post increment.
 278 #
 279 foreach 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 #
 290 my $tintin = "Tin-Tin";
 291 my @thunderbirds  = qw [Scott Virgel Alan Gordon John];
 292 my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
 293 foreach 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 # List context reassigns, but scalar doesn't.
 305 #
 306 my @swords = qw [Stormbringer Szczerbiec Grimtooth Corrougue];
 307 foreach my $sword (@swords) {
 308     state ($s1) = state $s2 = $sword;
 309     is $s1, $swords [0], 'mixed context';
 310     is $s2, $swords [0], 'mixed context';
 311 }
 312
 313
 314 #
 315 # Use with given.
 316 #
 317 my @spam = qw [spam ham bacon beans];
 318 foreach my $spam (@spam) {
 319     given (state $spam = $spam) {
 320         when ($spam [0]) {ok 1, "given"}
 321         default          {ok 0, "given"}
 322     }
 323 }
 324
 325 #
 326 # Redefine.
 327 #
 328 {
 329     state $x = "one";
 330     no warnings;
 331     state $x = "two";
 332     is $x, "two", "masked"
 333 }