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; | |
642c9703 | 11 | use feature ":5.10"; |
952306ac | 12 | |
d1186544 | 13 | plan tests => 130; |
952306ac RGS |
14 | |
15 | ok( ! defined state $uninit, q(state vars are undef by default) ); | |
16 | ||
ea84231e RGS |
17 | # basic functionality |
18 | ||
952306ac RGS |
19 | sub 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 | 27 | my ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
28 | is( $x, 0, 'uninitialized state var' ); |
29 | is( $y, 1, 'initialized state var' ); | |
30 | is( $z, 2, 'lexical' ); | |
84f64f45 | 31 | is( $t, 3, 'initialized state var, list syntax' ); |
952306ac | 32 | |
84f64f45 | 33 | ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
34 | is( $x, 1, 'incremented state var' ); |
35 | is( $y, 2, 'incremented state var' ); | |
36 | is( $z, 2, 'reinitialized lexical' ); | |
84f64f45 | 37 | is( $t, 4, 'incremented state var, list syntax' ); |
952306ac | 38 | |
84f64f45 | 39 | ($x, $y, $z, $t) = stateful(); |
952306ac RGS |
40 | is( $x, 2, 'incremented state var' ); |
41 | is( $y, 3, 'incremented state var' ); | |
42 | is( $z, 2, 'reinitialized lexical' ); | |
84f64f45 | 43 | is( $t, 5, 'incremented state var, list syntax' ); |
952306ac | 44 | |
ea84231e RGS |
45 | # in a nested block |
46 | ||
952306ac | 47 | sub 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(); | |
56 | is( $x, 11, 'outer state var' ); | |
57 | is( $y, 13, 'inner state var' ); | |
58 | ||
59 | ($x, $y) = nesting(); | |
60 | is( $x, 12, 'outer state var' ); | |
61 | is( $y, 14, 'inner state var' ); | |
62 | ||
ea84231e RGS |
63 | # in a closure |
64 | ||
952306ac RGS |
65 | sub generator { |
66 | my $outer; | |
67 | # we use $outer to generate a closure | |
68 | sub { ++$outer; ++state $x } | |
69 | } | |
70 | ||
71 | my $f1 = generator(); | |
72 | is( $f1->(), 1, 'generator 1' ); | |
73 | is( $f1->(), 2, 'generator 1' ); | |
74 | my $f2 = generator(); | |
75 | is( $f2->(), 1, 'generator 2' ); | |
76 | is( $f1->(), 3, 'generator 1 again' ); | |
77 | is( $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 | ||
95 | sub 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 | ||
105 | gen_cashier(59)->{add}->(); | |
106 | gen_cashier(17)->{del}->(); | |
107 | is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' ); | |
108 | ||
109 | # stateless assignment to a state variable | |
110 | ||
aa2c6373 | 111 | sub stateless { |
b708784e | 112 | state $reinitme = 42; |
aa2c6373 RGS |
113 | ++$reinitme; |
114 | } | |
115 | is( stateless(), 43, 'stateless function, first time' ); | |
c5917253 | 116 | is( stateless(), 44, 'stateless function, second time' ); |
a5911867 RGS |
117 | |
118 | # array state vars | |
119 | ||
120 | sub stateful_array { | |
121 | state @x; | |
122 | push @x, 'x'; | |
123 | return $#x; | |
124 | } | |
125 | ||
126 | my $xsize = stateful_array(); | |
127 | is( $xsize, 0, 'uninitialized state array' ); | |
128 | ||
129 | $xsize = stateful_array(); | |
130 | is( $xsize, 1, 'uninitialized state array after one iteration' ); | |
131 | ||
132 | # hash state vars | |
133 | ||
134 | sub stateful_hash { | |
135 | state %hx; | |
136 | return $hx{foo}++; | |
137 | } | |
138 | ||
139 | my $xhval = stateful_hash(); | |
140 | is( $xhval, 0, 'uninitialized state hash' ); | |
141 | ||
142 | $xhval = stateful_hash(); | |
143 | is( $xhval, 1, 'uninitialized state hash after one iteration' ); | |
a53dbfbb | 144 | |
fda94784 RGS |
145 | # Recursion |
146 | ||
147 | sub 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 | } | |
153 | noseworth(2); | |
84f64f45 RGS |
154 | |
155 | # Assignment return value | |
156 | ||
157 | sub pugnax { my $x = state $y = 42; $y++; $x; } | |
158 | ||
159 | is( pugnax(), 42, 'scalar state assignment return value' ); | |
c5917253 | 160 | is( pugnax(), 43, 'scalar state assignment return value' ); |
642c9703 A |
161 | |
162 | ||
163 | # | |
164 | # Test various blocks. | |
165 | # | |
166 | foreach my $x (1 .. 3) { | |
167 | state $y = $x; | |
168 | is ($y, 1, "foreach $x"); | |
169 | } | |
170 | ||
171 | for (my $x = 1; $x < 4; $x ++) { | |
172 | state $y = $x; | |
173 | is ($y, 1, "for $x"); | |
174 | } | |
175 | ||
176 | while ($x < 4) { | |
177 | state $y = $x; | |
178 | is ($y, 1, "while $x"); | |
179 | $x ++; | |
180 | } | |
181 | ||
182 | $x = 1; | |
183 | until ($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 | # | |
203 | my @stones = qw [fred wilma barny betty]; | |
204 | my $first = $stones [0]; | |
205 | my $First = ucfirst $first; | |
206 | $_ = "bambam"; | |
207 | foreach my $flint (@stones) { | |
208 | state $_ = $flint; | |
209 | is $_, $first, 'state $_'; | |
210 | ok /$first/, '/.../ binds to $_'; | |
211 | is ucfirst, $First, '$_ default argument'; | |
212 | } | |
213 | is $_, "bambam", '$_ is still there'; | |
214 | ||
215 | # | |
216 | # Goto. | |
217 | # | |
218 | my @simpsons = qw [Homer Marge Bart Lisa Maggie]; | |
219 | again: | |
220 | my $next = shift @simpsons; | |
221 | state $simpson = $next; | |
222 | is $simpson, 'Homer', 'goto 1'; | |
223 | goto again if @simpsons; | |
224 | ||
225 | goto Elvis; | |
226 | my $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 | } | |
235 | my @presidents = qw [Taylor Garfield Ford Arthur Monroe]; | |
236 | sub president { | |
237 | my $next = shift @presidents; | |
238 | state $president = $next; | |
239 | goto &president if @presidents; | |
240 | $president; | |
241 | } | |
242 | my $president_answer = $presidents [0]; | |
243 | is president, $president_answer, '&goto'; | |
244 | ||
245 | my @flowers = qw [Bluebonnet Goldenrod Hawthorn Peony]; | |
246 | foreach 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 | # | |
259 | my @apollo = qw [Eagle Antares Odyssey Aquarius]; | |
260 | my @result1 = map {state $x = $_;} @apollo; | |
261 | my @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 | # | |
271 | sub reference {\state $x} | |
272 | my $ref1 = reference; | |
273 | my $ref2 = reference; | |
274 | is $ref1, $ref2, "Reference to state variable"; | |
275 | ||
276 | # | |
277 | # Pre/post increment. | |
278 | # | |
279 | foreach 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 | # | |
290 | my $tintin = "Tin-Tin"; | |
291 | my @thunderbirds = qw [Scott Virgel Alan Gordon John]; | |
292 | my @thunderbirds2 = qw [xcott xxott xxxtt xxxxt xxxxx]; | |
293 | foreach 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 | # | |
306 | my @spam = qw [spam ham bacon beans]; | |
307 | foreach 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 |
351 | foreach 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__ |
402 | state ($a) = 1; | |
403 | (state $a) = 1; | |
404 | state @a = 1; | |
405 | state (@a) = 1; | |
406 | (state @a) = 1; | |
407 | state %a = (); | |
408 | state (%a) = (); | |
409 | (state %a) = (); | |
410 | state ($a, $b) = (); | |
411 | state ($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) = (); | |
418 | state ($a, undef, $b) = (); |