This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.08_07
[perl5.git] / ext / threads / t / blocks.t
CommitLineData
f2e0bb91
JH
1use strict;
2use warnings;
3
4BEGIN {
5 if ($ENV{'PERL_CORE'}){
6 chdir 't';
7 unshift @INC, '../lib';
8 }
9 use Config;
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12 exit(0);
13 }
14}
15
16use ExtUtils::testlib;
17
18use threads;
f2e0bb91 19
f2e0bb91 20BEGIN {
58a3a76c
JH
21 eval {
22 require threads::shared;
23 import threads::shared;
24 };
25 if ($@ || ! $threads::shared::threads_shared) {
26 print("1..0 # Skip: threads::shared not available\n");
27 exit(0);
28 }
29
f2e0bb91
JH
30 $| = 1;
31 print("1..5\n"); ### Number of tests that will be run ###
f2e0bb91
JH
32};
33
58a3a76c
JH
34my $TEST = 1;
35share($TEST);
36
f2e0bb91
JH
37ok(1, 'Loaded');
38
39sub ok {
40 my ($ok, $name) = @_;
41
42 lock($TEST);
43 my $id = $TEST++;
44
45 # You have to do it this way or VMS will get confused.
46 if ($ok) {
47 print("ok $id - $name\n");
48 } else {
49 print("not ok $id - $name\n");
50 printf("# Failed test at line %d\n", (caller)[2]);
51 }
52
53 return ($ok);
54}
55
56
57### Start of Testing ###
58
59$SIG{'__WARN__'} = sub { ok(0, "Warning: $_[0]"); };
60
61sub foo { }
62sub baz { 42 }
63
64my $bthr;
65BEGIN {
66 $SIG{'__WARN__'} = sub { ok(0, "BEGIN: $_[0]"); };
67
68 threads->create('foo')->join();
69 threads->create(\&foo)->join();
70 threads->create(sub {})->join();
71
72 threads->create('foo')->detach();
73 threads->create(\&foo)->detach();
74 threads->create(sub {})->detach();
75
76 $bthr = threads->create('baz');
77}
78
79my $mthr;
80MAIN: {
81 threads->create('foo')->join();
82 threads->create(\&foo)->join();
83 threads->create(sub {})->join();
84
85 threads->create('foo')->detach();
86 threads->create(\&foo)->detach();
87 threads->create(sub {})->detach();
88
89 $mthr = threads->create('baz');
90}
91
92ok($mthr, 'Main thread');
93ok($bthr, 'BEGIN thread');
94
95ok($mthr->join() == 42, 'Main join');
96ok($bthr->join() == 42, 'BEGIN join');
97
5168baf3
DM
98# make sure a still-running detached thread doesn't give a warning on exit
99
100# *** add new tests above this one
101threads->create(sub { 1 while 1 })->detach();
102# *** add new tests above this one