1use strict;
2use warnings;
3
4BEGIN {
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
16use ExtUtils::testlib;
17
18BEGIN {
19    $| = 1;
20    print("1..28\n");   ### Number of tests that will be run ###
21};
22
23use threads;
24use threads::shared;
25
26my $TEST;
27BEGIN {
28    share($TEST);
29    $TEST = 1;
30}
31
32sub 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
49ok(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
94my $C1 = 'chocolate chip';
95my $C2 = 'oatmeal raisin';
96my $C3 = 'vanilla wafer';
97
98my $cookie = Cookie->new($C1);
99ok($cookie->{'type'} eq $C1, 'Have cookie');
100
101my $jar = Jar->new();
102$jar->store($cookie);
103
104ok($cookie->{'type'}      eq $C1, 'Still have cookie');
105ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
106ok($cookie->{'type'}      eq $C1, 'Still have cookie');
107
108threads->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
117ok($cookie->{'type'}      eq $C1, 'Still have original cookie after thread');
118ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
119
120$cookie = $jar->fetch();
121ok($cookie->{'type'}      eq $C2, 'Fetched cookie from jar');
122ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
123
124$cookie = $jar->fetch();
125ok($cookie->{'type'}      eq $C1, 'Fetched cookie from jar');
126undef($cookie);
127
128share($cookie);
129$cookie = $jar->store(Cookie->new($C3));
130ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
131ok($cookie->{'type'}      eq $C3, 'Have cookie');
132
133threads->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
140ok($cookie->{'type'}      eq $C1, 'Have changed cookie after thread');
141ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
142undef($cookie);
143ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
144$cookie = $jar->fetch();
145ok($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
161my $obj :shared;
162$obj = Foo->new();
163ok($$obj == 1, "Main: Object ID $$obj");
164
165threads->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
175ok($$obj == 2, "Main: New object ID $$obj  # TODO - should be 2");
176
177exit(0);
178
179# EOF
180