This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Work in non core env.
[perl5.git] / ext / threads / t / join.t
CommitLineData
e1c44605
AB
1BEGIN {
2 chdir 't' if -d 't';
974ec8aa 3 push @INC, '../lib';
e1c44605
AB
4 require Config; import Config;
5 unless ($Config{'useithreads'}) {
6 print "1..0 # Skip: no useithreads\n";
7 exit 0;
8 }
9}
10
11use ExtUtils::testlib;
12use strict;
57b48062 13BEGIN { print "1..12\n" };
e1c44605
AB
14use threads;
15use threads::shared;
16
17my $test_id = 1;
18share($test_id);
19use Devel::Peek qw(Dump);
20
21sub ok {
22 my ($ok, $name) = @_;
23
24 # You have to do it this way or VMS will get confused.
25 print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
26
27 printf "# Failed test at line %d\n", (caller)[2] unless $ok;
28 $test_id++;
29 return $ok;
30}
31
d90a703e
JH
32sub skip {
33 ok(1, "# Skipped: @_");
34}
35
e1c44605
AB
36ok(1,"");
37
38
39{
40 my $retval = threads->create(sub { return ("hi") })->join();
41 ok($retval eq 'hi', "Check basic returnvalue");
42}
43{
44 my ($thread) = threads->create(sub { return (1,2,3) });
45 my @retval = $thread->join();
46 ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3);
47}
48{
49 my $retval = threads->create(sub { return [1] })->join();
50 ok($retval->[0] == 1,"Check that a array ref works");
51}
52{
53 my $retval = threads->create(sub { return { foo => "bar" }})->join();
54 ok($retval->{foo} eq 'bar',"Check that hash refs work");
55}
56{
57 my $retval = threads->create( sub {
58 open(my $fh, "+>threadtest") || die $!;
59 print $fh "test\n";
60 return $fh;
61 })->join();
62 ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
63 print $retval "test2\n";
64# seek($retval,0,0);
65# ok(<$retval> eq "test\n");
66 close($retval);
67 unlink("threadtest");
68}
69{
70 my $test = "hi";
71 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
72 ok($$retval eq 'hi');
73}
74{
75 my $test = "hi";
76 share($test);
77 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
78 ok($$retval eq 'hi');
79 $test = "foo";
80 ok($$retval eq 'foo');
81}
82{
83 my %foo;
84 share(%foo);
85 threads->create(sub {
86 my $foo;
87 share($foo);
88 $foo = "thread1";
89 return $foo{bar} = \$foo;
90 })->join();
91 ok(1,"");
92}
e2975953
JH
93
94if ($^O eq 'linux') { # We parse ps output so this is OS-dependent.
e2975953 95 # First modify $0 in a subthread.
c8c7fdd1
RGS
96 print "# mainthread: \$0 = $0\n";
97 threads->new( sub {
98 print "# subthread: \$0 = $0\n";
99 $0 = "foobar";
100 print "# subthread: \$0 = $0\n" } )->join;
101 print "# mainthread: \$0 = $0\n";
102 print "# pid = $$\n";
103 if (open PS, "ps -f |") { # Note: must work in (all) Linux(es).
00c4b2c0 104 my ($sawpid, $sawexe);
e2975953 105 while (<PS>) {
c8c7fdd1
RGS
106 s/\s+$//; # there seems to be extra whitespace at the end by ps(1)?
107 print "# $_\n";
00c4b2c0
JH
108 if (/^\S+\s+$$\s/) {
109 $sawpid++;
110 if (/\sfoobar\b/) {
111 $sawexe++;
112 }
e2975953
JH
113 last;
114 }
115 }
116 close PS;
00c4b2c0
JH
117 if ($sawpid) {
118 ok($sawpid && $sawexe, 'altering $0 is effective');
119 } else {
120 skip("\$0 check: did not see pid $$ in 'ps -f |'");
121 }
e2975953
JH
122 } else {
123 skip("\$0 check: opening 'ps -f |' failed: $!");
124 }
125} else {
126 skip("\$0 check: only on Linux");
127}
57b48062
AB
128
129{
130 my $t = threads->new(sub {});
131 $t->join;
132 my $x = threads->new(sub {});
133 $x->join;
134 eval {
135 $t->join;
136 };
137 my $ok = 0;
138 $ok++ if($@ =~/Thread already joined/);
139 ok($ok, "Double join works");
140}