This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix year of 5.16.3 in perlhist
[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';
6 @INC = '../lib';
7 require './test.pl';
8}
9
10use strict;
9dcb8368
FC
11
12plan tests => 131;
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#
207# Check state $_
208#
209my @stones = qw [fred wilma barny betty];
210my $first = $stones [0];
211my $First = ucfirst $first;
212$_ = "bambam";
213foreach my $flint (@stones) {
dcd695b6 214 no warnings 'experimental::lexical_topic';
642c9703
A
215 state $_ = $flint;
216 is $_, $first, 'state $_';
217 ok /$first/, '/.../ binds to $_';
218 is ucfirst, $First, '$_ default argument';
219}
220is $_, "bambam", '$_ is still there';
221
222#
223# Goto.
224#
225my @simpsons = qw [Homer Marge Bart Lisa Maggie];
226again:
227 my $next = shift @simpsons;
228 state $simpson = $next;
229 is $simpson, 'Homer', 'goto 1';
230 goto again if @simpsons;
231
642c9703
A
232my $vi;
233{
b500e03b 234 goto Elvis unless $vi;
642c9703
A
235 state $calvin = ++ $vi;
236 Elvis: state $vile = ++ $vi;
237 redo unless defined $calvin;
238 is $calvin, 2, "goto 2";
239 is $vile, 1, "goto 3";
240 is $vi, 2, "goto 4";
241}
242my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
243sub president {
244 my $next = shift @presidents;
245 state $president = $next;
246 goto &president if @presidents;
247 $president;
248}
249my $president_answer = $presidents [0];
250is president, $president_answer, '&goto';
251
252my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
253foreach my $f (@flowers) {
254 goto state $flower = $f;
255 ok 0, 'computed goto 0'; next;
256 Bluebonnet: ok 1, 'computed goto 1'; next;
257 Goldenrod: ok 0, 'computed goto 2'; next;
258 Hawthorn: ok 0, 'computed goto 3'; next;
259 Peony: ok 0, 'computed goto 4'; next;
260 ok 0, 'computed goto 5'; next;
261}
262
263#
264# map/grep
265#
266my @apollo = qw [Eagle Antares Odyssey Aquarius];
267my @result1 = map {state $x = $_;} @apollo;
268my @result2 = grep {state $x = /Eagle/} @apollo;
269{
270 local $" = "";
271 is "@result1", $apollo [0] x @apollo, "map";
272 is "@result2", "@apollo", "grep";
273}
274
275#
276# Reference to state variable.
277#
278sub reference {\state $x}
279my $ref1 = reference;
280my $ref2 = reference;
281is $ref1, $ref2, "Reference to state variable";
282
283#
284# Pre/post increment.
285#
286foreach my $x (1 .. 3) {
287 ++ state $y;
288 state $z ++;
289 is $y, $x, "state pre increment";
290 is $z, $x, "state post increment";
291}
292
293
294#
295# Substr
296#
297my $tintin = "Tin-Tin";
298my @thunderbirds = qw [Scott Virgel Alan Gordon John];
299my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
300foreach my $x (0 .. 4) {
301 state $c = \substr $tintin, $x, 1;
302 my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
303 $$c = "x";
304 $$d = "x";
305 is $tintin, "xin-Tin", "substr";
306 is $tb, $thunderbirds2 [$x], "substr";
307}
308
309
310#
642c9703
A
311# Use with given.
312#
313my @spam = qw [spam ham bacon beans];
314foreach my $spam (@spam) {
315 given (state $spam = $spam) {
316 when ($spam [0]) {ok 1, "given"}
317 default {ok 0, "given"}
318 }
319}
320
321#
322# Redefine.
323#
324{
325 state $x = "one";
326 no warnings;
327 state $x = "two";
328 is $x, "two", "masked"
329}
6dbe9451 330
a74073ad
DM
331# normally closureless anon subs share a CV and pad. If the anon sub has a
332# state var, this would mean that it is shared. Check that this doesn't
333# happen
334
335{
336 my @f;
337 push @f, sub { state $x; ++$x } for 1..2;
338 $f[0]->() for 1..10;
339 is $f[0]->(), 11;
340 is $f[1]->(), 1;
341}
342
0d3b281c
DM
343# each copy of an anon sub should get its own 'once block'
344
345{
346 my $x; # used to force a closure
347 my @f;
c23d26f1 348 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
0d3b281c
DM
349 is $f[0]->(1), 1;
350 is $f[0]->(2), 1;
351 is $f[1]->(3), 3;
352 is $f[1]->(4), 3;
353}
354
355
356
357
6dbe9451
NC
358foreach my $forbidden (<DATA>) {
359 chomp $forbidden;
360 no strict 'vars';
361 eval $forbidden;
362 like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
363}
d1186544
DM
364
365# [perl #49522] state variable not available
366
367{
368 my @warnings;
369 local $SIG{__WARN__} = sub { push @warnings, $_[0] };
370
371 eval q{
372 use warnings;
373
374 sub f_49522 {
375 state $s = 88;
376 sub g_49522 { $s }
377 sub { $s };
378 }
379
380 sub h_49522 {
381 state $t = 99;
382 sub i_49522 {
383 sub { $t };
384 }
385 }
386 };
387 is $@, '', "eval f_49522";
388 # shouldn't be any 'not available' or 'not stay shared' warnings
389 ok !@warnings, "suppress warnings part 1 [@warnings]";
390
391 @warnings = ();
392 my $f = f_49522();
393 is $f->(), 88, "state var closure 1";
394 is g_49522(), 88, "state var closure 2";
395 ok !@warnings, "suppress warnings part 2 [@warnings]";
396
397
398 @warnings = ();
399 $f = i_49522();
400 h_49522(); # initialise $t
401 is $f->(), 99, "state var closure 3";
402 ok !@warnings, "suppress warnings part 3 [@warnings]";
403
404
405}
406
407
6dbe9451
NC
408__DATA__
409state ($a) = 1;
410(state $a) = 1;
411state @a = 1;
412state (@a) = 1;
413(state @a) = 1;
414state %a = ();
415state (%a) = ();
416(state %a) = ();
417state ($a, $b) = ();
418state ($a, @b) = ();
419(state $a, state $b) = ();
420(state $a, $b) = ();
421(state $a, my $b) = ();
422(state $a, state @b) = ();
423(state $a, local @b) = ();
424(state $a, undef, state $b) = ();
425state ($a, undef, $b) = ();