This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make 'state $$' etc report 'Can't use global $$ in "state"' (not "my")
[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
642c9703 13plan tests => 108;
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#
304# List context reassigns, but scalar doesn't.
305#
306my @swords = qw [Stormbringer Szczerbiec Grimtooth Corrougue];
307foreach my $sword (@swords) {
308 state ($s1) = state $s2 = $sword;
309 is $s1, $swords [0], 'mixed context';
310 is $s2, $swords [0], 'mixed context';
311}
312
313
314#
315# Use with given.
316#
317my @spam = qw [spam ham bacon beans];
318foreach my $spam (@spam) {
319 given (state $spam = $spam) {
320 when ($spam [0]) {ok 1, "given"}
321 default {ok 0, "given"}
322 }
323}
324
325#
326# Redefine.
327#
328{
329 state $x = "one";
330 no warnings;
331 state $x = "two";
332 is $x, "two", "masked"
333}