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
14BEGIN {
15    $| = 1;
16    print("1..226\n");    ### Number of tests that will be run ###
17}
18
19use threads;
20use threads::shared;
21use Scalar::Util qw(dualvar);
22
23my $TEST = 1;
24
25sub ok {
26    my ($ok, $name) = @_;
27
28    # You have to do it this way or VMS will get confused.
29    if ($ok) {
30        print("ok $TEST - $name\n");
31    } else {
32        print("not ok $TEST - $name\n");
33        printf("# Failed test at line %d\n", (caller(1))[2]);
34    }
35
36    $TEST++;
37}
38
39sub ok_iv
40{
41    my ($var, $iv) = @_;
42    ok($var == $iv, 'IV number preserved');
43    ok($var eq $iv, 'String preserved');
44}
45
46sub ok_nv
47{
48    my ($var, $nv) = @_;
49    ok($var == $nv, 'NV number preserved');
50    ok($var eq $nv, 'String preserved');
51}
52
53sub ok_uv
54{
55    my ($var, $uv) = @_;
56    ok($var == $uv, 'UV number preserved');
57    ok($var > 0, 'UV number preserved');
58    ok($var eq $uv, 'String preserved');
59}
60
61### Start of Testing ###
62
63my $iv = dualvar(42, 'Fourty-Two');
64my $nv = dualvar(3.14, 'PI');
65my $bits = ($Config{'use64bitint'}) ? 63 : 31;
66my $uv = dualvar(1<<$bits, 'Large unsigned int');
67
68print("# Shared scalar assignment using shared_clone()\n");
69
70my $siv :shared = shared_clone($iv);
71my $snv :shared = shared_clone($nv);
72my $suv :shared = shared_clone($uv);
73
74ok_iv($siv, $iv);
75ok_nv($snv, $nv);
76ok_uv($suv, $uv);
77
78{
79    print("# Shared array initialization\n");
80
81    my @ary :shared = ($iv, $nv, $uv);
82
83    ok_iv($ary[0], $iv);
84    ok_nv($ary[1], $nv);
85    ok_uv($ary[2], $uv);
86}
87
88{
89    print("# Shared array list assignment\n");
90
91    my @ary :shared;
92    @ary = ($iv, $nv, $uv);
93
94    ok_iv($ary[0], $iv);
95    ok_nv($ary[1], $nv);
96    ok_uv($ary[2], $uv);
97}
98
99{
100    print("# Shared array element assignment\n");
101
102    my @ary :shared;
103    $ary[0] = $iv;
104    $ary[1] = $nv;
105    $ary[2] = $uv;
106
107    ok_iv($ary[0], $iv);
108    ok_nv($ary[1], $nv);
109    ok_uv($ary[2], $uv);
110}
111
112{
113    print("# Shared array initialization - shared scalars\n");
114
115    my @ary :shared = ($siv, $snv, $suv);
116
117    ok_iv($ary[0], $iv);
118    ok_nv($ary[1], $nv);
119    ok_uv($ary[2], $uv);
120}
121
122{
123    print("# Shared array list assignment - shared scalars\n");
124
125    my @ary :shared;
126    @ary = ($siv, $snv, $suv);
127
128    ok_iv($ary[0], $iv);
129    ok_nv($ary[1], $nv);
130    ok_uv($ary[2], $uv);
131}
132
133{
134    print("# Shared array element assignment - shared scalars\n");
135
136    my @ary :shared;
137    $ary[0] = $siv;
138    $ary[1] = $snv;
139    $ary[2] = $suv;
140
141    ok_iv($ary[0], $iv);
142    ok_nv($ary[1], $nv);
143    ok_uv($ary[2], $uv);
144}
145
146{
147    print("# Shared hash initialization\n");
148
149    my %hsh :shared = (
150        'iv' => $iv,
151        'nv' => $nv,
152        'uv' => $uv,
153    );
154
155    ok_iv($hsh{'iv'}, $iv);
156    ok_nv($hsh{'nv'}, $nv);
157    ok_uv($hsh{'uv'}, $uv);
158}
159
160{
161    print("# Shared hash assignment\n");
162
163    my %hsh :shared;
164    %hsh = (
165        'iv' => $iv,
166        'nv' => $nv,
167        'uv' => $uv,
168    );
169
170    ok_iv($hsh{'iv'}, $iv);
171    ok_nv($hsh{'nv'}, $nv);
172    ok_uv($hsh{'uv'}, $uv);
173}
174
175{
176    print("# Shared hash element assignment\n");
177
178    my %hsh :shared;
179    $hsh{'iv'} = $iv;
180    $hsh{'nv'} = $nv;
181    $hsh{'uv'} = $uv;
182
183    ok_iv($hsh{'iv'}, $iv);
184    ok_nv($hsh{'nv'}, $nv);
185    ok_uv($hsh{'uv'}, $uv);
186}
187
188{
189    print("# Shared hash initialization - shared scalars\n");
190
191    my %hsh :shared = (
192        'iv' => $siv,
193        'nv' => $snv,
194        'uv' => $suv,
195    );
196
197    ok_iv($hsh{'iv'}, $iv);
198    ok_nv($hsh{'nv'}, $nv);
199    ok_uv($hsh{'uv'}, $uv);
200}
201
202{
203    print("# Shared hash assignment - shared scalars\n");
204
205    my %hsh :shared;
206    %hsh = (
207        'iv' => $siv,
208        'nv' => $snv,
209        'uv' => $suv,
210    );
211
212    ok_iv($hsh{'iv'}, $iv);
213    ok_nv($hsh{'nv'}, $nv);
214    ok_uv($hsh{'uv'}, $uv);
215}
216
217{
218    print("# Shared hash element assignment - shared scalars\n");
219
220    my %hsh :shared;
221    $hsh{'iv'} = $siv;
222    $hsh{'nv'} = $snv;
223    $hsh{'uv'} = $suv;
224
225    ok_iv($hsh{'iv'}, $iv);
226    ok_nv($hsh{'nv'}, $nv);
227    ok_uv($hsh{'uv'}, $uv);
228}
229
230{
231    print("# Shared array push\n");
232
233    my @ary :shared;
234    push(@ary, $iv, $nv, $uv);
235
236    ok_iv($ary[0], $iv);
237    ok_nv($ary[1], $nv);
238    ok_uv($ary[2], $uv);
239
240    print("# Shared array pop\n");
241
242    my $xuv = pop(@ary);
243    my $xnv = pop(@ary);
244    my $xiv = pop(@ary);
245
246    ok_iv($xiv, $iv);
247    ok_nv($xnv, $nv);
248    ok_uv($xuv, $uv);
249
250    print("# Shared array unshift\n");
251
252    unshift(@ary, $iv, $nv, $uv);
253
254    ok_iv($ary[0], $iv);
255    ok_nv($ary[1], $nv);
256    ok_uv($ary[2], $uv);
257
258    print("# Shared array shift\n");
259
260    $xiv = shift(@ary);
261    $xnv = shift(@ary);
262    $xuv = shift(@ary);
263
264    ok_iv($xiv, $iv);
265    ok_nv($xnv, $nv);
266    ok_uv($xuv, $uv);
267}
268
269{
270    print("# Shared array push - shared scalars\n");
271
272    my @ary :shared;
273    push(@ary, $siv, $snv, $suv);
274
275    ok_iv($ary[0], $iv);
276    ok_nv($ary[1], $nv);
277    ok_uv($ary[2], $uv);
278
279    print("# Shared array pop - shared scalars\n");
280
281    my $xuv = pop(@ary);
282    my $xnv = pop(@ary);
283    my $xiv = pop(@ary);
284
285    ok_iv($xiv, $iv);
286    ok_nv($xnv, $nv);
287    ok_uv($xuv, $uv);
288
289    print("# Shared array unshift - shared scalars\n");
290
291    unshift(@ary, $siv, $snv, $suv);
292
293    ok_iv($ary[0], $iv);
294    ok_nv($ary[1], $nv);
295    ok_uv($ary[2], $uv);
296
297    print("# Shared array shift - shared scalars\n");
298
299    $xiv = shift(@ary);
300    $xnv = shift(@ary);
301    $xuv = shift(@ary);
302
303    ok_iv($xiv, $iv);
304    ok_nv($xnv, $nv);
305    ok_uv($xuv, $uv);
306}
307
308{
309    print("# Shared hash delete\n");
310
311    my %hsh :shared = (
312        'iv' => $iv,
313        'nv' => $nv,
314        'uv' => $uv,
315    );
316
317    ok_iv(delete($hsh{'iv'}), $iv);
318    ok_nv(delete($hsh{'nv'}), $nv);
319    ok_uv(delete($hsh{'uv'}), $uv);
320}
321
322{
323    print("# Shared hash delete - shared scalars\n");
324
325    my %hsh :shared = (
326        'iv' => $siv,
327        'nv' => $snv,
328        'uv' => $suv,
329    );
330
331    ok_iv(delete($hsh{'iv'}), $iv);
332    ok_nv(delete($hsh{'nv'}), $nv);
333    ok_uv(delete($hsh{'uv'}), $uv);
334}
335
336{
337    print("# Shared array copy to non-shared array\n");
338
339    my @ary :shared = ($iv, $nv, $uv);
340    my @nsa = @ary;
341
342    ok_iv($nsa[0], $iv);
343    ok_nv($nsa[1], $nv);
344    ok_uv($nsa[2], $uv);
345
346    print("# Shared array copy using shared_clone()\n");
347
348    my $copy :shared = shared_clone(\@nsa);
349
350    ok_iv($$copy[0], $iv);
351    ok_nv($$copy[1], $nv);
352    ok_uv($$copy[2], $uv);
353}
354
355{
356    print("# Shared array copy to non-shared array - shared scalars\n");
357
358    my @ary :shared = ($siv, $snv, $suv);
359    my @nsa = @ary;
360
361    ok_iv($nsa[0], $iv);
362    ok_nv($nsa[1], $nv);
363    ok_uv($nsa[2], $uv);
364
365    print("# Shared array copy using shared_clone()\n");
366
367    my $copy :shared = shared_clone(\@nsa);
368
369    ok_iv($$copy[0], $iv);
370    ok_nv($$copy[1], $nv);
371    ok_uv($$copy[2], $uv);
372}
373
374{
375    print("# Shared hash copy to non-shared hash\n");
376
377    my %hsh :shared = (
378        'iv' => $iv,
379        'nv' => $nv,
380        'uv' => $uv,
381    );
382    my %nsh = %hsh;
383
384    ok_iv($nsh{'iv'}, $iv);
385    ok_nv($nsh{'nv'}, $nv);
386    ok_uv($nsh{'uv'}, $uv);
387
388    print("# Shared hash copy using shared_clone()\n");
389
390    my $copy :shared = shared_clone(\%nsh);
391
392    ok_iv($$copy{'iv'}, $iv);
393    ok_nv($$copy{'nv'}, $nv);
394    ok_uv($$copy{'uv'}, $uv);
395}
396
397{
398    print("# Shared hash copy to non-shared hash - shared scalars\n");
399
400    my %hsh :shared = (
401        'iv' => $siv,
402        'nv' => $snv,
403        'uv' => $suv,
404    );
405    my %nsh = %hsh;
406
407    ok_iv($nsh{'iv'}, $iv);
408    ok_nv($nsh{'nv'}, $nv);
409    ok_uv($nsh{'uv'}, $uv);
410
411    print("# Shared hash copy using shared_clone()\n");
412
413    my $copy :shared = shared_clone(\%nsh);
414
415    ok_iv($$copy{'iv'}, $iv);
416    ok_nv($$copy{'nv'}, $nv);
417    ok_uv($$copy{'uv'}, $uv);
418}
419
420print("# Mix it up with a thread\n");
421my @ary :shared;
422my %hsh :shared;
423
424threads->create(sub {
425                    @ary = ($siv);
426                    push(@ary, $snv);
427
428                    %hsh = ( 'nv' => $ary[1] );
429                    $hsh{'iv'} = $ary[0];
430                    $hsh{'uv'} = $suv;
431
432                    $ary[2] = $hsh{'uv'};
433                })->join();
434
435ok_iv($hsh{'iv'}, $ary[0]);
436ok_nv($hsh{'nv'}, $ary[1]);
437ok_uv($hsh{'uv'}, $ary[2]);
438
439# $! behaves like a dualvar, but is really implemented as a tied SV.
440# As a result sharing $! directly only propagates the string value.
441# However, we can create a dualvar from it.
442print("# Errno\n");
443$! = 1;
444my $ss :shared = dualvar($!,$!);
445ok_iv($ss, $!);
446
447exit(0);
448