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
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');
c7f61eda 8 skip_all_if_miniperl("miniperl can't load attributes");
952306ac
RGS
9}
10
11use strict;
9dcb8368 12
f99042c8 13plan tests => 164;
9dcb8368
FC
14
15# Before loading feature.pm, test it with CORE::
16ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
17
18
642c9703 19use feature ":5.10";
952306ac 20
952306ac
RGS
21
22ok( ! defined state $uninit, q(state vars are undef by default) );
23
ea84231e
RGS
24# basic functionality
25
952306ac
RGS
26sub stateful {
27 state $x;
c5917253 28 state $y = 1;
952306ac 29 my $z = 2;
b708784e 30 state ($t) //= 3;
84f64f45 31 return ($x++, $y++, $z++, $t++);
952306ac
RGS
32}
33
84f64f45 34my ($x, $y, $z, $t) = stateful();
952306ac
RGS
35is( $x, 0, 'uninitialized state var' );
36is( $y, 1, 'initialized state var' );
37is( $z, 2, 'lexical' );
84f64f45 38is( $t, 3, 'initialized state var, list syntax' );
952306ac 39
84f64f45 40($x, $y, $z, $t) = stateful();
952306ac
RGS
41is( $x, 1, 'incremented state var' );
42is( $y, 2, 'incremented state var' );
43is( $z, 2, 'reinitialized lexical' );
84f64f45 44is( $t, 4, 'incremented state var, list syntax' );
952306ac 45
84f64f45 46($x, $y, $z, $t) = stateful();
952306ac
RGS
47is( $x, 2, 'incremented state var' );
48is( $y, 3, 'incremented state var' );
49is( $z, 2, 'reinitialized lexical' );
84f64f45 50is( $t, 5, 'incremented state var, list syntax' );
952306ac 51
ea84231e
RGS
52# in a nested block
53
952306ac 54sub nesting {
c5917253 55 state $foo = 10;
952306ac 56 my $t;
c5917253 57 { state $bar = 12; $t = ++$bar }
952306ac
RGS
58 ++$foo;
59 return ($foo, $t);
60}
61
62($x, $y) = nesting();
63is( $x, 11, 'outer state var' );
64is( $y, 13, 'inner state var' );
65
66($x, $y) = nesting();
67is( $x, 12, 'outer state var' );
68is( $y, 14, 'inner state var' );
69
ea84231e
RGS
70# in a closure
71
952306ac
RGS
72sub generator {
73 my $outer;
74 # we use $outer to generate a closure
75 sub { ++$outer; ++state $x }
76}
77
78my $f1 = generator();
79is( $f1->(), 1, 'generator 1' );
80is( $f1->(), 2, 'generator 1' );
81my $f2 = generator();
82is( $f2->(), 1, 'generator 2' );
83is( $f1->(), 3, 'generator 1 again' );
84is( $f2->(), 2, 'generator 2 once more' );
5d1e1362 85
ea84231e 86# with ties
5d1e1362
RGS
87{
88 package countfetches;
89 our $fetchcount = 0;
90 sub TIESCALAR {bless {}};
91 sub FETCH { ++$fetchcount; 18 };
92 tie my $y, "countfetches";
c5917253 93 sub foo { state $x = $y; $x++ }
5d1e1362
RGS
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}
aa2c6373 99
ea84231e
RGS
100# state variables are shared among closures
101
102sub gen_cashier {
103 my $amount = shift;
c5917253 104 state $cash_in_store = 0;
ea84231e
RGS
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
112gen_cashier(59)->{add}->();
113gen_cashier(17)->{del}->();
114is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
115
116# stateless assignment to a state variable
117
aa2c6373 118sub stateless {
b708784e 119 state $reinitme = 42;
aa2c6373
RGS
120 ++$reinitme;
121}
122is( stateless(), 43, 'stateless function, first time' );
c5917253 123is( stateless(), 44, 'stateless function, second time' );
a5911867
RGS
124
125# array state vars
126
127sub stateful_array {
128 state @x;
129 push @x, 'x';
130 return $#x;
131}
132
133my $xsize = stateful_array();
134is( $xsize, 0, 'uninitialized state array' );
135
136$xsize = stateful_array();
137is( $xsize, 1, 'uninitialized state array after one iteration' );
138
f99042c8
Z
139sub stateful_init_array {
140 state @x = qw(a b c);
141 push @x, "x";
142 return join(",", @x);
143}
144
145is stateful_init_array(), "a,b,c,x";
146is stateful_init_array(), "a,b,c,x,x";
147is stateful_init_array(), "a,b,c,x,x,x";
148
a5911867
RGS
149# hash state vars
150
151sub stateful_hash {
152 state %hx;
153 return $hx{foo}++;
154}
155
156my $xhval = stateful_hash();
157is( $xhval, 0, 'uninitialized state hash' );
158
159$xhval = stateful_hash();
160is( $xhval, 1, 'uninitialized state hash after one iteration' );
a53dbfbb 161
f99042c8
Z
162sub stateful_init_hash {
163 state %x = qw(a b c d);
164 $x{foo}++;
165 return join(",", map { ($_, $x{$_}) } sort keys %x);
166}
167
168is stateful_init_hash(), "a,b,c,d,foo,1";
169is stateful_init_hash(), "a,b,c,d,foo,2";
170is stateful_init_hash(), "a,b,c,d,foo,3";
171
172# declarations with attributes
173
174sub 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
191is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
192is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
193is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
194
fda94784
RGS
195# Recursion
196
197sub 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}
203noseworth(2);
84f64f45
RGS
204
205# Assignment return value
206
207sub pugnax { my $x = state $y = 42; $y++; $x; }
208
209is( pugnax(), 42, 'scalar state assignment return value' );
c5917253 210is( pugnax(), 43, 'scalar state assignment return value' );
642c9703
A
211
212
213#
214# Test various blocks.
215#
216foreach my $x (1 .. 3) {
217 state $y = $x;
218 is ($y, 1, "foreach $x");
219}
220
221for (my $x = 1; $x < 4; $x ++) {
222 state $y = $x;
223 is ($y, 1, "for $x");
224}
225
226while ($x < 4) {
227 state $y = $x;
228 is ($y, 1, "while $x");
229 $x ++;
230}
231
232$x = 1;
233until ($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#
642c9703
A
251# Goto.
252#
253my @simpsons = qw [Homer Marge Bart Lisa Maggie];
254again:
255 my $next = shift @simpsons;
256 state $simpson = $next;
257 is $simpson, 'Homer', 'goto 1';
258 goto again if @simpsons;
259
642c9703
A
260my $vi;
261{
b500e03b 262 goto Elvis unless $vi;
642c9703
A
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}
270my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
271sub president {
272 my $next = shift @presidents;
273 state $president = $next;
274 goto &president if @presidents;
275 $president;
276}
277my $president_answer = $presidents [0];
278is president, $president_answer, '&goto';
279
280my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
281foreach 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#
294my @apollo = qw [Eagle Antares Odyssey Aquarius];
295my @result1 = map {state $x = $_;} @apollo;
296my @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#
306sub reference {\state $x}
307my $ref1 = reference;
308my $ref2 = reference;
309is $ref1, $ref2, "Reference to state variable";
310
311#
312# Pre/post increment.
313#
314foreach 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#
325my $tintin = "Tin-Tin";
326my @thunderbirds = qw [Scott Virgel Alan Gordon John];
327my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
328foreach 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#
642c9703
A
339# Use with given.
340#
341my @spam = qw [spam ham bacon beans];
342foreach my $spam (@spam) {
0f539b13 343 no warnings 'experimental::smartmatch';
642c9703
A
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}
6dbe9451 359
a74073ad
DM
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
0d3b281c
DM
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;
c23d26f1 377 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
0d3b281c
DM
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
6dbe9451
NC
387foreach my $forbidden (<DATA>) {
388 chomp $forbidden;
389 no strict 'vars';
390 eval $forbidden;
f99042c8 391 like $@, qr/Initialization of state variables in list currently forbidden/, "Currently forbidden: $forbidden";
6dbe9451 392}
d1186544
DM
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
1e45dee4
DM
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
872fcb08
MH
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
c4a33ecd
AC
477# [perl #123029] regression in "state" under PERL_NO_COW
478sub rt_123029 {
479 state $s;
a4f1ca6e 480 $s = 'foo'x500;
c4a33ecd
AC
481 my $c = $s;
482 return defined $s;
483}
484ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
1e45dee4 485
e839e6ed
DM
486# make sure multiconcat doesn't break state
487
488for (1,2) {
489 state $s = "-$_-";
490 is($s, "-1-", "state with multiconcat pass $_");
491}
492
6dbe9451 493__DATA__
6dbe9451 494(state $a) = 1;
6dbe9451 495(state @a) = 1;
f99042c8 496(state @a :shared) = 1;
6dbe9451 497(state %a) = ();
f99042c8
Z
498(state %a :shared) = ();
499state ($a) = 1;
500(state ($a)) = 1;
501state (@a) = 1;
502(state (@a)) = 1;
503state (@a) :shared = 1;
504(state (@a) :shared) = 1;
505state (%a) = ();
506(state (%a)) = ();
507state (%a) :shared = ();
508(state (%a) :shared) = ();
509state (undef, $a) = ();
510(state (undef, $a)) = ();
511state (undef, @a) = ();
512(state (undef, @a)) = ();
513state ($a, undef) = ();
514(state ($a, undef)) = ();
6dbe9451 515state ($a, $b) = ();
f99042c8
Z
516(state ($a, $b)) = ();
517state ($a, $b) :shared = ();
518(state ($a, $b) :shared) = ();
6dbe9451 519state ($a, @b) = ();
f99042c8
Z
520(state ($a, @b)) = ();
521state ($a, @b) :shared = ();
522(state ($a, @b) :shared) = ();
523state (@a, undef) = ();
524(state (@a, undef)) = ();
525state (@a, $b) = ();
526(state (@a, $b)) = ();
527state (@a, $b) :shared = ();
528(state (@a, $b) :shared) = ();
529state (@a, @b) = ();
530(state (@a, @b)) = ();
531state (@a, @b) :shared = ();
532(state (@a, @b) :shared) = ();
6dbe9451
NC
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) = ();
539state ($a, undef, $b) = ();