This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Introduce two new Configure symbols:
[perl5.git] / ext / threads / t / thread.t
CommitLineData
f9dff5f5
AB
1
2BEGIN {
3 chdir 't' if -d 't';
8abd20a8 4 @INC = qw(../lib .);
f9dff5f5
AB
5 require Config; import Config;
6 unless ($Config{'useithreads'}) {
7 print "1..0 # Skip: no useithreads\n";
8 exit 0;
9 }
8abd20a8 10 require "test.pl";
f9dff5f5
AB
11}
12
13use ExtUtils::testlib;
14use strict;
38875929 15BEGIN { $| = 1; print "1..24\n" };
f9dff5f5
AB
16use threads;
17use threads::shared;
18
19print "ok 1\n";
20
21sub content {
22 print shift;
23 return shift;
24}
25{
26 my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000);
27 print $t->join();
28}
29{
30 my $lock : shared;
31 my $t;
32 {
33 lock($lock);
34 $t = threads->new(sub { lock($lock); print "ok 5\n"});
35 print "ok 4\n";
36 }
37 $t->join();
38}
39
40sub dorecurse {
41 my $val = shift;
42 my $ret;
74bf223e 43 print $val;
f9dff5f5
AB
44 if(@_) {
45 $ret = threads->new(\&dorecurse, @_);
74bf223e 46 $ret->join;
f9dff5f5
AB
47 }
48}
49{
74bf223e
JH
50 my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10);
51 $t->join();
f9dff5f5
AB
52}
53
54{
55 # test that sleep lets other thread run
74bf223e 56 my $t = threads->new(\&dorecurse, "ok 11\n");
da32f63e 57 threads->yield; # help out non-preemptive thread implementations
f9dff5f5 58 sleep 1;
74bf223e
JH
59 print "ok 12\n";
60 $t->join();
f9dff5f5
AB
61}
62{
63 my $lock : shared;
64 sub islocked {
65 lock($lock);
66 my $val = shift;
67 my $ret;
68 print $val;
69 if (@_) {
70 $ret = threads->new(\&islocked, shift);
71 }
72 return $ret;
73 }
74bf223e 74my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n");
f9dff5f5
AB
75$t->join->join;
76}
77
78
79
80sub testsprintf {
81 my $testno = shift;
82 my $same = sprintf( "%0.f", $testno);
8abd20a8 83 return $testno eq $same;
f9dff5f5
AB
84}
85
86sub threaded {
8abd20a8 87 my ($string, $string_end) = @_;
f9dff5f5
AB
88
89 # Do the match, saving the output in appropriate variables
90 $string =~ /(.*)(is)(.*)/;
91 # Yield control, allowing the other thread to fill in the match variables
92 threads->yield();
93 # Examine the match variable contents; on broken perls this fails
8abd20a8 94 return $3 eq $string_end;
f9dff5f5
AB
95}
96
97
98{
74bf223e 99 curr_test(15);
8abd20a8 100
74bf223e
JH
101 my $thr1 = threads->new(\&testsprintf, 15);
102 my $thr2 = threads->new(\&testsprintf, 16);
f9dff5f5
AB
103
104 my $short = "This is a long string that goes on and on.";
105 my $shorte = " a long string that goes on and on.";
106 my $long = "This is short.";
107 my $longe = " short.";
108 my $foo = "This is bar bar bar.";
109 my $fooe = " bar bar bar.";
8abd20a8
JH
110 my $thr3 = new threads \&threaded, $short, $shorte;
111 my $thr4 = new threads \&threaded, $long, $longe;
74bf223e
JH
112 my $thr5 = new threads \&testsprintf, 19;
113 my $thr6 = new threads \&testsprintf, 20;
8abd20a8
JH
114 my $thr7 = new threads \&threaded, $foo, $fooe;
115
116 ok($thr1->join());
117 ok($thr2->join());
118 ok($thr3->join());
119 ok($thr4->join());
120 ok($thr5->join());
121 ok($thr6->join());
122 ok($thr7->join());
f9dff5f5 123}
38875929
DM
124
125# test that 'yield' is importable
126
127package Test1;
128
129use threads 'yield';
130yield;
131main::ok(1);
132
133package main;
134
135
136# test async
137
138{
139 my $th = async {return 1 };
140 ok($th);
141 ok($th->join());
142}
143