Commit | Line | Data |
373098c0 |
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 | } |
15 | |
16 | use ExtUtils::testlib; |
17 | |
18 | sub ok { |
19 | my ($id, $ok, $name) = @_; |
20 | |
21 | # You have to do it this way or VMS will get confused. |
22 | if ($ok) { |
23 | print("ok $id - $name\n"); |
24 | } else { |
25 | print("not ok $id - $name\n"); |
26 | printf("# Failed test at line %d\n", (caller)[2]); |
27 | } |
28 | |
29 | return ($ok); |
30 | } |
31 | |
32 | BEGIN { |
33 | $| = 1; |
34 | print("1..28\n"); ### Number of tests that will be run ### |
35 | }; |
36 | |
37 | my $test = 1; |
38 | |
39 | use threads; |
40 | use threads::shared; |
41 | ok($test++, 1, 'Loaded'); |
42 | |
43 | ### Start of Testing ### |
44 | |
45 | { |
46 | # Scalar |
47 | my $x = shared_clone(14); |
48 | ok($test++, $x == 14, 'number'); |
49 | |
50 | $x = shared_clone('test'); |
51 | ok($test++, $x eq 'test', 'string'); |
52 | } |
53 | |
54 | { |
55 | my %hsh = ('foo' => 2); |
56 | eval { |
57 | my $x = shared_clone(%hsh); |
58 | }; |
59 | ok($test++, $@ =~ /Usage:/, '1 arg'); |
60 | |
61 | threads->create(sub {})->join(); # Hide leaks, etc. |
62 | } |
63 | |
64 | { |
65 | my $x = 'test'; |
66 | my $foo :shared = shared_clone($x); |
67 | ok($test++, $foo eq 'test', 'cloned string'); |
68 | |
69 | $foo = shared_clone(\$x); |
70 | ok($test++, $$foo eq 'test', 'cloned scalar ref'); |
71 | |
72 | threads->create(sub { |
73 | ok($test++, $$foo eq 'test', 'cloned scalar ref in thread'); |
74 | })->join(); |
75 | |
76 | $test++; |
77 | } |
78 | |
79 | { |
80 | my $foo :shared; |
81 | $foo = shared_clone(\$foo); |
82 | ok($test++, ref($foo) eq 'REF', 'Circular ref typ'); |
83 | ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref'); |
84 | |
85 | threads->create(sub { |
86 | ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread'); |
87 | |
88 | my ($x, $y, $z); |
89 | $x = \$y; $y = \$z; $z = \$x; |
90 | $foo = shared_clone($x); |
91 | })->join(); |
92 | |
93 | $test++; |
94 | |
95 | ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo), |
96 | 'Cloned circular refs from thread'); |
97 | } |
98 | |
99 | { |
100 | my @ary = (qw/foo bar baz/); |
101 | my $ary = shared_clone(\@ary); |
102 | |
103 | ok($test++, $ary->[1] eq 'bar', 'Cloned array'); |
104 | $ary->[1] = 99; |
105 | ok($test++, $ary->[1] == 99, 'Clone mod'); |
106 | ok($test++, $ary[1] eq 'bar', 'Original array'); |
107 | |
108 | threads->create(sub { |
109 | ok($test++, $ary->[1] == 99, 'Clone mod in thread'); |
110 | |
111 | $ary[1] = 'bork'; |
112 | $ary->[1] = 'thread'; |
113 | })->join(); |
114 | |
115 | $test++; |
116 | |
117 | ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread'); |
118 | ok($test++, $ary[1] eq 'bar', 'Original array'); |
119 | } |
120 | |
121 | { |
122 | my $scalar = 'zip'; |
123 | |
124 | my $obj = { |
125 | 'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ], |
126 | 'ref' => \$scalar, |
127 | }; |
128 | |
129 | $obj->{'self'} = $obj; |
130 | |
131 | bless($obj, 'Foo'); |
132 | |
133 | my $copy :shared; |
134 | |
135 | threads->create(sub { |
136 | $copy = shared_clone($obj); |
137 | |
138 | ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread'); |
139 | ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj'); |
140 | ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj'); |
141 | })->join(); |
142 | |
143 | $test += 3; |
144 | |
145 | ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread'); |
146 | ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread'); |
147 | ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj'); |
148 | ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned'); |
149 | ok($test++, ref($copy) eq 'Foo', 'Cloned object class'); |
150 | } |
151 | |
152 | { |
153 | my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]}); |
154 | ok($test++, is_shared($hsh), 'Shared hash ref'); |
155 | ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem'); |
156 | ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure'); |
157 | } |
158 | |
159 | # EOF |