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