Commit | Line | Data |
---|---|---|
952306ac | 1 | #!./perl -w |
ea84231e | 2 | # tests state variables |
952306ac RGS |
3 | |
4 | BEGIN { | |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | require './test.pl'; | |
8 | } | |
9 | ||
10 | use strict; | |
9dcb8368 | 11 | |
c4a33ecd | 12 | plan tests => 137; |
9dcb8368 FC |
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 | ||
642c9703 | 18 | use feature ":5.10"; |
952306ac | 19 | |
952306ac RGS |
20 | |
21 | ok( ! defined state $uninit, q(state vars are undef by default) ); | |
22 | ||
ea84231e RGS |
23 | # basic functionality |
24 | ||
952306ac RGS |
25 | sub 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 | 33 | my ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
34 | is( $x, 0, 'uninitialized state var' ); |
35 | is( $y, 1, 'initialized state var' ); | |
36 | is( $z, 2, 'lexical' ); | |
84f64f45 | 37 | is( $t, 3, 'initialized state var, list syntax' ); |
952306ac | 38 | |
84f64f45 | 39 | ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
40 | is( $x, 1, 'incremented state var' ); |
41 | is( $y, 2, 'incremented state var' ); | |
42 | is( $z, 2, 'reinitialized lexical' ); | |
84f64f45 | 43 | is( $t, 4, 'incremented state var, list syntax' ); |
952306ac | 44 | |
84f64f45 | 45 | ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
46 | is( $x, 2, 'incremented state var' ); |
47 | is( $y, 3, 'incremented state var' ); | |
48 | is( $z, 2, 'reinitialized lexical' ); | |
84f64f45 | 49 | is( $t, 5, 'incremented state var, list syntax' ); |
952306ac | 50 | |
ea84231e RGS |
51 | # in a nested block |
52 | ||
952306ac | 53 | sub 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(); | |
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 | ||
ea84231e RGS |
69 | # in a closure |
70 | ||
952306ac RGS |
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' ); | |
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 | ||
101 | sub 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 | ||
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 | ||
aa2c6373 | 117 | sub stateless { |
b708784e | 118 | state $reinitme = 42; |
aa2c6373 RGS |
119 | ++$reinitme; |
120 | } | |
121 | is( stateless(), 43, 'stateless function, first time' ); | |
c5917253 | 122 | is( stateless(), 44, 'stateless function, second time' ); |
a5911867 RGS |
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' ); | |
a53dbfbb | 150 | |
fda94784 RGS |
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); | |
84f64f45 RGS |
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' ); | |
c5917253 | 166 | is( pugnax(), 43, 'scalar state assignment return value' ); |
642c9703 A |
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 | # Check state $_ | |
208 | # | |
209 | my @stones = qw [fred wilma barny betty]; | |
210 | my $first = $stones [0]; | |
211 | my $First = ucfirst $first; | |
212 | $_ = "bambam"; | |
213 | foreach 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 | } | |
220 | is $_, "bambam", '$_ is still there'; | |
221 | ||
222 | # | |
223 | # Goto. | |
224 | # | |
225 | my @simpsons = qw [Homer Marge Bart Lisa Maggie]; | |
226 | again: | |
227 | my $next = shift @simpsons; | |
228 | state $simpson = $next; | |
229 | is $simpson, 'Homer', 'goto 1'; | |
230 | goto again if @simpsons; | |
231 | ||
642c9703 A |
232 | my $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 | } | |
242 | my @presidents = qw [Taylor Garfield Ford Arthur Monroe]; | |
243 | sub president { | |
244 | my $next = shift @presidents; | |
245 | state $president = $next; | |
246 | goto &president if @presidents; | |
247 | $president; | |
248 | } | |
249 | my $president_answer = $presidents [0]; | |
250 | is president, $president_answer, '&goto'; | |
251 | ||
252 | my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony]; | |
253 | foreach 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 | # | |
266 | my @apollo = qw [Eagle Antares Odyssey Aquarius]; | |
267 | my @result1 = map {state $x = $_;} @apollo; | |
268 | my @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 | # | |
278 | sub reference {\state $x} | |
279 | my $ref1 = reference; | |
280 | my $ref2 = reference; | |
281 | is $ref1, $ref2, "Reference to state variable"; | |
282 | ||
283 | # | |
284 | # Pre/post increment. | |
285 | # | |
286 | foreach 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 | # | |
297 | my $tintin = "Tin-Tin"; | |
298 | my @thunderbirds = qw [Scott Virgel Alan Gordon John]; | |
299 | my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx]; | |
300 | foreach 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 | # | |
313 | my @spam = qw [spam ham bacon beans]; | |
314 | foreach my $spam (@spam) { | |
0f539b13 | 315 | no warnings 'experimental::smartmatch'; |
642c9703 A |
316 | given (state $spam = $spam) { |
317 | when ($spam [0]) {ok 1, "given"} | |
318 | default {ok 0, "given"} | |
319 | } | |
320 | } | |
321 | ||
322 | # | |
323 | # Redefine. | |
324 | # | |
325 | { | |
326 | state $x = "one"; | |
327 | no warnings; | |
328 | state $x = "two"; | |
329 | is $x, "two", "masked" | |
330 | } | |
6dbe9451 | 331 | |
a74073ad DM |
332 | # normally closureless anon subs share a CV and pad. If the anon sub has a |
333 | # state var, this would mean that it is shared. Check that this doesn't | |
334 | # happen | |
335 | ||
336 | { | |
337 | my @f; | |
338 | push @f, sub { state $x; ++$x } for 1..2; | |
339 | $f[0]->() for 1..10; | |
340 | is $f[0]->(), 11; | |
341 | is $f[1]->(), 1; | |
342 | } | |
343 | ||
0d3b281c DM |
344 | # each copy of an anon sub should get its own 'once block' |
345 | ||
346 | { | |
347 | my $x; # used to force a closure | |
348 | my @f; | |
c23d26f1 | 349 | push @f, sub { $x=0; state $s = $_[0]; $s } for 1..2; |
0d3b281c DM |
350 | is $f[0]->(1), 1; |
351 | is $f[0]->(2), 1; | |
352 | is $f[1]->(3), 3; | |
353 | is $f[1]->(4), 3; | |
354 | } | |
355 | ||
356 | ||
357 | ||
358 | ||
6dbe9451 NC |
359 | foreach my $forbidden (<DATA>) { |
360 | chomp $forbidden; | |
361 | no strict 'vars'; | |
362 | eval $forbidden; | |
363 | like $@, qr/Initialization of state variables in list context currently forbidden/, "Currently forbidden: $forbidden"; | |
364 | } | |
d1186544 DM |
365 | |
366 | # [perl #49522] state variable not available | |
367 | ||
368 | { | |
369 | my @warnings; | |
370 | local $SIG{__WARN__} = sub { push @warnings, $_[0] }; | |
371 | ||
372 | eval q{ | |
373 | use warnings; | |
374 | ||
375 | sub f_49522 { | |
376 | state $s = 88; | |
377 | sub g_49522 { $s } | |
378 | sub { $s }; | |
379 | } | |
380 | ||
381 | sub h_49522 { | |
382 | state $t = 99; | |
383 | sub i_49522 { | |
384 | sub { $t }; | |
385 | } | |
386 | } | |
387 | }; | |
388 | is $@, '', "eval f_49522"; | |
389 | # shouldn't be any 'not available' or 'not stay shared' warnings | |
390 | ok !@warnings, "suppress warnings part 1 [@warnings]"; | |
391 | ||
392 | @warnings = (); | |
393 | my $f = f_49522(); | |
394 | is $f->(), 88, "state var closure 1"; | |
395 | is g_49522(), 88, "state var closure 2"; | |
396 | ok !@warnings, "suppress warnings part 2 [@warnings]"; | |
397 | ||
398 | ||
399 | @warnings = (); | |
400 | $f = i_49522(); | |
401 | h_49522(); # initialise $t | |
402 | is $f->(), 99, "state var closure 3"; | |
403 | ok !@warnings, "suppress warnings part 3 [@warnings]"; | |
404 | ||
405 | ||
406 | } | |
407 | ||
408 | ||
1e45dee4 DM |
409 | # [perl #117095] state var initialisation getting skipped |
410 | # the 'if 0' code below causes a call to op_free at compile-time, | |
411 | # which used to inadvertently mark the state var as initialised. | |
412 | ||
413 | { | |
414 | state $f = 1; | |
415 | foo($f) if 0; # this calls op_free on padmy($f) | |
416 | ok(defined $f, 'state init not skipped'); | |
417 | } | |
418 | ||
872fcb08 MH |
419 | # [perl #121134] Make sure padrange doesn't mess with these |
420 | { | |
421 | sub thing { | |
422 | my $expect = shift; | |
423 | my ($x, $y); | |
424 | state $z; | |
425 | ||
426 | is($z, $expect, "State variable is correct"); | |
427 | ||
428 | $z = 5; | |
429 | } | |
430 | ||
431 | thing(undef); | |
432 | thing(5); | |
433 | ||
434 | sub thing2 { | |
435 | my $expect = shift; | |
436 | my $x; | |
437 | my $y; | |
438 | state $z; | |
439 | ||
440 | is($z, $expect, "State variable is correct"); | |
441 | ||
442 | $z = 6; | |
443 | } | |
444 | ||
445 | thing2(undef); | |
446 | thing2(6); | |
447 | } | |
448 | ||
c4a33ecd AC |
449 | # [perl #123029] regression in "state" under PERL_NO_COW |
450 | sub rt_123029 { | |
451 | state $s; | |
452 | $s = 'foo'; | |
453 | my $c = $s; | |
454 | return defined $s; | |
455 | } | |
456 | ok(rt_123029(), "state variables don't surprisingly disappear when accessed"); | |
1e45dee4 | 457 | |
6dbe9451 NC |
458 | __DATA__ |
459 | state ($a) = 1; | |
460 | (state $a) = 1; | |
461 | state @a = 1; | |
462 | state (@a) = 1; | |
463 | (state @a) = 1; | |
464 | state %a = (); | |
465 | state (%a) = (); | |
466 | (state %a) = (); | |
467 | state ($a, $b) = (); | |
468 | state ($a, @b) = (); | |
469 | (state $a, state $b) = (); | |
470 | (state $a, $b) = (); | |
471 | (state $a, my $b) = (); | |
472 | (state $a, state @b) = (); | |
473 | (state $a, local @b) = (); | |
474 | (state $a, undef, state $b) = (); | |
475 | state ($a, undef, $b) = (); |