This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to threads::shared 1.41
[perl5.git] / dist / threads-shared / t / clone.t
CommitLineData
373098c0
JH
1use strict;
2use warnings;
3
4BEGIN {
373098c0
JH
5 use Config;
6 if (! $Config{'useithreads'}) {
6c791b15 7 print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
373098c0
JH
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;
2d282673 30 print("1..40\n"); ### Number of tests that will be run ###
373098c0
JH
31};
32
33my $test = 1;
34
35use threads;
36use threads::shared;
37ok($test++, 1, 'Loaded');
38
39### Start of Testing ###
40
41{
373098c0
JH
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{
a469502f
RGS
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');
e4ddb720 130 ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
a469502f
RGS
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');
e4ddb720 135 ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
a469502f
RGS
136 ok($test++, ref($bork) eq 'Bork', 'Object class');
137 })->join();
138
139 $test += 3;
140}
141
142{
373098c0
JH
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
2d282673
JH
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
6c791b15
JH
196exit(0);
197
373098c0 198# EOF