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}
11
12use ExtUtils::testlib;
13
14sub ok {
15    my ($id, $ok, $name) = @_;
16
17    # You have to do it this way or VMS will get confused.
18    if ($ok) {
19        print("ok $id - $name\n");
20    } else {
21        print("not ok $id - $name\n");
22        printf("# Failed test at line %d\n", (caller)[2]);
23    }
24
25    return ($ok);
26}
27
28BEGIN {
29    $| = 1;
30    print("1..40\n");   ### Number of tests that will be run ###
31};
32
33my $test = 1;
34
35use threads;
36use threads::shared;
37ok($test++, 1, 'Loaded');
38
39### Start of Testing ###
40
41{
42    my $x = shared_clone(14);
43    ok($test++, $x == 14, 'number');
44
45    $x = shared_clone('test');
46    ok($test++, $x eq 'test', 'string');
47}
48
49{
50    my %hsh = ('foo' => 2);
51    eval {
52        my $x = shared_clone(%hsh);
53    };
54    ok($test++, $@ =~ /Usage:/, '1 arg');
55
56    threads->create(sub {})->join();  # Hide leaks, etc.
57}
58
59{
60    my $x = 'test';
61    my $foo :shared = shared_clone($x);
62    ok($test++, $foo eq 'test', 'cloned string');
63
64    $foo = shared_clone(\$x);
65    ok($test++, $$foo eq 'test', 'cloned scalar ref');
66
67    threads->create(sub {
68        ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
69    })->join();
70
71    $test++;
72}
73
74{
75    my $foo :shared;
76    $foo = shared_clone(\$foo);
77    ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
78    ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
79
80    threads->create(sub {
81        ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
82
83        my ($x, $y, $z);
84        $x = \$y; $y = \$z; $z = \$x;
85        $foo = shared_clone($x);
86    })->join();
87
88    $test++;
89
90    ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
91                    'Cloned circular refs from thread');
92}
93
94{
95    my @ary = (qw/foo bar baz/);
96    my $ary = shared_clone(\@ary);
97
98    ok($test++, $ary->[1] eq 'bar', 'Cloned array');
99    $ary->[1] = 99;
100    ok($test++, $ary->[1] == 99, 'Clone mod');
101    ok($test++, $ary[1] eq 'bar', 'Original array');
102
103    threads->create(sub {
104        ok($test++, $ary->[1] == 99, 'Clone mod in thread');
105
106        $ary[1] = 'bork';
107        $ary->[1] = 'thread';
108    })->join();
109
110    $test++;
111
112    ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
113    ok($test++, $ary[1] eq 'bar', 'Original array');
114}
115
116{
117    my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
118    ok($test++, is_shared($hsh), 'Shared hash ref');
119    ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
120    ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
121}
122
123{
124    my $obj = \do { my $bork = 99; };
125    bless($obj, 'Bork');
126    Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
127
128    my $bork = shared_clone($obj);
129    ok($test++, $$bork == 99, 'cloned scalar ref object');
130    ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
131    ok($test++, ref($bork) eq 'Bork', 'Object class');
132
133    threads->create(sub {
134        ok($test++, $$bork == 99, 'cloned scalar ref object in thread');
135        ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
136        ok($test++, ref($bork) eq 'Bork', 'Object class');
137    })->join();
138
139    $test += 3;
140}
141
142{
143    my $scalar = 'zip';
144
145    my $obj = {
146        'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
147        'ref' => \$scalar,
148    };
149
150    $obj->{'self'} = $obj;
151
152    bless($obj, 'Foo');
153
154    my $copy :shared;
155
156    threads->create(sub {
157        $copy = shared_clone($obj);
158
159        ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
160        ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
161        ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
162    })->join();
163
164    $test += 3;
165
166    ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
167    ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
168    ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
169    ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
170    ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
171}
172
173{
174    my $foo = \*STDIN;
175    my $copy :shared;
176    eval {
177        $copy = shared_clone($foo);
178    };
179    ok($test++, $@ =~ /Unsupported/, 'Cannot clone GLOB - fatal');
180    ok($test++, ! defined($copy), 'Nothing cloned');
181
182    $threads::shared::clone_warn = 1;
183    my $warn;
184    $SIG{'__WARN__'} = sub { $warn = shift; };
185    $copy = shared_clone($foo);
186    ok($test++, $warn =~ /Unsupported/, 'Cannot clone GLOB - warning');
187    ok($test++, ! defined($copy), 'Nothing cloned');
188
189    $threads::shared::clone_warn = 0;
190    undef($warn);
191    $copy = shared_clone($foo);
192    ok($test++, ! defined($warn), 'Cannot clone GLOB - silent');
193    ok($test++, ! defined($copy), 'Nothing cloned');
194}
195
196exit(0);
197
198# EOF
199