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 "state";
  12
  13 plan tests => 38;
  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' );