This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
39eeecd7c59291b6be7056caa34df2ddbaa6ab92
[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 }
9
10 use strict;
11
12 plan tests => 126;
13
14 # Before loading feature.pm, test it with CORE::
15 ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
16
17
18 use feature ":5.10";
19
20
21 ok( ! defined state $uninit, q(state vars are undef by default) );
22
23 # basic functionality
24
25 sub stateful {
26     state $x;
27     state $y = 1;
28     my $z = 2;
29     state ($t) //= 3;
30     return ($x++, $y++, $z++, $t++);
31 }
32
33 my ($x, $y, $z, $t) = stateful();
34 is( $x, 0, 'uninitialized state var' );
35 is( $y, 1, 'initialized state var' );
36 is( $z, 2, 'lexical' );
37 is( $t, 3, 'initialized state var, list syntax' );
38
39 ($x, $y, $z, $t) = stateful();
40 is( $x, 1, 'incremented state var' );
41 is( $y, 2, 'incremented state var' );
42 is( $z, 2, 'reinitialized lexical' );
43 is( $t, 4, 'incremented state var, list syntax' );
44
45 ($x, $y, $z, $t) = stateful();
46 is( $x, 2, 'incremented state var' );
47 is( $y, 3, 'incremented state var' );
48 is( $z, 2, 'reinitialized lexical' );
49 is( $t, 5, 'incremented state var, list syntax' );
50
51 # in a nested block
52
53 sub nesting {
54     state $foo = 10;
55     my $t;
56     { state $bar = 12; $t = ++$bar }
57     ++$foo;
58     return ($foo, $t);
59 }
60
61 ($x, $y) = nesting();
62 is( $x, 11, 'outer state var' );
63 is( $y, 13, 'inner state var' );
64
65 ($x, $y) = nesting();
66 is( $x, 12, 'outer state var' );
67 is( $y, 14, 'inner state var' );
68
69 # in a closure
70
71 sub generator {
72     my $outer;
73     # we use $outer to generate a closure
74     sub { ++$outer; ++state $x }
75 }
76
77 my $f1 = generator();
78 is( $f1->(), 1, 'generator 1' );
79 is( $f1->(), 2, 'generator 1' );
80 my $f2 = generator();
81 is( $f2->(), 1, 'generator 2' );
82 is( $f1->(), 3, 'generator 1 again' );
83 is( $f2->(), 2, 'generator 2 once more' );
84
85 # with ties
86 {
87     package countfetches;
88     our $fetchcount = 0;
89     sub TIESCALAR {bless {}};
90     sub FETCH { ++$fetchcount; 18 };
91     tie my $y, "countfetches";
92     sub foo { state $x = $y; $x++ }
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 }
98
99 # state variables are shared among closures
100
101 sub gen_cashier {
102     my $amount = shift;
103     state $cash_in_store = 0;
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
111 gen_cashier(59)->{add}->();
112 gen_cashier(17)->{del}->();
113 is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
114
115 # stateless assignment to a state variable
116
117 sub stateless {
118     state $reinitme = 42;
119     ++$reinitme;
120 }
121 is( stateless(), 43, 'stateless function, first time' );
122 is( stateless(), 44, 'stateless function, second time' );
123
124 # array state vars
125
126 sub stateful_array {
127     state @x;
128     push @x, 'x';
129     return $#x;
130 }
131
132 my $xsize = stateful_array();
133 is( $xsize, 0, 'uninitialized state array' );
134
135 $xsize = stateful_array();
136 is( $xsize, 1, 'uninitialized state array after one iteration' );
137
138 # hash state vars
139
140 sub stateful_hash {
141     state %hx;
142     return $hx{foo}++;
143 }
144
145 my $xhval = stateful_hash();
146 is( $xhval, 0, 'uninitialized state hash' );
147
148 $xhval = stateful_hash();
149 is( $xhval, 1, 'uninitialized state hash after one iteration' );
150
151 # Recursion
152
153 sub 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 }
159 noseworth(2);
160
161 # Assignment return value
162
163 sub pugnax { my $x = state $y = 42; $y++; $x; }
164
165 is( pugnax(), 42, 'scalar state assignment return value' );
166 is( pugnax(), 43, 'scalar state assignment return value' );
167
168
169 #
170 # Test various blocks.
171 #
172 foreach my $x (1 .. 3) {
173     state $y = $x;
174     is ($y, 1, "foreach $x");
175 }
176
177 for (my $x = 1; $x < 4; $x ++) {
178     state $y = $x;
179     is ($y, 1, "for $x");
180 }
181
182 while ($x < 4) {
183     state $y = $x;
184     is ($y, 1, "while $x");
185     $x ++;
186 }
187
188 $x = 1;
189 until ($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 # Goto.
208 #
209 my @simpsons = qw [Homer Marge Bart Lisa Maggie];
210 again:
211     my $next = shift @simpsons;
212     state $simpson = $next;
213     is $simpson, 'Homer', 'goto 1';
214     goto again if @simpsons;
215
216 my $vi;
217 {
218     goto Elvis unless $vi;
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 }
226 my @presidents = qw [Taylor Garfield Ford Arthur Monroe];
227 sub president {
228     my $next = shift @presidents;
229     state $president = $next;
230     goto  &president if @presidents;
231     $president;
232 }
233 my $president_answer = $presidents [0];
234 is president, $president_answer, '&goto';
235
236 my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony];
237 foreach 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 #
250 my @apollo  = qw [Eagle Antares Odyssey Aquarius];
251 my @result1 = map  {state $x = $_;}     @apollo;
252 my @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 #
262 sub reference {\state $x}
263 my $ref1 = reference;
264 my $ref2 = reference;
265 is $ref1, $ref2, "Reference to state variable";
266
267 #
268 # Pre/post increment.
269 #
270 foreach 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 #
281 my $tintin = "Tin-Tin";
282 my @thunderbirds  = qw [Scott Virgel Alan Gordon John];
283 my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx];
284 foreach 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 #
295 # Use with given.
296 #
297 my @spam = qw [spam ham bacon beans];
298 foreach my $spam (@spam) {
299     no warnings 'experimental::smartmatch';
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 }
315
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
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;
333     push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2;
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
343 foreach 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 }
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
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
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
433 # [perl #123029] regression in "state" under PERL_NO_COW
434 sub rt_123029 {
435     state $s;
436     $s = 'foo'x500;
437     my $c = $s;
438     return defined $s;
439 }
440 ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
441
442 # make sure multiconcat doesn't break state
443
444 for (1,2) {
445     state $s = "-$_-";
446     is($s, "-1-", "state with multiconcat pass $_");
447 }
448
449 __DATA__
450 state ($a) = 1;
451 (state $a) = 1;
452 state @a = 1;
453 state (@a) = 1;
454 (state @a) = 1;
455 state %a = ();
456 state (%a) = ();
457 (state %a) = ();
458 state ($a, $b) = ();
459 state ($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) = ();
466 state ($a, undef, $b) = ();