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
14use threads;
15
16BEGIN {
17    if (! eval 'use threads::shared; 1') {
18        print("1..0 # SKIP threads::shared not available\n");
19        exit(0);
20    }
21
22    $| = 1;
23    print("1..20\n");   ### Number of tests that will be run ###
24};
25
26my $TEST;
27BEGIN {
28    share($TEST);
29    $TEST = 1;
30}
31
32ok(1, 'Loaded');
33
34sub ok {
35    my ($ok, $name) = @_;
36
37    lock($TEST);
38    my $id = $TEST++;
39
40    # You have to do it this way or VMS will get confused.
41    if ($ok) {
42        print("ok $id - $name\n");
43    } else {
44        print("not ok $id - $name\n");
45        printf("# Failed test at line %d\n", (caller)[2]);
46    }
47
48    return ($ok);
49}
50
51sub skip {
52    ok(1, '# SKIP ' . $_[0]);
53}
54
55
56### Start of Testing ###
57
58{
59    my $retval = threads->create(sub { return ("hi") })->join();
60    ok($retval eq 'hi', "Check basic returnvalue");
61}
62{
63    my ($thread) = threads->create(sub { return (1,2,3) });
64    my @retval = $thread->join();
65    ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
66}
67{
68    my $retval = threads->create(sub { return [1] })->join();
69    ok($retval->[0] == 1,"Check that a array ref works",);
70}
71{
72    my $retval = threads->create(sub { return { foo => "bar" }})->join();
73    ok($retval->{foo} eq 'bar',"Check that hash refs work");
74}
75{
76    my $retval = threads->create( sub {
77        open(my $fh, "+>threadtest") || die $!;
78        print $fh "test\n";
79        return $fh;
80    })->join();
81    ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
82    print $retval "test2\n";
83    close($retval);
84    unlink("threadtest");
85}
86{
87    my $test = "hi";
88    my $retval = threads->create(sub { return $_[0]}, \$test)->join();
89    ok($$retval eq 'hi','');
90}
91{
92    my $test = "hi";
93    share($test);
94    my $retval = threads->create(sub { return $_[0]}, \$test)->join();
95    ok($$retval eq 'hi','');
96    $test = "foo";
97    ok($$retval eq 'foo','');
98}
99{
100    my %foo;
101    share(%foo);
102    threads->create(sub { 
103        my $foo;
104        share($foo);
105        $foo = "thread1";
106        return $foo{bar} = \$foo;
107    })->join();
108    ok(1,"");
109}
110
111# We parse ps output so this is OS-dependent.
112if ($^O eq 'linux') {
113    # First modify $0 in a subthread.
114    #print "# mainthread: \$0 = $0\n";
115    threads->create(sub{ #print "# subthread: \$0 = $0\n";
116                        $0 = "foobar";
117                        #print "# subthread: \$0 = $0\n"
118                 })->join;
119    #print "# mainthread: \$0 = $0\n";
120    #print "# pid = $$\n";
121    if (open PS, "ps -f |") { # Note: must work in (all) systems.
122        my ($sawpid, $sawexe);
123        while (<PS>) {
124            chomp;
125            #print "# [$_]\n";
126            if (/^\s*\S+\s+$$\s/) {
127                $sawpid++;
128                if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
129                    $sawexe++;
130                }
131                last;
132            }
133        }
134        close PS or die;
135        if ($sawpid) {
136            ok($sawpid && $sawexe, 'altering $0 is effective');
137        } else {
138            skip("\$0 check: did not see pid $$ in 'ps -f |'");
139        }
140    } else {
141        skip("\$0 check: opening 'ps -f |' failed: $!");
142    }
143} else {
144    skip("\$0 check: only on Linux");
145}
146
147{
148    my $t = threads->create(sub {});
149    $t->join();
150    threads->create(sub {})->join();
151    eval { $t->join(); };
152    ok(($@ =~ /Thread already joined/), "Double join works");
153    eval { $t->detach(); };
154    ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread");
155}
156
157{
158    my $t = threads->create(sub {});
159    $t->detach();
160    threads->create(sub {})->join();
161    eval { $t->detach(); };
162    ok(($@ =~ /Thread already detached/), "Double detach works");
163    eval { $t->join(); };
164    ok(($@ =~ /Cannot join a detached thread/), "Join detached thread");
165}
166
167{
168    # The "use IO::File" is not actually used for anything; its only purpose
169    # is incite a lot of calls to newCONSTSUB.  See the p5p archives for
170    # the thread "maint@20974 or before broke mp2 ithreads test".
171    use IO::File;
172    # This coredumped between #20930 and #21000
173    $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
174}
175
176{
177    my $go : shared = 0;
178
179    my $t = threads->create( sub {
180        lock($go);
181        cond_wait($go) until $go;
182    }); 
183
184    my $joiner = threads->create(sub { $_[0]->join }, $t);
185
186    threads->yield();
187    sleep 1;
188    eval { $t->join; };
189    ok(($@ =~ /^Thread already joined at/)?1:0, "Join pending join");
190
191    { lock($go); $go = 1; cond_signal($go); }
192    $joiner->join;
193}
194
195{
196    my $go : shared = 0;
197    my $t = threads->create( sub {
198        eval { threads->self->join; };
199        ok(($@ =~ /^Cannot join self/), "Join self");
200        lock($go); $go = 1; cond_signal($go);
201    });
202
203    { lock ($go); cond_wait($go) until $go; }
204    $t->join;
205}
206
207{
208    my $go : shared = 0;
209    my $t = threads->create( sub {
210        lock($go);  cond_wait($go) until $go;
211    });
212    my $joiner = threads->create(sub { $_[0]->join; }, $t);
213
214    threads->yield();
215    sleep 1;
216    eval { $t->detach };
217    ok(($@ =~ /^Cannot detach a joined thread at/)?1:0, "Detach pending join");
218
219    { lock($go); $go = 1; cond_signal($go); }
220    $joiner->join;
221}
222
223exit(0);
224
225# EOF
226