File Coverage

blib/lib/Test/ParallelSubtest.pm
Criterion Covered Total %
statement 159 178 89.3
branch 37 60 61.6
condition 2 6 33.3
subroutine 27 28 96.4
pod 4 4 100.0
total 229 276 82.9


line stmt bran cond sub pod time code
1             package Test::ParallelSubtest;
2 10     10   244938 use strict;
  10         41  
  10         530  
3 10     10   63 use warnings;
  10         23  
  10         775  
4              
5             our $VERSION = '0.05';
6             $VERSION = eval $VERSION;
7              
8 10     10   6351 use Test::Builder::Module;
  10         89750  
  10         71  
9             our @ISA = qw(Test::Builder::Module);
10             our @EXPORT = qw(bg_subtest_wait bg_subtest max_parallel);
11              
12             our @_kids;
13             our $_i_am_a_child = 0;
14              
15             our $MaxParallel = 4;
16              
17 10     10   1106 use Carp;
  10         20  
  10         1006  
18 10     10   9783 use Sub::Prepend ();
  10         32061  
  10         317  
19 10     10   12395 use TAP::Parser;
  10         971186  
  10         379  
20 10     10   118 use Test::Builder;
  10         21  
  10         250  
21 10     10   20445 use Test::ParallelSubtest::Capture;
  10         30  
  10         8672  
