Commit | Line | Data |
39e571d4 |
1 | #!./perl |
bf3d9ec5 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
93430cb4 |
5 | unshift @INC, '../lib'; |
bf3d9ec5 |
6 | require Config; import Config; |
146174a9 |
7 | if (! $Config{'use5005threads'}) { |
8 | print "1..0 # Skip: not use5005threads\n"; |
bf3d9ec5 |
9 | exit 0; |
10 | } |
9c63abab |
11 | |
12 | # XXX known trouble with global destruction |
13 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; |
bf3d9ec5 |
14 | } |
15 | $| = 1; |
146174a9 |
16 | print "1..21\n"; |
17 | use Thread 'yield'; |
bf3d9ec5 |
18 | print "ok 1\n"; |
19 | |
20 | sub content |
21 | { |
22 | print shift; |
23 | return shift; |
24 | } |
25 | |
26 | # create a thread passing args and immedaietly wait for it. |
c4e7bd8d |
27 | my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); |
bf3d9ec5 |
28 | print $t->join; |
29 | |
30 | # check that lock works ... |
31 | {lock $foo; |
32 | $t = new Thread sub { lock $foo; print "ok 5\n" }; |
33 | print "ok 4\n"; |
34 | } |
35 | $t->join; |
36 | |
8d6d311f |
37 | sub dorecurse |
bf3d9ec5 |
38 | { |
bf3d9ec5 |
39 | my $val = shift; |
40 | my $ret; |
0f5feb8d |
41 | print $val; |
bf3d9ec5 |
42 | if (@_) |
43 | { |
8d6d311f |
44 | $ret = Thread->new(\&dorecurse, @_); |
faa19ec9 |
45 | $ret->join; |
bf3d9ec5 |
46 | } |
bf3d9ec5 |
47 | } |
48 | |
8d6d311f |
49 | $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; |
faa19ec9 |
50 | $t->join; |
bf3d9ec5 |
51 | |
52 | # test that sleep lets other thread run |
8d6d311f |
53 | $t = new Thread \&dorecurse,"ok 11\n"; |
61bb5906 |
54 | sleep 6; |
0f5feb8d |
55 | print "ok 12\n"; |
faa19ec9 |
56 | $t->join; |
8d6d311f |
57 | |
146174a9 |
58 | sub islocked : locked { |
8d6d311f |
59 | my $val = shift; |
60 | my $ret; |
61 | print $val; |
62 | if (@_) |
63 | { |
64 | $ret = Thread->new(\&islocked, shift); |
65 | } |
66 | $ret; |
67 | } |
68 | |
69 | $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); |
70 | $t->join->join; |
71 | |
13e08037 |
72 | { |
73 | package Loch::Ness; |
74 | sub new { bless [], shift } |
cb50131a |
75 | sub monster : locked : method { |
13e08037 |
76 | my($s, $m) = @_; |
77 | print "ok $m\n"; |
78 | } |
79 | sub gollum { &monster } |
80 | } |
81 | Loch::Ness->monster(15); |
82 | Loch::Ness->new->monster(16); |
83 | Loch::Ness->gollum(17); |
84 | Loch::Ness->new->gollum(18); |
146174a9 |
85 | |
86 | my $short = "This is a long string that goes on and on."; |
87 | my $shorte = " a long string that goes on and on."; |
88 | my $long = "This is short."; |
89 | my $longe = " short."; |
90 | my $thr1 = new Thread \&threaded, $short, $shorte, "19"; |
91 | my $thr2 = new Thread \&threaded, $long, $longe, "20"; |
92 | |
93 | sub threaded { |
94 | my ($string, $string_end, $testno) = @_; |
95 | |
96 | # Do the match, saving the output in appropriate variables |
97 | $string =~ /(.*)(is)(.*)/; |
98 | # Yield control, allowing the other thread to fill in the match variables |
99 | yield(); |
100 | # Examine the match variable contents; on broken perls this fails |
101 | if ($3 eq $string_end) { |
102 | print "ok $testno\n"; |
103 | } |
104 | else { |
105 | warn <<EOT; |
106 | |
107 | # |
108 | # This is a KNOWN FAILURE, and one of the reasons why threading |
109 | # is still an experimental feature. It is here to stop people |
110 | # from deploying threads in production. ;-) |
111 | # |
112 | EOT |
113 | print "not ok $testno # other thread filled in match variables\n"; |
114 | } |
115 | } |
116 | $thr1->join; |
117 | $thr2->join; |
118 | print "ok 21\n"; |