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
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 sub 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
190 is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
191 is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
192 is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
193
194 # Recursion
195
196 sub 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 }
202 noseworth(2);
203
204 # Assignment return value
205
206 sub pugnax { my $x = state $y = 42; $y++; $x; }
207
208 is( pugnax(), 42, 'scalar state assignment return value' );
209 is( pugnax(), 43, 'scalar state assignment return value' );
210
211
212 #
213 # Test various blocks.
214 #
215 foreach my $x (1 .. 3) {
216     state $y = $x;
217     is ($y, 1, "foreach $x");
218 }
219
220 for (my $x = 1; $x < 4; $x ++) {
221     state $y = $x;
222     is ($y, 1, "for $x");
223 }
224
225 while ($x < 4) {
226     state $y = $x;
227     is ($y, 1, "while $x");
228     $x ++;
229 }
230
231 $x = 1;
232 until ($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 #
250 # Goto.
251 #
252 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
253 again:
254     my $next = shift @simpsons;
255     state $simpson = $next;
256     is $simpson, 'Homer', 'goto 1';
257     goto again if @simpsons;
258
259 my $vi;
260 {
261     goto Elvis unless $vi;
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 }
269 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
270 sub president {
271     my $next = shift @presidents;
272     state $president = $next;
273     goto  &president if @presidents;
274     $president;
275 }
276 my $president_answer = $presidents [0];
277 is president, $president_answer, '&goto';
278
279 my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
280 foreach 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 #
293 my @apollo  = qw [Eagle Antares Odyssey Aquarius];
294 my @result1 = map  {state $x = $_;}     @apollo;
295 my @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 #
305 sub reference {\state $x}
306 my $ref1 = reference;
307 my $ref2 = reference;
308 is $ref1, $ref2, "Reference to state variable";
309
310 #
311 # Pre/post increment.
312 #
313 foreach 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 #
324 my $tintin = "Tin-Tin";
325 my @thunderbirds  = qw [Scott Virgel Alan Gordon John];
326 my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
327 foreach 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 #
338 # Use with given.
339 #
340 my @spam = qw [spam ham bacon beans];
341 foreach my $spam (@spam) {
342     no warnings 'experimental::smartmatch';
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 }
358
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
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;
376     push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
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
386 foreach my $forbidden (<DATA>) {
387     chomp $forbidden;
388     no strict 'vars';
389     eval $forbidden;
390     like $@, qr/Initialization of state variables in list currently forbidden/, "Currently forbidden: $forbidden";
391 }
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
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
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
476 # [perl #123029] regression in "state" under PERL_NO_COW
477 sub rt_123029 {
478     state $s;
479     $s = 'foo'x500;
480     my $c = $s;
481     return defined $s;
482 }
483 ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
484
485 # make sure multiconcat doesn't break state
486
487 for (1,2) {
488     state $s = "-$_-";
489     is($s, "-1-", "state with multiconcat pass $_");
490 }
491
492 __DATA__
493 (state $a) = 1;
494 (state @a) = 1;
495 (state @a :shared) = 1;
496 (state %a) = ();
497 (state %a :shared) = ();
498 state ($a) = 1;
499 (state ($a)) = 1;
500 state (@a) = 1;
501 (state (@a)) = 1;
502 state (@a) :shared = 1;
503 (state (@a) :shared) = 1;
504 state (%a) = ();
505 (state (%a)) = ();
506 state (%a) :shared = ();
507 (state (%a) :shared) = ();
508 state (undef, $a) = ();
509 (state (undef, $a)) = ();
510 state (undef, @a) = ();
511 (state (undef, @a)) = ();
512 state ($a, undef) = ();
513 (state ($a, undef)) = ();
514 state ($a, $b) = ();
515 (state ($a, $b)) = ();
516 state ($a, $b) :shared = ();
517 (state ($a, $b) :shared) = ();
518 state ($a, @b) = ();
519 (state ($a, @b)) = ();
520 state ($a, @b) :shared = ();
521 (state ($a, @b) :shared) = ();
522 state (@a, undef) = ();
523 (state (@a, undef)) = ();
524 state (@a, $b) = ();
525 (state (@a, $b)) = ();
526 state (@a, $b) :shared = ();
527 (state (@a, $b) :shared) = ();
528 state (@a, @b) = ();
529 (state (@a, @b)) = ();
530 state (@a, @b) :shared = ();
531 (state (@a, @b) :shared) = ();
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) = ();
538 state ($a, undef, $b) = ();