Commit | Line | Data |
7473853a |
1 | use strict; |
13c1b207 |
2 | use warnings; |
3 | |
aaf3876d |
4 | BEGIN { |
7473853a |
5 | if ($ENV{'PERL_CORE'}){ |
6 | chdir 't'; |
7 | unshift @INC, '../lib'; |
8 | } |
9 | use Config; |
10 | if (! $Config{'useithreads'}) { |
6c791b15 |
11 | print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); |
7473853a |
12 | exit(0); |
aaf3876d |
13 | } |
14 | } |
15 | |
7473853a |
16 | use ExtUtils::testlib; |
aaf3876d |
17 | |
18 | sub ok { |
19 | my ($id, $ok, $name) = @_; |
20 | |
21 | # You have to do it this way or VMS will get confused. |
7473853a |
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 | } |
aaf3876d |
28 | |
7473853a |
29 | return ($ok); |
aaf3876d |
30 | } |
31 | |
7473853a |
32 | BEGIN { |
33 | $| = 1; |
34 | print("1..44\n"); ### Number of tests that will be run ### |
35 | }; |
aaf3876d |
36 | |
aaf3876d |
37 | use threads; |
38 | use threads::shared; |
7473853a |
39 | ok(1, 1, 'Loaded'); |
40 | |
41 | ### Start of Testing ### |
42 | |
aaf3876d |
43 | my @foo; |
44 | share(@foo); |
45 | ok(2,1,"shared \@foo"); |
46 | $foo[0] = "hi"; |
47 | ok(3, $foo[0] eq 'hi', "Check assignment works"); |
48 | $foo[0] = "bar"; |
49 | ok(4, $foo[0] eq 'bar', "Check overwriting works"); |
13c1b207 |
50 | ok(5, !defined $foo[1], "Check undef value"); |
aaf3876d |
51 | $foo[2] = "test"; |
52 | ok(6, $foo[2] eq "test", "Check extending the array works"); |
13c1b207 |
53 | ok(7, !defined $foo[1], "Check undef value again"); |
aaf3876d |
54 | ok(8, scalar(@foo) == 3, "Check the length of the array"); |
55 | ok(9,$#foo == 2, "Check last element of array"); |
56 | threads->create(sub { $foo[0] = "thread1" })->join; |
57 | ok(10, $foo[0] eq "thread1", "Check that a value can be changed in another thread"); |
58 | push(@foo, "another value"); |
59 | ok(11, $foo[3] eq "another value", "Check that push works"); |
60 | push(@foo, 1,2,3); |
61 | ok(12, $foo[-1] == 3, "More push"); |
62 | ok(13, $foo[-2] == 2, "More push"); |
63 | ok(14, $foo[4] == 1, "More push"); |
64 | threads->create(sub { push @foo, "thread2" })->join(); |
65 | ok(15, $foo[7] eq "thread2", "Check push in another thread"); |
66 | unshift(@foo, "start"); |
67 | ok(16, $foo[0] eq "start", "Check unshift"); |
68 | unshift(@foo, 1,2,3); |
69 | ok(17, $foo[0] == 1, "Check multiple unshift"); |
70 | ok(18, $foo[1] == 2, "Check multiple unshift"); |
71 | ok(19, $foo[2] == 3, "Check multiple unshift"); |
72 | threads->create(sub { unshift @foo, "thread3" })->join(); |
73 | ok(20, $foo[0] eq "thread3", "Check unshift from another thread"); |
74 | my $var = pop(@foo); |
75 | ok(21, $var eq "thread2", "Check pop"); |
76 | threads->create(sub { my $foo = pop @foo; ok(22, $foo == 3, "Check pop works in a thread")})->join(); |
77 | $var = pop(@foo); |
78 | ok(23, $var == 2, "Check pop after thread"); |
79 | $var = shift(@foo); |
80 | ok(24, $var eq "thread3", "Check shift"); |
81 | threads->create(sub { my $foo = shift @foo; ok(25, $foo == 1, "Check shift works in a thread"); |
82 | })->join(); |
83 | $var = shift(@foo); |
84 | ok(26, $var == 2, "Check shift after thread"); |
85 | { |
86 | my @foo2; |
87 | share @foo2; |
88 | my $empty = shift @foo2; |
13c1b207 |
89 | ok(27, !defined $empty, "Check shift on empty array"); |
aaf3876d |
90 | $empty = pop @foo2; |
13c1b207 |
91 | ok(28, !defined $empty, "Check pop on empty array"); |
aaf3876d |
92 | } |
93 | my $i = 0; |
94 | foreach my $var (@foo) { |
95 | $i++; |
96 | } |
97 | ok(29, scalar @foo == $i, "Check foreach"); |
98 | my $ref = \@foo; |
99 | ok(30, $ref->[0] == 3, "Check reference access"); |
100 | threads->create(sub { $ref->[0] = "thread4"})->join(); |
101 | ok(31, $ref->[0] eq "thread4", "Check that it works after another thread"); |
102 | undef($ref); |
103 | threads->create(sub { @foo = () })->join(); |
104 | ok(32, @foo == 0, "Check that array is empty"); |
105 | ok(33, exists($foo[0]) == 0, "Check that zero index doesn't index"); |
106 | @foo = ("sky"); |
107 | ok(34, exists($foo[0]) == 1, "Check that zero index exists now"); |
108 | ok(35, $foo[0] eq "sky", "And check that it also contains the right value"); |
109 | $#foo = 20; |
110 | $foo[20] = "sky"; |
111 | ok(36, delete($foo[20]) eq "sky", "Check delete works"); |
112 | |
113 | threads->create(sub { delete($foo[0])})->join(); |
13c1b207 |
114 | ok(37, !defined delete($foo[0]), "Check that delete works from a thread"); |
aaf3876d |
115 | |
116 | @foo = (1,2,3,4,5); |
117 | |
118 | { |
6b85e4fe |
119 | my ($t1,$t2) = @foo[2,3]; |
aaf3876d |
120 | ok(38, $t1 == 3, "Check slice"); |
121 | ok(39, $t2 == 4, "Check slice again"); |
122 | my @t1 = @foo[1...4]; |
123 | ok(40, $t1[0] == 2, "Check slice list"); |
124 | ok(41, $t1[2] == 4, "Check slice list 2"); |
125 | threads->create(sub { @foo[0,1] = ("hej","hop") })->join(); |
126 | ok(42,$foo[0] eq "hej", "Check slice assign"); |
127 | } |
128 | { |
129 | eval { |
7473853a |
130 | my @t1 = splice(@foo,0,2,"hop", "hej"); |
aaf3876d |
131 | }; |
6b85e4fe |
132 | ok(43, my $temp1 = $@ =~/Splice not implemented for shared arrays/, "Check that the warning message is correct for non splice"); |
aaf3876d |
133 | } |
7473853a |
134 | |
135 | ok(44, is_shared(@foo), "Check for sharing"); |
136 | |
6c791b15 |
137 | exit(0); |
138 | |
7473853a |
139 | # EOF |