Commit | Line | Data |
---|---|---|
39e571d4 | 1 | #!./perl |
bf3d9ec5 NIS |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
93430cb4 | 5 | unshift @INC, '../lib'; |
bf3d9ec5 | 6 | require Config; import Config; |
97404f98 GS |
7 | if (! $Config{'use5005threads'}) { |
8 | print "1..0 # Skip: not use5005threads\n"; | |
bf3d9ec5 NIS |
9 | exit 0; |
10 | } | |
9c63abab GS |
11 | |
12 | # XXX known trouble with global destruction | |
13 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; | |
bf3d9ec5 NIS |
14 | } |
15 | $| = 1; | |
bed74ed0 GS |
16 | print "1..21\n"; |
17 | use Thread 'yield'; | |
bf3d9ec5 NIS |
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 NIS |
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 NIS |
39 | my $val = shift; |
40 | my $ret; | |
0f5feb8d | 41 | print $val; |
bf3d9ec5 NIS |
42 | if (@_) |
43 | { | |
8d6d311f | 44 | $ret = Thread->new(\&dorecurse, @_); |
faa19ec9 | 45 | $ret->join; |
bf3d9ec5 | 46 | } |
bf3d9ec5 NIS |
47 | } |
48 | ||
8d6d311f | 49 | $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; |
faa19ec9 | 50 | $t->join; |
bf3d9ec5 NIS |
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 | |
a98df962 | 58 | sub islocked : locked { |
8d6d311f GS |
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 GS |
72 | { |
73 | package Loch::Ness; | |
74 | sub new { bless [], shift } | |
a98df962 | 75 | sub monster : locked, method { |
13e08037 GS |
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); | |
bed74ed0 GS |
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"; |