2 # tests state variables
15 ok( ! defined state $uninit, q(state vars are undef by default) );
24 return ($x++, $y++, $z++, $t++);
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' );
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' );
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' );
50 { state $bar = 12; $t = ++$bar }
56 is( $x, 11, 'outer state var' );
57 is( $y, 13, 'inner state var' );
60 is( $x, 12, 'outer state var' );
61 is( $y, 14, 'inner state var' );
67 # we use $outer to generate a closure
68 sub { ++$outer; ++state $x }
72 is( $f1->(), 1, 'generator 1' );
73 is( $f1->(), 2, 'generator 1' );
75 is( $f2->(), 1, 'generator 2' );
76 is( $f1->(), 3, 'generator 1 again' );
77 is( $f2->(), 2, 'generator 2 once more' );
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" );
93 # state variables are shared among closures
97 state $cash_in_store = 0;
99 add => sub { $cash_in_store += $amount },
100 del => sub { $cash_in_store -= $amount },
101 bal => sub { $cash_in_store },
105 gen_cashier(59)->{add}->();
106 gen_cashier(17)->{del}->();
107 is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
109 # stateless assignment to a state variable
112 state $reinitme = 42;
115 is( stateless(), 43, 'stateless function, first time' );
116 is( stateless(), 44, 'stateless function, second time' );
126 my $xsize = stateful_array();
127 is( $xsize, 0, 'uninitialized state array' );
129 $xsize = stateful_array();
130 is( $xsize, 1, 'uninitialized state array after one iteration' );
139 my $xhval = stateful_hash();
140 is( $xhval, 0, 'uninitialized state hash' );
142 $xhval = stateful_hash();
143 is( $xhval, 1, 'uninitialized state hash after one iteration' );
149 state $recursed_state = 123;
150 is($recursed_state, 123, "state kept through recursion ($level)");
151 noseworth($level - 1) if $level;
155 # Assignment return value
157 sub pugnax { my $x = state $y = 42; $y++; $x; }
159 is( pugnax(), 42, 'scalar state assignment return value' );
160 is( pugnax(), 43, 'scalar state assignment return value' );
164 # Test various blocks.
166 foreach my $x (1 .. 3) {
168 is ($y, 1, "foreach $x");
171 for (my $x = 1; $x < 4; $x ++) {
173 is ($y, 1, "for $x");
178 is ($y, 1, "while $x");
185 is ($y, 1, "until $x");
195 is ($z, $y, "bare block $y");
203 my @stones = qw [fred wilma barny betty];
204 my $first = $stones [0];
205 my $First = ucfirst $first;
207 foreach my $flint (@stones) {
209 is $_, $first, 'state $_';
210 ok /$first/, '/.../ binds to $_';
211 is ucfirst, $First, '$_ default argument';
213 is $_, "bambam", '$_ is still there';
218 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
220 my $next = shift @simpsons;
221 state $simpson = $next;
222 is $simpson, 'Homer', 'goto 1';
223 goto again if @simpsons;
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";
235 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
237 my $next = shift @presidents;
238 state $president = $next;
239 goto &president if @presidents;
242 my $president_answer = $presidents [0];
243 is president, $president_answer, '&goto';
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;
259 my @apollo = qw [Eagle Antares Odyssey Aquarius];
260 my @result1 = map {state $x = $_;} @apollo;
261 my @result2 = grep {state $x = /Eagle/} @apollo;
264 is "@result1", $apollo [0] x @apollo, "map";
265 is "@result2", "@apollo", "grep";
269 # Reference to state variable.
271 sub reference {\state $x}
272 my $ref1 = reference;
273 my $ref2 = reference;
274 is $ref1, $ref2, "Reference to state variable";
277 # Pre/post increment.
279 foreach my $x (1 .. 3) {
282 is $y, $x, "state pre increment";
283 is $z, $x, "state post increment";
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);
298 is $tintin, "xin-Tin", "substr";
299 is $tb, $thunderbirds2 [$x], "substr";
306 my @spam = qw [spam ham bacon beans];
307 foreach my $spam (@spam) {
308 given (state $spam = $spam) {
309 when ($spam [0]) {ok 1, "given"}
310 default {ok 0, "given"}
321 is $x, "two", "masked"
324 # normally closureless anon subs share a CV and pad. If the anon sub has a
325 # state var, this would mean that it is shared. Check that this doesn't
330 push @f, sub { state $x; ++$x } for 1..2;
336 # each copy of an anon sub should get its own 'once block'
339 my $x; # used to force a closure
341 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
351 foreach my $forbidden (<DATA>) {
355 like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
358 # [perl #49522] state variable not available
362 local $SIG{__WARN__} = sub { push @warnings, $_[0] };
380 is $@, '', "eval f_49522";
381 # shouldn't be any 'not available' or 'not stay shared' warnings
382 ok !@warnings, "suppress warnings part 1 [@warnings]";
386 is $f->(), 88, "state var closure 1";
387 is g_49522(), 88, "state var closure 2";
388 ok !@warnings, "suppress warnings part 2 [@warnings]";
393 h_49522(); # initialise $t
394 is $f->(), 99, "state var closure 3";
395 ok !@warnings, "suppress warnings part 3 [@warnings]";
412 (state $a, state $b) = ();
414 (state $a, my $b) = ();
415 (state $a, state @b) = ();
416 (state $a, local @b) = ();
417 (state $a, undef, state $b) = ();
418 state ($a, undef, $b) = ();