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