Fixes for the test suite on OS/2

[p5sagit/p5-mst-13.2.git] / t / op / state.t

diff --git a/t/op/state.t b/t/op/state.t
index 3b68879..92b4dfc 100644 (file)
--- a/t/op/state.t
+++ b/t/op/state.t
@@ -1,4 +1,5 @@
 #!./perl -w
+# tests state variables
 
 BEGIN {
     chdir 't' if -d 't';
@@ -9,10 +10,12 @@ BEGIN {
 use strict;
 use feature "state";
 
-plan tests => 19;
+plan tests => 34;
 
 ok( ! defined state $uninit, q(state vars are undef by default) );
 
+# basic functionality
+
 sub stateful {
     state $x;
     state $y = 1;
@@ -35,6 +38,8 @@ is( $x, 2, 'incremented state var' );
 is( $y, 3, 'incremented state var' );
 is( $z, 2, 'reinitialized lexical' );
 
+# in a nested block
+
 sub nesting {
     state $foo = 10;
     my $t;
@@ -51,6 +56,8 @@ is( $y, 13, 'inner state var' );
 is( $x, 12, 'outer state var' );
 is( $y, 14, 'inner state var' );
 
+# in a closure
+
 sub generator {
     my $outer;
     # we use $outer to generate a closure
@@ -64,3 +71,97 @@ my $f2 = generator();
 is( $f2->(), 1, 'generator 2' );
 is( $f1->(), 3, 'generator 1 again' );
 is( $f2->(), 2, 'generator 2 once more' );
+
+# with ties
+{
+    package countfetches;
+    our $fetchcount = 0;
+    sub TIESCALAR {bless {}};
+    sub FETCH { ++$fetchcount; 18 };
+    tie my $y, "countfetches";
+    sub foo { state $x = $y; $x++ }
+    ::is( foo(), 18, "initialisation with tied variable" );
+    ::is( foo(), 19, "increments correctly" );
+    ::is( foo(), 20, "increments correctly, twice" );
+    ::is( $fetchcount, 1, "fetch only called once" );
+}
+
+# state variables are shared among closures
+
+sub gen_cashier {
+    my $amount = shift;
+    state $cash_in_store = 0;
+    return {
+       add => sub { $cash_in_store += $amount },
+       del => sub { $cash_in_store -= $amount },
+       bal => sub { $cash_in_store },
+    };
+}
+
+gen_cashier(59)->{add}->();
+gen_cashier(17)->{del}->();
+is( gen_cashier()->{bal}->(), 42, '$42 in my drawer' );
+
+# stateless assignment to a state variable
+
+sub stateless {
+    no warnings 'misc';
+    (state $reinitme, my $foo) = (42, 'bar');
+    ++$reinitme;
+}
+is( stateless(), 43, 'stateless function, first time' );
+is( stateless(), 43, 'stateless function, second time' );
+
+# array state vars
+
+sub stateful_array {
+    state @x;
+    push @x, 'x';
+    return $#x;
+}
+
+my $xsize = stateful_array();
+is( $xsize, 0, 'uninitialized state array' );
+
+$xsize = stateful_array();
+is( $xsize, 1, 'uninitialized state array after one iteration' );
+
+# hash state vars
+
+sub stateful_hash {
+    state %hx;
+    return $hx{foo}++;
+}
+
+my $xhval = stateful_hash();
+is( $xhval, 0, 'uninitialized state hash' );
+
+$xhval = stateful_hash();
+is( $xhval, 1, 'uninitialized state hash after one iteration' );
+
+# state declaration with a list
+
+sub statelist {
+    # note that this should be a state assignment, while (state $lager, state $stout) shouldn't
+    state($lager, $stout) = (11, 22);
+    $lager++;
+    $stout++;
+    "$lager/$stout";
+}
+
+my $ls = statelist();
+is($ls, "12/23", 'list assignment to state scalars');
+$ls = statelist();
+is($ls, "13/24", 'list assignment to state scalars');
+
+sub statelist2 {
+    state($sherry, $bourbon) = (1 .. 2);
+    $sherry++;
+    $bourbon++;
+    "$sherry/$bourbon";
+}
+
+$ls = statelist2();
+is($ls, "2/3", 'list assignment to state scalars');
+$ls = statelist2();
+is($ls, "3/4", 'list assignment to state scalars');