This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #49522] state variable not available
[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;
642c9703 11use feature ":5.10";
952306ac 12
d1186544 13plan tests => 130;
952306ac
RGS
14
15ok( ! defined state $uninit, q(state vars are undef by default) );
16
ea84231e
RGS
17# basic functionality
18
952306ac
RGS
19sub stateful {
20 state $x;
c5917253 21 state $y = 1;
952306ac 22 my $z = 2;
b708784e 23 state ($t) //= 3;
84f64f45 24 return ($x++, $y++, $z++, $t++);
952306ac
RGS
25}
26
84f64f45 27my ($x, $y, $z, $t) = stateful();
952306ac
RGS
28is( $x, 0, 'uninitialized state var' );
29is( $y, 1, 'initialized state var' );
30is( $z, 2, 'lexical' );
84f64f45 31is( $t, 3, 'initialized state var, list syntax' );
952306ac 32
84f64f45 33($x, $y, $z, $t) = stateful();
952306ac
RGS
34is( $x, 1, 'incremented state var' );
35is( $y, 2, 'incremented state var' );
36is( $z, 2, 'reinitialized lexical' );
84f64f45 37is( $t, 4, 'incremented state var, list syntax' );
952306ac 38
84f64f45 39($x, $y, $z, $t) = stateful();
952306ac
RGS
40is( $x, 2, 'incremented state var' );
41is( $y, 3, 'incremented state var' );
42is( $z, 2, 'reinitialized lexical' );
84f64f45 43is( $t, 5, 'incremented state var, list syntax' );
952306ac 44
ea84231e
RGS
45# in a nested block
46
952306ac 47sub nesting {
c5917253 48 state $foo = 10;
952306ac 49 my $t;
c5917253 50 { state $bar = 12; $t = ++$bar }
952306ac
RGS
51 ++$foo;
52 return ($foo, $t);
53}
54
55($x, $y) = nesting();
56is( $x, 11, 'outer state var' );
57is( $y, 13, 'inner state var' );
58
59($x, $y) = nesting();
60is( $x, 12, 'outer state var' );
61is( $y, 14, 'inner state var' );
62
ea84231e
RGS
63# in a closure
64
952306ac
RGS
65sub generator {
66 my $outer;
67 # we use $outer to generate a closure
68 sub { ++$outer; ++state $x }
69}
70
71my $f1 = generator();
72is( $f1->(), 1, 'generator 1' );
73is( $f1->(), 2, 'generator 1' );
74my $f2 = generator();
75is( $f2->(), 1, 'generator 2' );
76is( $f1->(), 3, 'generator 1 again' );
77is( $f2->(), 2, 'generator 2 once more' );
5d1e1362 78
ea84231e 79# with ties
5d1e1362
RGS
80{
81 package countfetches;
82 our $fetchcount = 0;
83 sub TIESCALAR {bless {}};
84 sub FETCH { ++$fetchcount; 18 };
85 tie my $y, "countfetches";
c5917253 86 sub foo { state $x = $y; $x++ }
5d1e1362
RGS
87 ::is( foo(), 18, "initialisation with tied variable" );
88 ::is( foo(), 19, "increments correctly" );
89 ::is( foo(), 20, "increments correctly, twice" );
90 ::is( $fetchcount, 1, "fetch only called once" );
91}
aa2c6373 92
ea84231e
RGS
93# state variables are shared among closures
94
95sub gen_cashier {
96 my $amount = shift;
c5917253 97 state $cash_in_store = 0;
ea84231e
RGS
98 return {
99 add => sub { $cash_in_store += $amount },
100 del => sub { $cash_in_store -= $amount },
101 bal => sub { $cash_in_store },
102 };
103}
104
105gen_cashier(59)->{add}->();
106gen_cashier(17)->{del}->();
107is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
108
109# stateless assignment to a state variable
110
aa2c6373 111sub stateless {
b708784e 112 state $reinitme = 42;
aa2c6373
RGS
113 ++$reinitme;
114}
115is( stateless(), 43, 'stateless function, first time' );
c5917253 116is( stateless(), 44, 'stateless function, second time' );
a5911867
RGS
117
118# array state vars
119
120sub stateful_array {
121 state @x;
122 push @x, 'x';
123 return $#x;
124}
125
126my $xsize = stateful_array();
127is( $xsize, 0, 'uninitialized state array' );
128
129$xsize = stateful_array();
130is( $xsize, 1, 'uninitialized state array after one iteration' );
131
132# hash state vars
133
134sub stateful_hash {
135 state %hx;
136 return $hx{foo}++;
137}
138
139my $xhval = stateful_hash();
140is( $xhval, 0, 'uninitialized state hash' );
141
142$xhval = stateful_hash();
143is( $xhval, 1, 'uninitialized state hash after one iteration' );
a53dbfbb 144
fda94784
RGS
145# Recursion
146
147sub noseworth {
148 my $level = shift;
149 state $recursed_state = 123;
150 is($recursed_state, 123, "state kept through recursion ($level)");
151 noseworth($level - 1) if $level;
152}
153noseworth(2);
84f64f45
RGS
154
155# Assignment return value
156
157sub pugnax { my $x = state $y = 42; $y++; $x; }
158
159is( pugnax(), 42, 'scalar state assignment return value' );
c5917253 160is( pugnax(), 43, 'scalar state assignment return value' );
642c9703
A
161
162
163#
164# Test various blocks.
165#
166foreach my $x (1 .. 3) {
167 state $y = $x;
168 is ($y, 1, "foreach $x");
169}
170
171for (my $x = 1; $x < 4; $x ++) {
172 state $y = $x;
173 is ($y, 1, "for $x");
174}
175
176while ($x < 4) {
177 state $y = $x;
178 is ($y, 1, "while $x");
179 $x ++;
180}
181
182$x = 1;
183until ($x >= 4) {
184 state $y = $x;
185 is ($y, 1, "until $x");
186 $x ++;
187}
188
189$x = 0;
190$y = 0;
191{
192 state $z = $x;
193 $z ++;
194 $y ++;
195 is ($z, $y, "bare block $y");
196 redo if $y < 3
197}
198
199
200#
201# Check state $_
202#
203my @stones = qw [fred wilma barny betty];
204my $first = $stones [0];
205my $First = ucfirst $first;
206$_ = "bambam";
207foreach my $flint (@stones) {
208 state $_ = $flint;
209 is $_, $first, 'state $_';
210 ok /$first/, '/.../ binds to $_';
211 is ucfirst, $First, '$_ default argument';
212}
213is $_, "bambam", '$_ is still there';
214
215#
216# Goto.
217#
218my @simpsons = qw [Homer Marge Bart Lisa Maggie];
219again:
220 my $next = shift @simpsons;
221 state $simpson = $next;
222 is $simpson, 'Homer', 'goto 1';
223 goto again if @simpsons;
224
225goto Elvis;
226my $vi;
227{
228 state $calvin = ++ $vi;
229 Elvis: state $vile = ++ $vi;
230 redo unless defined $calvin;
231 is $calvin, 2, "goto 2";
232 is $vile, 1, "goto 3";
233 is $vi, 2, "goto 4";
234}
235my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
236sub president {
237 my $next = shift @presidents;
238 state $president = $next;
239 goto &president if @presidents;
240 $president;
241}
242my $president_answer = $presidents [0];
243is president, $president_answer, '&goto';
244
245my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
246foreach my $f (@flowers) {
247 goto state $flower = $f;
248 ok 0, 'computed goto 0'; next;
249 Bluebonnet: ok 1, 'computed goto 1'; next;
250 Goldenrod: ok 0, 'computed goto 2'; next;
251 Hawthorn: ok 0, 'computed goto 3'; next;
252 Peony: ok 0, 'computed goto 4'; next;
253 ok 0, 'computed goto 5'; next;
254}
255
256#
257# map/grep
258#
259my @apollo = qw [Eagle Antares Odyssey Aquarius];
260my @result1 = map {state $x = $_;} @apollo;
261my @result2 = grep {state $x = /Eagle/} @apollo;
262{
263 local $" = "";
264 is "@result1", $apollo [0] x @apollo, "map";
265 is "@result2", "@apollo", "grep";
266}
267
268#
269# Reference to state variable.
270#
271sub reference {\state $x}
272my $ref1 = reference;
273my $ref2 = reference;
274is $ref1, $ref2, "Reference to state variable";
275
276#
277# Pre/post increment.
278#
279foreach my $x (1 .. 3) {
280 ++ state $y;
281 state $z ++;
282 is $y, $x, "state pre increment";
283 is $z, $x, "state post increment";
284}
285
286
287#
288# Substr
289#
290my $tintin = "Tin-Tin";
291my @thunderbirds = qw [Scott Virgel Alan Gordon John];
292my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
293foreach my $x (0 .. 4) {
294 state $c = \substr $tintin, $x, 1;
295 my $d = \substr ((state $tb = $thunderbirds [$x]), $x, 1);
296 $$c = "x";
297 $$d = "x";
298 is $tintin, "xin-Tin", "substr";
299 is $tb, $thunderbirds2 [$x], "substr";
300}
301
302
303#
642c9703
A
304# Use with given.
305#
306my @spam = qw [spam ham bacon beans];
307foreach my $spam (@spam) {
308 given (state $spam = $spam) {
309 when ($spam [0]) {ok 1, "given"}
310 default {ok 0, "given"}
311 }
312}
313
314#
315# Redefine.
316#
317{
318 state $x = "one";
319 no warnings;
320 state $x = "two";
321 is $x, "two", "masked"
322}
6dbe9451 323
a74073ad
DM
324# normally closureless anon subs share a CV and pad. If the anon sub has a
325# state var, this would mean that it is shared. Check that this doesn't
326# happen
327
328{
329 my @f;
330 push @f, sub { state $x; ++$x } for 1..2;
331 $f[0]->() for 1..10;
332 is $f[0]->(), 11;
333 is $f[1]->(), 1;
334}
335
0d3b281c
DM
336# each copy of an anon sub should get its own 'once block'
337
338{
339 my $x; # used to force a closure
340 my @f;
c23d26f1 341 push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
0d3b281c
DM
342 is $f[0]->(1), 1;
343 is $f[0]->(2), 1;
344 is $f[1]->(3), 3;
345 is $f[1]->(4), 3;
346}
347
348
349
350
6dbe9451
NC
351foreach my $forbidden (<DATA>) {
352 chomp $forbidden;
353 no strict 'vars';
354 eval $forbidden;
355 like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden";
356}
d1186544
DM
357
358# [perl #49522] state variable not available
359
360{
361 my @warnings;
362 local $SIG{__WARN__} = sub { push @warnings, $_[0] };
363
364 eval q{
365 use warnings;
366
367 sub f_49522 {
368 state $s = 88;
369 sub g_49522 { $s }
370 sub { $s };
371 }
372
373 sub h_49522 {
374 state $t = 99;
375 sub i_49522 {
376 sub { $t };
377 }
378 }
379 };
380 is $@, '', "eval f_49522";
381 # shouldn't be any 'not available' or 'not stay shared' warnings
382 ok !@warnings, "suppress warnings part 1 [@warnings]";
383
384 @warnings = ();
385 my $f = f_49522();
386 is $f->(), 88, "state var closure 1";
387 is g_49522(), 88, "state var closure 2";
388 ok !@warnings, "suppress warnings part 2 [@warnings]";
389
390
391 @warnings = ();
392 $f = i_49522();
393 h_49522(); # initialise $t
394 is $f->(), 99, "state var closure 3";
395 ok !@warnings, "suppress warnings part 3 [@warnings]";
396
397
398}
399
400
6dbe9451
NC
401__DATA__
402state ($a) = 1;
403(state $a) = 1;
404state @a = 1;
405state (@a) = 1;
406(state @a) = 1;
407state %a = ();
408state (%a) = ();
409(state %a) = ();
410state ($a, $b) = ();
411state ($a, @b) = ();
412(state $a, state $b) = ();
413(state $a, $b) = ();
414(state $a, my $b) = ();
415(state $a, state @b) = ();
416(state $a, local @b) = ();
417(state $a, undef, state $b) = ();
418state ($a, undef, $b) = ();