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
1 use strict;
2 use warnings;
3
4 BEGIN {
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
16 use ExtUtils::testlib;
17
18 use threads;
19
20 BEGIN {
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
34 my $TEST;
35 BEGIN {
36     share($TEST);
37     $TEST = 1;
38 }
39
40 ok(1, 'Loaded');
41
42 sub 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
79 sub 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
125 my @exit_types = qw(return die exit threads->exit);
126
127 # Test (non-trivial) combinations of termination methods
128 #   WRT the thread and its handlers
129 foreach 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:
173 no warnings 'threads';
174
175 sub 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
220 foreach 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;
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     }
251 };
252
253 threads->create(sub { sleep(100); });
254 threads->create(sub {});
255 threads->create(sub {});
256 threads->create(sub { sleep(100); })->detach();
257 threads->create(sub { sleep(100); })->detach();
258 threads->create(sub { sleep(100); })->detach();
259 threads->yield();
260 sleep(1);
261
262 # EOF