This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add comment to explain why we want to probe for statfs() et al
[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
e839e6ed 12plan tests => 126;
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
138# hash state vars
139
140sub stateful_hash {
141 state %hx;
142 return $hx{foo}++;
143}
144
145my $xhval = stateful_hash();
146is( $xhval, 0, 'uninitialized state hash' );
147
148$xhval = stateful_hash();
149is( $xhval, 1, 'uninitialized state hash after one iteration' );
a53dbfbb 150
fda94784
RGS
151# Recursion
152
153sub noseworth {
154 my $level = shift;
155 state $recursed_state = 123;
156 is($recursed_state, 123, "state kept through recursion ($level)");
157 noseworth($level - 1) if $level;
158}
159noseworth(2);
84f64f45
RGS
160
161# Assignment return value
162
163sub pugnax { my $x = state $y = 42; $y++; $x; }
164
165is( pugnax(), 42, 'scalar state assignment return value' );
c5917253 166is( pugnax(), 43, 'scalar state assignment return value' );
642c9703
A
167
168
169#
170# Test various blocks.
171#
172foreach my $x (1 .. 3) {
173 state $y = $x;
174 is ($y, 1, "foreach $x");
175}
176
177for (my $x = 1; $x < 4; $x ++) {
178 state $y = $x;
179 is ($y, 1, "for $x");
180}
181
182while ($x < 4) {
183 state $y = $x;
184 is ($y, 1, "while $x");
185 $x ++;
186}
187
188$x = 1;
189until ($x >= 4) {
190 state $y = $x;
191 is ($y, 1, "until $x");
192 $x ++;
193}
194
195$x = 0;
196$y = 0;
197{
198 state $z = $x;
199 $z ++;
200 $y ++;
201 is ($z, $y, "bare block $y");
202 redo if $y < 3
203}
204
205
206#
642c9703
A
207# Goto.
208#
209my @simpsons = qw [Homer Marge Bart Lisa Maggie];
210again:
211 my $next = shift @simpsons;
212 state $simpson = $next;
213 is $simpson, 'Homer', 'goto 1';
214 goto again if @simpsons;
215
642c9703
A
216my $vi;
217{
b500e03b 218 goto Elvis unless $vi;
642c9703
A
219 state $calvin = ++ $vi;
220 Elvis: state $vile = ++ $vi;
221 redo unless defined $calvin;
222 is $calvin, 2, "goto 2";
223 is $vile, 1, "goto 3";
224 is $vi, 2, "goto 4";
225}
226my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
227sub president {
228 my $next = shift @presidents;
229 state $president = $next;
230 goto &president if @presidents;
231 $president;
232}
233my $president_answer = $presidents [0];
234is president, $president_answer, '&goto';
235
236my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
237foreach my $f (@flowers) {
238 goto state $flower = $f;
239 ok 0, 'computed goto 0'; next;
240 Bluebonnet: ok 1, 'computed goto 1'; next;
241 Goldenrod: ok 0, 'computed goto 2'; next;
242 Hawthorn: ok 0, 'computed goto 3'; next;
243 Peony: ok 0, 'computed goto 4'; next;
244 ok 0, 'computed goto 5'; next;
245}
246
247#
248# map/grep
249#
250my @apollo = qw [Eagle Antares Odyssey Aquarius];
251my @result1 = map {state $x = $_;} @apollo;
252my @result2 = grep {state $x = /Eagle/} @apollo;
253{
254 local $" = "";
255 is "@result1", $apollo [0] x @apollo, "map";
256 is "@result2", "@apollo", "grep";
257}
258
259#
260# Reference to state variable.
261#
262sub reference {\state $x}
263my $ref1 = reference;
264my $ref2 = reference;
265is $ref1, $ref2, "Reference to state variable";
266
267#
268# Pre/post increment.
269#
270foreach my $x (1 .. 3) {
271 ++ state $y;
272 state $z ++;
273 is $y, $x, "state pre increment";
274 is $z, $x, "state post increment";
275}
276
277
278#
279# Substr
280#
281my $tintin = "Tin-Tin";
282my @thunderbirds = qw [Scott Virgel Alan Gordon John];
283my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
284foreach my $x (0 .. 4) {
285 state $c = \substr $tintin, $x, 1;
286 my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
287 $$c = "x";
288 $$d = "x";
289 is $tintin, "xin-Tin", "substr";
290 is $tb, $thunderbirds2 [$x], "substr";
291}
292
293
294#
642c9703
A
295# Use with given.
296#
297my @spam = qw [spam ham bacon beans];
298foreach my $spam (@spam) {
0f539b13 299 no warnings 'experimental::smartmatch';
642c9703
A
300 given (state $spam = $spam) {
301 when ($spam [0]) {ok 1, "given"}
302 default {ok 0, "given"}
303 }
304}
305
306#
307# Redefine.
308#
309{
310 state $x = "one";
311 no warnings;
312 state $x = "two";
313 is $x, "two", "masked"
314}
6dbe9451 315
a74073ad
DM
316# normally closureless anon subs share a CV and pad. If the anon sub has a
317# state var, this would mean that it is shared. Check that this doesn't
318# happen
319
320{
321 my @f;
322 push @f, sub { state $x; ++$x } for 1..2;
323 $f[0]->() for 1..10;
324 is $f[0]->(), 11;
325 is $f[1]->(), 1;
326}
327
0d3b281c
DM
328# each copy of an anon sub should get its own 'once block'
329
330{
331 my $x; # used to force a closure
332 my @f;
c23d26f1 333 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
0d3b281c
DM
334 is $f[0]->(1), 1;
335 is $f[0]->(2), 1;
336 is $f[1]->(3), 3;
337 is $f[1]->(4), 3;
338}
339
340
341
342
6dbe9451
NC
343foreach my $forbidden (<DATA>) {
344 chomp $forbidden;
345 no strict 'vars';
346 eval $forbidden;
347 like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
348}
d1186544
DM
349
350# [perl #49522] state variable not available
351
352{
353 my @warnings;
354 local $SIG{__WARN__} = sub { push @warnings, $_[0] };
355
356 eval q{
357 use warnings;
358
359 sub f_49522 {
360 state $s = 88;
361 sub g_49522 { $s }
362 sub { $s };
363 }
364
365 sub h_49522 {
366 state $t = 99;
367 sub i_49522 {
368 sub { $t };
369 }
370 }
371 };
372 is $@, '', "eval f_49522";
373 # shouldn't be any 'not available' or 'not stay shared' warnings
374 ok !@warnings, "suppress warnings part 1 [@warnings]";
375
376 @warnings = ();
377 my $f = f_49522();
378 is $f->(), 88, "state var closure 1";
379 is g_49522(), 88, "state var closure 2";
380 ok !@warnings, "suppress warnings part 2 [@warnings]";
381
382
383 @warnings = ();
384 $f = i_49522();
385 h_49522(); # initialise $t
386 is $f->(), 99, "state var closure 3";
387 ok !@warnings, "suppress warnings part 3 [@warnings]";
388
389
390}
391
392
1e45dee4
DM
393# [perl #117095] state var initialisation getting skipped
394# the 'if 0' code below causes a call to op_free at compile-time,
395# which used to inadvertently mark the state var as initialised.
396
397{
398 state $f = 1;
399 foo($f) if 0; # this calls op_free on padmy($f)
400 ok(defined $f, 'state init not skipped');
401}
402
872fcb08
MH
403# [perl #121134] Make sure padrange doesn't mess with these
404{
405 sub thing {
406 my $expect = shift;
407 my ($x, $y);
408 state $z;
409
410 is($z, $expect, "State variable is correct");
411
412 $z = 5;
413 }
414
415 thing(undef);
416 thing(5);
417
418 sub thing2 {
419 my $expect = shift;
420 my $x;
421 my $y;
422 state $z;
423
424 is($z, $expect, "State variable is correct");
425
426 $z = 6;
427 }
428
429 thing2(undef);
430 thing2(6);
431}
432
c4a33ecd
AC
433# [perl #123029] regression in "state" under PERL_NO_COW
434sub rt_123029 {
435 state $s;
a4f1ca6e 436 $s = 'foo'x500;
c4a33ecd
AC
437 my $c = $s;
438 return defined $s;
439}
440ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
1e45dee4 441
e839e6ed
DM
442# make sure multiconcat doesn't break state
443
444for (1,2) {
445 state $s = "-$_-";
446 is($s, "-1-", "state with multiconcat pass $_");
447}
448
6dbe9451
NC
449__DATA__
450state ($a) = 1;
451(state $a) = 1;
452state @a = 1;
453state (@a) = 1;
454(state @a) = 1;
455state %a = ();
456state (%a) = ();
457(state %a) = ();
458state ($a, $b) = ();
459state ($a, @b) = ();
460(state $a, state $b) = ();
461(state $a, $b) = ();
462(state $a, my $b) = ();
463(state $a, state @b) = ();
464(state $a, local @b) = ();
465(state $a, undef, state $b) = ();
466state ($a, undef, $b) = ();