22              
23             Test::Builder->new->can('subtest') or croak
24             "Need a version of Test::Builder with subtest support";
25              
26 10 100   10   19549 END { bg_subtest_wait() if @_kids }
27              
28             Sub::Prepend::prepend(
29             'Test::Builder::done_testing' => \&bg_subtest_wait
30             );
31             Sub::Prepend::prepend(
32             'Test::Builder::subtest' => sub {
33             # Wait for kids just before entering a subtest.
34             bg_subtest_wait();
35              
36             # Wait for kids just before leaving a subtest.
37             my $subtests = $_[2];
38             $_[2] = sub {
39             $subtests->();
40             bg_subtest_wait();
41             };
42             }
43             );
44              
45             sub import_extra {
46 10     10 1 609 my ($class, $list) = @_;
47              
48 10         27 my @other;
49 10         50 while (@$list >= 2) {
50 21         49 my $item = shift @$list;
51 21 100       53 if ($item eq 'max_parallel') {
52 7         28 max_parallel(shift @$list);
53             }
54             else {
55 14         47 push @other, $item;
56             }
57             }
58              
59 10         35 @$list = @other;
60              
61 10         36 return;
62             }
63              
64             sub max_parallel (;$) {
65 15     15 1 2342 my $new_value = shift;
66              
67 15         24 my $old_value = $MaxParallel;
68 15 100       60 if (defined $new_value) {
69 9 50       61 $new_value =~ /^[0-9]+\z/ or croak "non-numeric max_parallel value";
70 9         25 $MaxParallel = $new_value;
71             }
72              
73 15         56 return $old_value;
74             }
75              
76             sub bg_subtest ($&) {
77 24     24 1 638 my ($name, $subtests) = @_;
78              
79 24 100       191 $_i_am_a_child and croak "bg_subtest() called from a child process";
80              
81 23         865 my $tb = Test::Builder->new;
82              
83 23 100       384 if ($MaxParallel < 1) {
84             # We've been told not to fork.
85 1         7 return $tb->subtest($name, $subtests);
86             }
87              
88 22         82 while (@_kids >= $MaxParallel) {
89 14         122 _wait_for_next_kid();
90             }
91              
92 22         93 my ($read_pipe, $write_pipe, $pid) = _pipe_and_fork();
93              
94 22 50       219 if (!defined $pid) {
95             # Can't fork, fall back to a subtest() call.
96 0         0 return $tb->subtest($name, $subtests);
97             }
98              
99 22         1218 my $out_fh = $tb->output;
100 22         2771 my $fail_fh = $tb->failure_output;
101 22         446 my $todo_fh = $tb->todo_output;
102              
103 22 100       384 if ($pid) {
104             # parent
105 16         487 close $write_pipe;
106 16         3422 my @caller = caller();
107 16         1932 push @_kids, {
108             Pid => $pid,
109             Ppid => $$,
110             Pipe => $read_pipe,
111             Out => [$out_fh, $fail_fh, $todo_fh],
112             TestName => $name,
113             Caller => "$caller[1] line $caller[2]",
114             };
115 16         2260 return;
116             }
117             else {
118             # child
119 6         776 close $read_pipe;
120 6         361 local $Test::Builder::Level = $Test::Builder::Level + 1;
121 6         357 _child($write_pipe, $name, $subtests);
122             }
123             }
124              
125             sub _child {
126 6     6   188 my ($write_pipe, $name, $subtests) = @_;
127              
128 6         721 $_i_am_a_child = 1;
129              
130             # Capture the outputs of the subtest as strings.
131 6         1656 my $outer_out = '';
132 6         92 my $outer_fail = '';
133 6         73 my $outer_todo = '';
134 6         327 my $tb = Test::Builder->new;
135 6         456 $tb->output(\$outer_out);
136 6         12198 $tb->failure_output(\$outer_fail);
137 6         396 $tb->todo_output(\$outer_todo);
138              
139             # Capture the outputs of tests within the subtest for replay
140             # in the parent.
141 6         627 my $capture = Test::ParallelSubtest::Capture->new;
142              
143             $tb->subtest($name, sub {
144 6     6   50 $capture->install($tb);
145 6         192 $subtests->();
146 6         452 });
147              
148             # Pass all the captured output to the parent process.
149 6         5498 _len_prefixed_writes($write_pipe,
150             \$outer_out, \$outer_fail, \$outer_todo, $capture->as_string_ref
151             );
152              
153 6         1755 close $write_pipe;
154              
155 10     10   71 no warnings 'redefine';
  10         14  
  10         7091  
156 6     0   492 *Test::Builder::DESTROY = sub {}; # For T::B fork in subtest bug
  0         0  
157 6         1196 exit(0);
158             }
159              
160             sub bg_subtest_wait {
161 26 100   26 1 1075 return if $_i_am_a_child;
162            
163 5         61 _wait_for_next_kid() while @_kids;
164             }
165              
166             sub _pipe_and_fork {
167 22     22   37 my ($read_pipe, $write_pipe, $pid);
168              
169 22         31 while (1) {
170 22         731 my $pipe_ok = pipe $read_pipe, $write_pipe;
171 22 50       73 if ($pipe_ok) {
172 22         43937 $pid = fork;
173 22 50       2549 if (defined $pid) {
174 22         1550 return ($read_pipe, $write_pipe, $pid);
175             }
176             }
177              
178 0 0       0 if (@_kids) {
179             # The pipe or fork failure could be due to a resource limit,
180             # reap a kid and try again.
181 0         0 _wait_for_next_kid();
182             }
183             else {
184             # No kids and pipe+fork won't work, give up.
185 0         0 return;
186             }
187             }
188             }
189              
190             sub _wait_for_next_kid {
191 16     16   136 my $kid = shift @_kids;
192              
193 16 50 33     356 return unless $kid and $kid->{Ppid} == $$;
194              
195 16         109 my $tb = Test::Builder->new;
196 16         121 my ($out_dest, $fail_dest, $todo_dest) = @{ $kid->{Out} };
  16         33  
197              
198 16         423 my ($outer_out, $outer_fail, $outer_todo, $inner_capture)
199             = _len_prefixed_reads($kid->{Pipe}, 4);
200              
201 16         22769255 waitpid $kid->{Pid}, 0; # Don't let zombies build up.
202              
203 16 50       276 if (!defined $outer_out) {
204 0         0 my $name = "failed child process for '$kid->{TestName}'";
205 0         0 _run_test_from_kid_in_parent(0, $name, undef, undef, <
206             ERROR: bg_subtest "$kid->{TestName}" ($kid->{Caller}) aborted:
207             Lost contact with the child process.
208             END
209 0         0 return;
210             }
211              
212 16         256 my ($ok, $name, $todo, $skip) = _parse_outer_output_line($$outer_out);
213              
214 16 50       67 if (!defined $ok) {
215 0         0 $name = "parse child output for '$kid->{TestName}'";
216 0         0 _run_test_from_kid_in_parent(0, $name, undef, undef, <
217             ERROR: bg_subtest "$kid->{TestName}" ($kid->{Caller}) aborted:
218             Parsing failure in Test::ParallelSubtest - cannot parse:
219             [$$outer_out]
220             END
221 0         0 return;
222             }
223              
224 16 50 33     84 if (defined $todo and $Test::Builder::VERSION >= 0.95_02) {
225             # Recent Test::Builder redirects the fail output to the todo
226             # output for a todo subtest.
227 0         0 $fail_dest = $todo_dest;
228             }
229              
230 16         246 my $cap = Test::ParallelSubtest::Capture->new($inner_capture);
231 16 50       132 if ( ! $cap->replay_writes($out_dest, $fail_dest, $todo_dest) ) {
232 0         0 $name = "garbled child output for '$name'";
233 0         0 _run_test_from_kid_in_parent(0, $name, undef, undef, <
234             ERROR: bg_subtest "$name" ($kid->{Caller}) aborted:
235             Garbled captured output from the child process
236             END
237 0         0 return;
238             }
239              
240 16         70 _run_test_from_kid_in_parent($ok, $name, $todo, $skip);
241              
242 16         525 print $fail_dest $$outer_fail;
243 16         806 print $todo_dest $$outer_todo;
244             }
245              
246             sub _run_test_from_kid_in_parent {
247 16     16   41 my ($ok, $name, $todo, $skip, $internal_failure) = @_;
248              
249 10     10   101 no warnings 'redefine';
  10         20  
  10         10105  
250 16     16   329 local *Test::Builder::todo = sub { $todo };
  16         2280  
251 16     32   195 local *Test::Builder::in_todo = sub { defined $todo };
  32         2449  
252              
253 16         105 my $tb = Test::Builder->new;
254            
255 16 50       245 if ($internal_failure) {
    50          
256 0         0 $tb->ok($ok, $name);
257 0         0 $tb->diag($internal_failure);
258             }
259             elsif (defined $skip) {
260 0         0 $tb->skip($skip);
261             }
262             else {
263 16         70 _ok_without_diag_output($tb, $ok, $name);
264             }
265             }
266              
267             sub _ok_without_diag_output {
268 16     16   54 my ($tb, $pass, $name) = @_;
269              
270 16         32 my $discard = '';
271 16         97 my $save_fail = $tb->failure_output;
272 16         233 my $save_todo = $tb->todo_output;
273 16         144 $tb->failure_output(\$discard);
274 16         64880 $tb->todo_output(\$discard);
275              
276 16         860 $tb->ok($pass, $name);
277              
278 16         5315 $tb->todo_output($save_todo);
279 16         453 $tb->failure_output($save_fail);
280             }
281              
282             sub _parse_outer_output_line {
283 16     16   98 my $output = shift;
284              
285 16         528 while ($output =~ s/^(\s*#\s*.*\n)//) {
286 16         235 _print_to(Test::Builder->new->output, $1);
287             }
288 16         110 $output =~ s/^\s*//; # it may have been generated within a subtest
289              
290 16 50       751 my $parser = TAP::Parser->new( { tap => $output } ) or return;
291 16 50       22624 my $result = $parser->next or return;
292 16 50       30235 $result->is_test or return;
293              
294 16         181 my $ok = $result->is_actual_ok;
295 16         127 my $name = $result->description;
296 16         144 $name =~ s/- //;
297 16         209 $name =~ s/\\#/#/g;
298 16 50       66 my $todo = $result->has_todo ? $result->explanation : undef;
299 16 50       148 my $skip = $result->has_skip ? $result->explanation : undef;
300              
301 16         380 return ($ok, $name, $todo, $skip);
302             }
303              
304             sub _len_prefixed_writes {
305 6     6   23 my ($fh, @data) = @_;
306              
307 6         20 print $fh map { pack('N', length $$_) . $$_ } @data;
  24         156  
308             }
309              
310             sub _len_prefixed_reads {
311 16     16   25 my ($fh, $count) = @_;
312              
313 16         160 my @results;
314 16         81 while ($count--) {
315 64         269 my $lenbuf = '';
316 64 50       15276987 read $fh, $lenbuf, 4 or return;
317 64 50       216 length($lenbuf) == 4 or return;
318 64         256 my $wantlen = unpack 'N', $lenbuf;
319              
320 64         171 my $buf = '';
321 64 100       755 if ($wantlen) {
322 32 50       233 read $fh, $buf, $wantlen or return;
323 32 50       144 length($buf) == $wantlen or return;
324             }
325 64         357 push @results, \$buf;
326             }
327              
328 16         81 return @results;
329             }
330              
331             sub _print_to {
332 16     16   655 my ($dest, $msg) = @_;
333              
334 16 50       212 if (ref $dest =~ /^SCALAR/) {
335 0         0 $$dest .= $msg;
336             } else {
337 16         42 print {$dest} $msg;
  16         1306  
338             }
339             }
340              
341             1;
342              
343             __END__