This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RE: [PATCH] threads 1.33
[perl5.git] / ext / threads / t / exit.t
CommitLineData
4dcb9e53
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;
19
20BEGIN {
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
30 $| = 1;
31 print("1..226\n"); ### Number of tests that will be run ###
32};
33
34my $TEST;
35BEGIN {
36 share($TEST);
37 $TEST = 1;
38}
39
40ok(1, 'Loaded');
41
42sub ok {
43 my ($ok, $name) = @_;
44 if (! defined($name)) {
45 # Bug in test
46 $name = $ok;
47 $ok = 0;
48 }
49 chomp($name);
50
51 lock($TEST);
52 my $id = $TEST++;
53
54 # You have to do it this way or VMS will get confused.
55 if ($ok) {
56 print("ok $id - $name\n");
57 } else {
58 print("not ok $id - $name\n");
59 printf("# Failed test at line %d\n", (caller)[2]);
60 print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
61 }
62
63 return ($ok);
64}
65
66
67### Start of Testing ###
68
69$SIG{'__WARN__'} = sub {
70 my $msg = shift;
71 ok(0, "WARN in main: $msg");
72};
73$SIG{'__DIE__'} = sub {
74 my $msg = shift;
75 ok(0, "DIE in main: $msg");
76};
77
78
79sub nasty
80{
81 my ($term, $warn, $die) = @_;
82 my $tid = threads->tid();
83
84 $SIG{'__WARN__'} = sub {
85 my $msg = $_[0];
86 ok($msg =~ /Thread \d+ terminated abnormally/, "WARN: $msg");
87 if ($warn eq 'return') {
88 return ('# __WARN__ returned');
89 } elsif ($warn eq 'die') {
90 die('# __WARN__ dying');
91 } elsif ($warn eq 'exit') {
92 CORE::exit(20);
93 } else {
94 threads->exit(21);
95 }
96 };
97
98 $SIG{'__DIE__'} = sub {
99 my $msg = $_[0];
100 ok(1, "DIE: $msg");
101 if ($die eq 'return') {
102 return ('# __DIE__ returned');
103 } elsif ($die eq 'die') {
104 die('# __DIE__ dying');
105 } elsif ($die eq 'exit') {
106 CORE::exit(30);
107 } else {
108 threads->exit(31);
109 }
110 };
111
112 ok(1, "Thread $tid");
113 if ($term eq 'return') {
114 return ('# Thread returned');
115 } elsif ($term eq 'die') {
116 die('# Thread dying');
117 } elsif ($term eq 'exit') {
118 CORE::exit(10);
119 } else {
120 threads->exit(11);
121 }
122}
123
124
125my @exit_types = qw(return die exit threads->exit);
126
127# Test (non-trivial) combinations of termination methods
128# WRT the thread and its handlers
129foreach my $die (@exit_types) {
130 foreach my $wrn (@exit_types) {
131 foreach my $thr (@exit_types) {
132 # Things are well behaved if the thread just returns
133 next if ($thr eq 'return');
134
135 # Skip combos with the die handler
136 # if neither the thread nor the warn handler dies
137 next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
138
139 # Must send STDERR to file to filter out 'un-capturable' output
140 my $rc;
141 eval {
142 local *STDERR;
143 if (! open(STDERR, '>tmp.stderr')) {
144 die('Failed to create "tmp.stderr"');
145 }
146
147 $rc = threads->create('nasty', $thr, $wrn, $die)->join();
148
149 close(STDERR);
150 };
151
152 # Filter out 'un-capturable' output
153 if (open(IN, 'tmp.stderr')) {
154 while (my $line = <IN>) {
155 if ($line !~ /^#/) {
156 print(STDERR $line);
157 }
158 }
159 close(IN);
160 } else {
161 ok(0, "Failed to open 'tmp.stderr': $!");
162 }
163 unlink('tmp.stderr');
164
165 ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
166 ok(! defined($rc), "Thread returned 'undef'");
167 }
168 }
169}
170
171
172# Again with:
173no warnings 'threads';
174
175sub less_nasty
176{
177 my ($term, $warn, $die) = @_;
178 my $tid = threads->tid();
179
180 $SIG{'__WARN__'} = sub {
181 my $msg = $_[0];
182 ok(0, "WARN: $msg");
183 if ($warn eq 'return') {
184 return ('# __WARN__ returned');
185 } elsif ($warn eq 'die') {
186 die('# __WARN__ dying');
187 } elsif ($warn eq 'exit') {
188 CORE::exit(20);
189 } else {
190 threads->exit(21);
191 }
192 };
193
194 $SIG{'__DIE__'} = sub {
195 my $msg = $_[0];
196 ok(1, "DIE: $msg");
197 if ($die eq 'return') {
198 return ('# __DIE__ returned');
199 } elsif ($die eq 'die') {
200 die('# __DIE__ dying');
201 } elsif ($die eq 'exit') {
202 CORE::exit(30);
203 } else {
204 threads->exit(31);
205 }
206 };
207
208 ok(1, "Thread $tid");
209 if ($term eq 'return') {
210 return ('# Thread returned');
211 } elsif ($term eq 'die') {
212 die('# Thread dying');
213 } elsif ($term eq 'exit') {
214 CORE::exit(10);
215 } else {
216 threads->exit(11);
217 }
218}
219
220foreach my $die (@exit_types) {
221 foreach my $wrn (@exit_types) {
222 foreach my $thr (@exit_types) {
223 # Things are well behaved if the thread just returns
224 next if ($thr eq 'return');
225
226 # Skip combos with the die handler
227 # if neither the thread nor the warn handler dies
228 next if ($thr ne 'die' && $wrn ne 'die' && $die ne 'return');
229
230 my $rc;
231 eval { $rc = threads->create('less_nasty', $thr, $wrn, $die)->join() };
232 ok(! $@, ($@) ? "Thread problem: $@" : "Thread ran okay");
233 ok(! defined($rc), "Thread returned 'undef'");
234 }
235 }
236}
237
238
239# Check termination warning concerning running threads
240$SIG{'__WARN__'} = sub {
241 my $msg = shift;
fe78ea02
JH
242 if ($^O eq 'VMS') {
243 ok($msg =~ /0 running and unjoined/, '0 running and unjoined (VMS)');
244 ok($msg =~ /3 finished and unjoined/, '3 finished and unjoined (VMS)');
245 ok($msg =~ /0 running and detached/, '0 finished and detached (VMS)');
246 } else {
247 ok($msg =~ /1 running and unjoined/, '1 running and unjoined');
248 ok($msg =~ /2 finished and unjoined/, '2 finished and unjoined');
249 ok($msg =~ /3 running and detached/, '3 finished and detached');
250 }
4dcb9e53
JH
251};
252
253threads->create(sub { sleep(100); });
254threads->create(sub {});
255threads->create(sub {});
256threads->create(sub { sleep(100); })->detach();
257threads->create(sub { sleep(100); })->detach();
258threads->create(sub { sleep(100); })->detach();
259threads->yield();
260sleep(1);
261
262# EOF