threads::shared TODO test for outstanding bug
[perl.git] / ext / threads / shared / t / object.t
1 use strict;
2 use warnings;
3
4 BEGIN {
5     if ($ENV{'PERL_CORE'}){
6         chdir 't';
7         unshift @INC, '../lib';
8     }
9     use Config;
10     if (! $Config{'useithreads'}) {
11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12         exit(0);
13     }
14     if ($] < 5.010) {
15         print("1..0 # Skip: Needs Perl 5.10.0 or later\n");
16         exit(0);
17     }
18 }
19
20 use ExtUtils::testlib;
21
22 BEGIN {
23     $| = 1;
24     print("1..28\n");   ### Number of tests that will be run ###
25 };
26
27 use threads;
28 use threads::shared;
29
30 my $TEST;
31 BEGIN {
32     share($TEST);
33     $TEST = 1;
34 }
35
36 sub ok {
37     my ($ok, $name) = @_;
38
39     lock($TEST);
40     my $id = $TEST++;
41
42     # You have to do it this way or VMS will get confused.
43     if ($ok) {
44         print("ok $id - $name\n");
45     } else {
46         print("not ok $id - $name\n");
47         printf("# Failed test at line %d\n", (caller)[2]);
48     }
49
50     return ($ok);
51 }
52
53 ok(1, 'Loaded');
54
55 ### Start of Testing ###
56
57 { package Jar;
58     my @jar :shared;
59
60     sub new
61     {
62         bless(&threads::shared::share({}), shift);
63     }
64
65     sub store
66     {
67         my ($self, $cookie) = @_;
68         push(@jar, $cookie);
69         return $jar[-1];        # Results in destruction of proxy object
70     }
71
72     sub peek
73     {
74         return $jar[-1];
75     }
76
77     sub fetch
78     {
79         pop(@jar);
80     }
81 }
82
83 { package Cookie;
84
85     sub new
86     {
87         my $self = bless(&threads::shared::share({}), shift);
88         $self->{'type'} = shift;
89         return $self;
90     }
91
92     sub DESTROY
93     {
94         delete(shift->{'type'});
95     }
96 }
97
98 my $C1 = 'chocolate chip';
99 my $C2 = 'oatmeal raisin';
100 my $C3 = 'vanilla wafer';
101
102 my $cookie = Cookie->new($C1);
103 ok($cookie->{'type'} eq $C1, 'Have cookie');
104
105 my $jar = Jar->new();
106 $jar->store($cookie);
107
108 ok($cookie->{'type'}      eq $C1, 'Still have cookie');
109 ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
110 ok($cookie->{'type'}      eq $C1, 'Still have cookie');
111
112 threads->create(sub {
113     ok($cookie->{'type'}      eq $C1, 'Have cookie in thread');
114     ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
115     ok($cookie->{'type'}      eq $C1, 'Still have cookie in thread');
116
117     $jar->store(Cookie->new($C2));
118     ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
119 })->join();
120
121 ok($cookie->{'type'}      eq $C1, 'Still have original cookie after thread');
122 ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
123
124 $cookie = $jar->fetch();
125 ok($cookie->{'type'}      eq $C2, 'Fetched cookie from jar');
126 ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
127
128 $cookie = $jar->fetch();
129 ok($cookie->{'type'}      eq $C1, 'Fetched cookie from jar');
130 undef($cookie);
131
132 share($cookie);
133 $cookie = $jar->store(Cookie->new($C3));
134 ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
135 ok($cookie->{'type'}      eq $C3, 'Have cookie');
136
137 threads->create(sub {
138     ok($cookie->{'type'}      eq $C3, 'Have cookie in thread');
139     $cookie = Cookie->new($C1);
140     ok($cookie->{'type'}      eq $C1, 'Change cookie in thread');
141     ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
142 })->join();
143
144 ok($cookie->{'type'}      eq $C1, 'Have changed cookie after thread');
145 ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
146 undef($cookie);
147 ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
148 $cookie = $jar->fetch();
149 ok($cookie->{'type'}      eq $C3, 'Fetched cookie from jar');
150
151 { package Foo;
152
153     my $ID = 1;
154     threads::shared::share($ID);
155
156     sub new
157     {
158         # Anonymous scalar with an internal ID
159         my $obj = \do{ my $scalar = $ID++; };
160         threads::shared::share($obj);   # Make it shared
161         return (bless($obj, 'Foo'));    # Make it an object
162     }
163 }
164
165 my $obj :shared;
166 $obj = Foo->new();
167 ok($$obj == 1, "Main: Object ID $$obj");
168
169 threads->create( sub {
170         ok($$obj == 1, "Thread: Object ID $$obj");
171
172         $$obj = 10;
173         ok($$obj == 10, "Thread: Changed object ID $$obj");
174
175         $obj = Foo->new();
176         ok($$obj == 2, "Thread: New object ID $$obj");
177     } )->join();
178
179 ok($$obj == 2, "Main: New object ID $$obj  # TODO - should be 2");
180
181 # EOF