This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
initialisation of simple aggregate state variables
[perl5.git] / t / op / state.t
CommitLineData
952306ac 1#!./perl -w
ea84231e 2# tests state variables
952306ac
RGS
3
4BEGIN {
5 chdir 't' if -d 't';
952306ac 6 require './test.pl';
624c42e2 7 set_up_inc('../lib');
952306ac
RGS
8}
9
10use strict;
9dcb8368 11
f99042c8 12plan tests => 164;
9dcb8368
FC
13
14# Before loading feature.pm, test it with CORE::
15ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
16
17
642c9703 18use feature ":5.10";
952306ac 19
952306ac
RGS
20
21ok( ! defined state $uninit, q(state vars are undef by default) );
22
ea84231e
RGS
23# basic functionality
24
952306ac
RGS
25sub stateful {
26 state $x;
c5917253 27 state $y = 1;
952306ac 28 my $z = 2;
b708784e 29 state ($t) //= 3;
84f64f45 30 return ($x++, $y++, $z++, $t++);
952306ac
RGS
31}
32
84f64f45 33my ($x, $y, $z, $t) = stateful();
952306ac
RGS
34is( $x, 0, 'uninitialized state var' );
35is( $y, 1, 'initialized state var' );
36is( $z, 2, 'lexical' );
84f64f45 37is( $t, 3, 'initialized state var, list syntax' );
952306ac 38
84f64f45 39($x, $y, $z, $t) = stateful();
952306ac
RGS
40is( $x, 1, 'incremented state var' );
41is( $y, 2, 'incremented state var' );
42is( $z, 2, 'reinitialized lexical' );
84f64f45 43is( $t, 4, 'incremented state var, list syntax' );
952306ac 44
84f64f45 45($x, $y, $z, $t) = stateful();
952306ac
RGS
46is( $x, 2, 'incremented state var' );
47is( $y, 3, 'incremented state var' );
48is( $z, 2, 'reinitialized lexical' );
84f64f45 49is( $t, 5, 'incremented state var, list syntax' );
952306ac 50
ea84231e
RGS
51# in a nested block
52
952306ac 53sub nesting {
c5917253 54 state $foo = 10;
952306ac 55 my $t;
c5917253 56 { state $bar = 12; $t = ++$bar }
952306ac
RGS
57 ++$foo;
58 return ($foo, $t);
59}
60
61($x, $y) = nesting();
62is( $x, 11, 'outer state var' );
63is( $y, 13, 'inner state var' );
64
65($x, $y) = nesting();
66is( $x, 12, 'outer state var' );
67is( $y, 14, 'inner state var' );
68
ea84231e
RGS
69# in a closure
70
952306ac
RGS
71sub generator {
72 my $outer;
73 # we use $outer to generate a closure
74 sub { ++$outer; ++state $x }
75}
76
77my $f1 = generator();
78is( $f1->(), 1, 'generator 1' );
79is( $f1->(), 2, 'generator 1' );
80my $f2 = generator();
81is( $f2->(), 1, 'generator 2' );
82is( $f1->(), 3, 'generator 1 again' );
83is( $f2->(), 2, 'generator 2 once more' );
5d1e1362 84
ea84231e 85# with ties
5d1e1362
RGS
86{
87 package countfetches;
88 our $fetchcount = 0;
89 sub TIESCALAR {bless {}};
90 sub FETCH { ++$fetchcount; 18 };
91 tie my $y, "countfetches";
c5917253 92 sub foo { state $x = $y; $x++ }
5d1e1362
RGS
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}
aa2c6373 98
ea84231e
RGS
99# state variables are shared among closures
100
101sub gen_cashier {
102 my $amount = shift;
c5917253 103 state $cash_in_store = 0;
ea84231e
RGS
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
111gen_cashier(59)->{add}->();
112gen_cashier(17)->{del}->();
113is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
114
115# stateless assignment to a state variable
116
aa2c6373 117sub stateless {
b708784e 118 state $reinitme = 42;
aa2c6373
RGS
119 ++$reinitme;
120}
121is( stateless(), 43, 'stateless function, first time' );
c5917253 122is( stateless(), 44, 'stateless function, second time' );
a5911867
RGS
123
124# array state vars
125
126sub stateful_array {
127 state @x;
128 push @x, 'x';
129 return $#x;
130}
131
132my $xsize = stateful_array();
133is( $xsize, 0, 'uninitialized state array' );
134
135$xsize = stateful_array();
136is( $xsize, 1, 'uninitialized state array after one iteration' );
137
f99042c8
Z
138sub stateful_init_array {
139 state @x = qw(a b c);
140 push @x, "x";
141 return join(",", @x);
142}
143
144is stateful_init_array(), "a,b,c,x";
145is stateful_init_array(), "a,b,c,x,x";
146is stateful_init_array(), "a,b,c,x,x,x";
147
a5911867
RGS
148# hash state vars
149
150sub stateful_hash {
151 state %hx;
152 return $hx{foo}++;
153}
154
155my $xhval = stateful_hash();
156is( $xhval, 0, 'uninitialized state hash' );
157
158$xhval = stateful_hash();
159is( $xhval, 1, 'uninitialized state hash after one iteration' );
a53dbfbb 160
f99042c8
Z
161sub stateful_init_hash {
162 state %x = qw(a b c d);
163 $x{foo}++;
164 return join(",", map { ($_, $x{$_}) } sort keys %x);
165}
166
167is stateful_init_hash(), "a,b,c,d,foo,1";
168is stateful_init_hash(), "a,b,c,d,foo,2";
169is stateful_init_hash(), "a,b,c,d,foo,3";
170
171# declarations with attributes
172
173sub stateful_attr {
174 state $a :shared;
175 state $b :shared = 3;
176 state @c :shared;
177 state @d :shared = qw(a b c);
178 state %e :shared;
179 state %f :shared = qw(a b c d);
180 $a++;
181 $b++;
182 push @c, "x";
183 push @d, "x";
184 $e{e}++;
185 $f{e}++;
186 return join(",", $a, $b, join(":", @c), join(":", @d), join(":", %e),
187 join(":", map { ($_, $f{$_}) } sort keys %f));
188}
189
190is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
191is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
192is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
193
fda94784
RGS
194# Recursion
195
196sub noseworth {
197 my $level = shift;
198 state $recursed_state = 123;
199 is($recursed_state, 123, "state kept through recursion ($level)");
200 noseworth($level - 1) if $level;
201}
202noseworth(2);
84f64f45
RGS
203
204# Assignment return value
205
206sub pugnax { my $x = state $y = 42; $y++; $x; }
207
208is( pugnax(), 42, 'scalar state assignment return value' );
c5917253 209is( pugnax(), 43, 'scalar state assignment return value' );
642c9703
A
210
211
212#
213# Test various blocks.
214#
215foreach my $x (1 .. 3) {
216 state $y = $x;
217 is ($y, 1, "foreach $x");
218}
219
220for (my $x = 1; $x < 4; $x ++) {
221 state $y = $x;
222 is ($y, 1, "for $x");
223}
224
225while ($x < 4) {
226 state $y = $x;
227 is ($y, 1, "while $x");
228 $x ++;
229}
230
231$x = 1;
232until ($x >= 4) {
233 state $y = $x;
234 is ($y, 1, "until $x");
235 $x ++;
236}
237
238$x = 0;
239$y = 0;
240{
241 state $z = $x;
242 $z ++;
243 $y ++;
244 is ($z, $y, "bare block $y");
245 redo if $y < 3
246}
247
248
249#
642c9703
A
250# Goto.
251#
252my @simpsons = qw [Homer Marge Bart Lisa Maggie];
253again:
254 my $next = shift @simpsons;
255 state $simpson = $next;
256 is $simpson, 'Homer', 'goto 1';
257 goto again if @simpsons;
258
642c9703
A
259my $vi;
260{
b500e03b 261 goto Elvis unless $vi;
642c9703
A
262 state $calvin = ++ $vi;
263 Elvis: state $vile = ++ $vi;
264 redo unless defined $calvin;
265 is $calvin, 2, "goto 2";
266 is $vile, 1, "goto 3";
267 is $vi, 2, "goto 4";
268}
269my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
270sub president {
271 my $next = shift @presidents;
272 state $president = $next;
273 goto &president if @presidents;
274 $president;
275}
276my $president_answer = $presidents [0];
277is president, $president_answer, '&goto';
278
279my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
280foreach my $f (@flowers) {
281 goto state $flower = $f;
282 ok 0, 'computed goto 0'; next;
283 Bluebonnet: ok 1, 'computed goto 1'; next;
284 Goldenrod: ok 0, 'computed goto 2'; next;
285 Hawthorn: ok 0, 'computed goto 3'; next;
286 Peony: ok 0, 'computed goto 4'; next;
287 ok 0, 'computed goto 5'; next;
288}
289
290#
291# map/grep
292#
293my @apollo = qw [Eagle Antares Odyssey Aquarius];
294my @result1 = map {state $x = $_;} @apollo;
295my @result2 = grep {state $x = /Eagle/} @apollo;
296{
297 local $" = "";
298 is "@result1", $apollo [0] x @apollo, "map";
299 is "@result2", "@apollo", "grep";
300}
301
302#
303# Reference to state variable.
304#
305sub reference {\state $x}
306my $ref1 = reference;
307my $ref2 = reference;
308is $ref1, $ref2, "Reference to state variable";
309
310#
311# Pre/post increment.
312#
313foreach my $x (1 .. 3) {
314 ++ state $y;
315 state $z ++;
316 is $y, $x, "state pre increment";
317 is $z, $x, "state post increment";
318}
319
320
321#
322# Substr
323#
324my $tintin = "Tin-Tin";
325my @thunderbirds = qw [Scott Virgel Alan Gordon John];
326my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
327foreach my $x (0 .. 4) {
328 state $c = \substr $tintin, $x, 1;
329 my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
330 $$c = "x";
331 $$d = "x";
332 is $tintin, "xin-Tin", "substr";
333 is $tb, $thunderbirds2 [$x], "substr";
334}
335
336
337#
642c9703
A
338# Use with given.
339#
340my @spam = qw [spam ham bacon beans];
341foreach my $spam (@spam) {
0f539b13 342 no warnings 'experimental::smartmatch';
642c9703
A
343 given (state $spam = $spam) {
344 when ($spam [0]) {ok 1, "given"}
345 default {ok 0, "given"}
346 }
347}
348
349#
350# Redefine.
351#
352{
353 state $x = "one";
354 no warnings;
355 state $x = "two";
356 is $x, "two", "masked"
357}
6dbe9451 358
a74073ad
DM
359# normally closureless anon subs share a CV and pad. If the anon sub has a
360# state var, this would mean that it is shared. Check that this doesn't
361# happen
362
363{
364 my @f;
365 push @f, sub { state $x; ++$x } for 1..2;
366 $f[0]->() for 1..10;
367 is $f[0]->(), 11;
368 is $f[1]->(), 1;
369}
370
0d3b281c
DM
371# each copy of an anon sub should get its own 'once block'
372
373{
374 my $x; # used to force a closure
375 my @f;
c23d26f1 376 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
0d3b281c
DM
377 is $f[0]->(1), 1;
378 is $f[0]->(2), 1;
379 is $f[1]->(3), 3;
380 is $f[1]->(4), 3;
381}
382
383
384
385
6dbe9451
NC
386foreach my $forbidden (<DATA>) {
387 chomp $forbidden;
388 no strict 'vars';
389 eval $forbidden;
f99042c8 390 like $@, qr/Initialization of state variables in list currently forbidden/, "Currently forbidden: $forbidden";
6dbe9451 391}
d1186544
DM
392
393# [perl #49522] state variable not available
394
395{
396 my @warnings;
397 local $SIG{__WARN__} = sub { push @warnings, $_[0] };
398
399 eval q{
400 use warnings;
401
402 sub f_49522 {
403 state $s = 88;
404 sub g_49522 { $s }
405 sub { $s };
406 }
407
408 sub h_49522 {
409 state $t = 99;
410 sub i_49522 {
411 sub { $t };
412 }
413 }
414 };
415 is $@, '', "eval f_49522";
416 # shouldn't be any 'not available' or 'not stay shared' warnings
417 ok !@warnings, "suppress warnings part 1 [@warnings]";
418
419 @warnings = ();
420 my $f = f_49522();
421 is $f->(), 88, "state var closure 1";
422 is g_49522(), 88, "state var closure 2";
423 ok !@warnings, "suppress warnings part 2 [@warnings]";
424
425
426 @warnings = ();
427 $f = i_49522();
428 h_49522(); # initialise $t
429 is $f->(), 99, "state var closure 3";
430 ok !@warnings, "suppress warnings part 3 [@warnings]";
431
432
433}
434
435
1e45dee4
DM
436# [perl #117095] state var initialisation getting skipped
437# the 'if 0' code below causes a call to op_free at compile-time,
438# which used to inadvertently mark the state var as initialised.
439
440{
441 state $f = 1;
442 foo($f) if 0; # this calls op_free on padmy($f)
443 ok(defined $f, 'state init not skipped');
444}
445
872fcb08
MH
446# [perl #121134] Make sure padrange doesn't mess with these
447{
448 sub thing {
449 my $expect = shift;
450 my ($x, $y);
451 state $z;
452
453 is($z, $expect, "State variable is correct");
454
455 $z = 5;
456 }
457
458 thing(undef);
459 thing(5);
460
461 sub thing2 {
462 my $expect = shift;
463 my $x;
464 my $y;
465 state $z;
466
467 is($z, $expect, "State variable is correct");
468
469 $z = 6;
470 }
471
472 thing2(undef);
473 thing2(6);
474}
475
c4a33ecd
AC
476# [perl #123029] regression in "state" under PERL_NO_COW
477sub rt_123029 {
478 state $s;
a4f1ca6e 479 $s = 'foo'x500;
c4a33ecd
AC
480 my $c = $s;
481 return defined $s;
482}
483ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
1e45dee4 484
e839e6ed
DM
485# make sure multiconcat doesn't break state
486
487for (1,2) {
488 state $s = "-$_-";
489 is($s, "-1-", "state with multiconcat pass $_");
490}
491
6dbe9451 492__DATA__
6dbe9451 493(state $a) = 1;
6dbe9451 494(state @a) = 1;
f99042c8 495(state @a :shared) = 1;
6dbe9451 496(state %a) = ();
f99042c8
Z
497(state %a :shared) = ();
498state ($a) = 1;
499(state ($a)) = 1;
500state (@a) = 1;
501(state (@a)) = 1;
502state (@a) :shared = 1;
503(state (@a) :shared) = 1;
504state (%a) = ();
505(state (%a)) = ();
506state (%a) :shared = ();
507(state (%a) :shared) = ();
508state (undef, $a) = ();
509(state (undef, $a)) = ();
510state (undef, @a) = ();
511(state (undef, @a)) = ();
512state ($a, undef) = ();
513(state ($a, undef)) = ();
6dbe9451 514state ($a, $b) = ();
f99042c8
Z
515(state ($a, $b)) = ();
516state ($a, $b) :shared = ();
517(state ($a, $b) :shared) = ();
6dbe9451 518state ($a, @b) = ();
f99042c8
Z
519(state ($a, @b)) = ();
520state ($a, @b) :shared = ();
521(state ($a, @b) :shared) = ();
522state (@a, undef) = ();
523(state (@a, undef)) = ();
524state (@a, $b) = ();
525(state (@a, $b)) = ();
526state (@a, $b) :shared = ();
527(state (@a, $b) :shared) = ();
528state (@a, @b) = ();
529(state (@a, @b)) = ();
530state (@a, @b) :shared = ();
531(state (@a, @b) :shared) = ();
6dbe9451
NC
532(state $a, state $b) = ();
533(state $a, $b) = ();
534(state $a, my $b) = ();
535(state $a, state @b) = ();
536(state $a, local @b) = ();
537(state $a, undef, state $b) = ();
538state ($a, undef, $b) = ();