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