File Coverage

blib/lib/TAP/Parser/Scheduler.pm
Criterion Covered Total %
statement 113 125 90.4
branch 53 64 82.8
condition 16 22 72.7
subroutine 19 21 90.4
pod 4 4 100.0
total 205 236 86.8


line stmt bran cond sub pod time code
1             package TAP::Parser::Scheduler;
2              
3 16     16   23744 use strict;
  16         20  
  16         420  
4 16     16   57 use warnings;
  16         21  
  16         452  
5              
6 16     16   338 use Carp;
  16         21  
  16         951  
7 16     16   6109 use TAP::Parser::Scheduler::Job;
  16         29  
  16         397  
8 16     16   6313 use TAP::Parser::Scheduler::Spinner;
  16         28  
  16         20395  
9              
10             =head1 NAME
11              
12             TAP::Parser::Scheduler - Schedule tests during parallel testing
13              
14             =head1 VERSION
15              
16             Version 3.39
17              
18             =cut
19              
20             our $VERSION = '3.39';
21              
22             =head1 SYNOPSIS
23              
24             use TAP::Parser::Scheduler;
25              
26             =head1 DESCRIPTION
27              
28             =head1 METHODS
29              
30             =head2 Class Methods
31              
32             =head3 C
33              
34             my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
35             my $sched = TAP::Parser::Scheduler->new(
36             tests => [ ['t/test_name.t','Test Description'], ... ],
37             rules => \%rules,
38             );
39              
40             Given 'tests' and optional 'rules' as input, returns a new
41             C object. Each member of C<@tests> should be either a
42             a test file name, or a two element arrayref, where the first element is a test
43             file name, and the second element is a test description. By default, we'll use
44             the test name as the description.
45              
46             The optional C attribute provides direction on which tests should be run
47             in parallel and which should be run sequentially. If no rule data structure is
48             provided, a default data structure is used which makes every test eligible to
49             be run in parallel:
50              
51             { par => '**' },
52              
53             The rules data structure is documented more in the next section.
54              
55             =head2 Rules data structure
56              
57             The "C" data structure is the the heart of the scheduler. It allows you
58             to express simple rules like "run all tests in sequence" or "run all tests in
59             parallel except these five tests.". However, the rules structure also supports
60             glob-style pattern matching and recursive definitions, so you can also express
61             arbitarily complicated patterns.
62              
63             The rule must only have one top level key: either 'par' for "parallel" or 'seq'
64             for "sequence".
65              
66             Values must be either strings with possible glob-style matching, or arrayrefs
67             of strings or hashrefs which follow this pattern recursively.
68              
69             Every element in an arrayref directly below a 'par' key is eligible to be run
70             in parallel, while vavalues directly below a 'seq' key must be run in sequence.
71              
72             =head3 Rules examples
73              
74             Here are some examples:
75              
76             # All tests be run in parallel (the default rule)
77             { par => '**' },
78              
79             # Run all tests in sequence, except those starting with "p"
80             { par => 't/p*.t' },
81              
82             # Run all tests in parallel, except those starting with "p"
83             {
84             seq => [
85             { seq => 't/p*.t' },
86             { par => '**' },
87             ],
88             }
89              
90             # Run some startup tests in sequence, then some parallel tests than some
91             # teardown tests in sequence.
92             {
93             seq => [
94             { seq => 't/startup/*.t' },
95             { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
96             { seq => 't/shutdown/*.t' },
97             ],
98             },
99              
100              
101             =head3 Rules resolution
102              
103             =over 4
104              
105             =item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
106              
107             =item * "First match wins". The first rule that matches a test will be the one that applies.
108              
109             =item * Any test which does not match a rule will be run in sequence at the end of the run.
110              
111             =item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
112              
113             =item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C in your Harness object.
114              
115             =back
116              
117             =head3 Glob-style pattern matching for rules
118              
119             We implement our own glob-style pattern matching. Here are the patterns it supports:
120              
121             ** is any number of characters, including /, within a pathname
122             * is zero or more characters within a filename/directory name
123             ? is exactly one character within a filename/directory name
124             {foo,bar,baz} is any of foo, bar or baz.
125             \ is an escape character
126              
127             =cut
128              
129             sub new {
130 89     89 1 6016 my $class = shift;
131              
132 89 50       305 croak "Need a number of key, value pairs" if @_ % 2;
133              
134 89         301 my %args = @_;
135 89   33     286 my $tests = delete $args{tests} || croak "Need a 'tests' argument";
136 89   100     690 my $rules = delete $args{rules} || { par => '**' };
137              
138 89 50       233 croak "Unknown arg(s): ", join ', ', sort keys %args
139             if keys %args;
140              
141             # Turn any simple names into a name, description pair. TODO: Maybe
142             # construct jobs here?
143 89         158 my $self = bless {}, $class;
144              
145 89         240 $self->_set_rules( $rules, $tests );
146              
147 89         460 return $self;
148             }
149              
150             # Build the scheduler data structure.
151             #
152             # SCHEDULER-DATA ::= JOB
153             # || ARRAY OF ARRAY OF SCHEDULER-DATA
154             #
155             # The nested arrays are the key to scheduling. The outer array contains
156             # a list of things that may be executed in parallel. Whenever an
157             # eligible job is sought any element of the outer array that is ready to
158             # execute can be selected. The inner arrays represent sequential
159             # execution. They can only proceed when the first job is ready to run.
160              
161             sub _set_rules {
162 89     89   117 my ( $self, $rules, $tests ) = @_;
163              
164             # Convert all incoming tests to job objects.
165             # If no test description is provided use the file name as the description.
166 448         1064 my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
167 89 100       165 map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
  448         856  
168 89         331 my $schedule = $self->_rule_clause( $rules, \@tests );
169              
170             # If any tests are left add them as a sequential block at the end of
171             # the run.
172 89 100       210 $schedule = [ [ $schedule, @tests ] ] if @tests;
173              
174 89         239 $self->{schedule} = $schedule;
175             }
176              
177             sub _rule_clause {
178 139     139   158 my ( $self, $rule, $tests ) = @_;
179 139 50       364 croak 'Rule clause must be a hash'
180             unless 'HASH' eq ref $rule;
181              
182 139         403 my @type = keys %$rule;
183 139 50       317 croak 'Rule clause must have exactly one key'
184             unless @type == 1;
185              
186             my %handlers = (
187             par => sub {
188 93     93   147 [ map { [$_] } @_ ];
  190         614  
189             },
190 46     46   229 seq => sub { [ [@_] ] },
191 139         917 );
192              
193 139   33     341 my $handler = $handlers{ $type[0] }
194             || croak 'Unknown scheduler type: ', $type[0];
195 139         194 my $val = $rule->{ $type[0] };
196              
197             return $handler->(
198             map {
199 139 100       328 'HASH' eq ref $_
  190 100       522  
200             ? $self->_rule_clause( $_, $tests )
201             : $self->_expand( $_, $tests )
202             } 'ARRAY' eq ref $val ? @$val : $val
203             );
204             }
205              
206             sub _glob_to_regexp {
207 160     160   7504 my ( $self, $glob ) = @_;
208 160         143 my $nesting;
209             my $pattern;
210              
211 160         165 while (1) {
212 318 100 100     1644 if ( $glob =~ /\G\*\*/gc ) {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
213              
214             # ** is any number of characters, including /, within a pathname
215 82         144 $pattern .= '.*?';
216             }
217             elsif ( $glob =~ /\G\*/gc ) {
218              
219             # * is zero or more characters within a filename/directory name
220 54         53 $pattern .= '[^/]*';
221             }
222             elsif ( $glob =~ /\G\?/gc ) {
223              
224             # ? is exactly one character within a filename/directory name
225 1         2 $pattern .= '[^/]';
226             }
227             elsif ( $glob =~ /\G\{/gc ) {
228              
229             # {foo,bar,baz} is any of foo, bar or baz.
230 15         14 $pattern .= '(?:';
231 15         12 ++$nesting;
232             }
233             elsif ( $nesting and $glob =~ /\G,/gc ) {
234              
235             # , is only special inside {}
236 18         16 $pattern .= '|';
237             }
238             elsif ( $nesting and $glob =~ /\G\}/gc ) {
239              
240             # } that matches { is special. But unbalanced } are not.
241 15         13 $pattern .= ')';
242 15         10 --$nesting;
243             }
244             elsif ( $glob =~ /\G(\\.)/gc ) {
245              
246             # A quoted literal
247 3         3 $pattern .= $1;
248             }
249             elsif ( $glob =~ /\G([\},])/gc ) {
250              
251             # Sometimes meta characters
252 8         12 $pattern .= '\\' . $1;
253             }
254             else {
255              
256             # Eat everything that is not a meta character.
257 122         188 $glob =~ /\G([^{?*\\\},]*)/gc;
258 122         199 $pattern .= quotemeta $1;
259             }
260 318 100       843 return $pattern if pos $glob == length $glob;
261             }
262             }
263              
264             sub _expand {
265 140     140   173 my ( $self, $name, $tests ) = @_;
266              
267 140         277 my $pattern = $self->_glob_to_regexp($name);
268 140         1637 $pattern = qr/^ $pattern $/x;
269 140         216 my @match = ();
270              
271 140         340 for ( my $ti = 0; $ti < @$tests; $ti++ ) {
272 3567 100       4911 if ( $tests->[$ti]->filename =~ $pattern ) {
273 414         484 push @match, splice @$tests, $ti, 1;
274 414         637 $ti--;
275             }
276             }
277              
278 140         551 return @match;
279             }
280              
281             =head2 Instance Methods
282              
283             =head3 C
284              
285             Get a list of all remaining tests.
286              
287             =cut
288              
289             sub get_all {
290 181     181 1 251 my $self = shift;
291 181         442 my @all = $self->_gather( $self->{schedule} );
292 181         280 $self->{count} = @all;
293 181         430 @all;
294             }
295              
296             sub _gather {
297 712     712   536 my ( $self, $rule ) = @_;
298 712 50       913 return unless defined $rule;
299 712 100       1353 return $rule unless 'ARRAY' eq ref $rule;
300 264 100       333 return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
  581         884  
  396         563  
301             }
302              
303             =head3 C
304              
305             Return the next available job as L object or
306             C if none are available. Returns a L if
307             the scheduler still has pending jobs but none are available to run right now.
308              
309             =cut
310              
311             sub get_job {
312 601     601 1 98491 my $self = shift;
313 601   100     1577 $self->{count} ||= $self->get_all;
314 601         1176 my @jobs = $self->_find_next_job( $self->{schedule} );
315 601 100       1050 if (@jobs) {
316 448         463 --$self->{count};
317 448         1012 return $jobs[0];
318             }
319              
320             return TAP::Parser::Scheduler::Spinner->new
321 153 100       448 if $self->{count};
322              
323 92         283 return;
324             }
325              
326             sub _not_empty {
327 23666     23666   18734 my $ar = shift;
328 23666 100       81815 return 1 unless 'ARRAY' eq ref $ar;
329 13293         13241 for (@$ar) {
330 13276 100       14226 return 1 if _not_empty($_);
331             }
332 67         152 return;
333             }
334              
335 10390     10390   11879 sub _is_empty { !_not_empty(@_) }
336              
337             sub _find_next_job {
338 4167     4167   3666 my ( $self, $rule ) = @_;
339              
340 4167         3709 my @queue = ();
341 4167         2945 my $index = 0;
342 4167         6242 while ( $index < @$rule ) {
343 10508         8968 my $seq = $rule->[$index];
344              
345             # Prune any exhausted items.
346 10508   100     20266 shift @$seq while @$seq && _is_empty( $seq->[0] );
347 10508 100       14980 if (@$seq) {
348 10373 100       15465 if ( defined $seq->[0] ) {
349 6991 100       10367 if ( 'ARRAY' eq ref $seq->[0] ) {
350 6543         6052 push @queue, $seq;
351             }
352             else {
353 448         868 my $job = splice @$seq, 0, 1, undef;
354 448     427   2566 $job->on_finish( sub { shift @$seq } );
  427         2280  
355 448         1254 return $job;
356             }
357             }
358 9925         15833 ++$index;
359             }
360             else {
361              
362             # Remove the empty sub-array from the array
363 135         403 splice @$rule, $index, 1;
364             }
365             }
366              
367 3719         3831 for my $seq (@queue) {
368 3566 100       5198 if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
369 309         833 return @jobs;
370             }
371             }
372              
373 3410         7328 return;
374             }
375              
376             =head3 C
377              
378             Return a human readable representation of the scheduling tree.
379             For example:
380              
381             my @tests = (qw{
382             t/startup/foo.t
383             t/shutdown/foo.t
384            
385             t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
386             });
387             my $sched = TAP::Parser::Scheduler->new(
388             tests => \@tests,
389             rules => {
390             seq => [
391             { seq => 't/startup/*.t' },
392             { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
393             { seq => 't/shutdown/*.t' },
394             ],
395             },
396             );
397              
398             Produces:
399              
400             par:
401             seq:
402             par:
403             seq:
404             par:
405             seq:
406             't/startup/foo.t'
407             par:
408             seq:
409             't/a/foo.t'
410             seq:
411             't/b/foo.t'
412             seq:
413             't/c/foo.t'
414             par:
415             seq:
416             't/shutdown/foo.t'
417             't/d/foo.t'
418              
419              
420             =cut
421              
422              
423             sub as_string {
424 0     0 1   my $self = shift;
425 0           return $self->_as_string( $self->{schedule} );
426             }
427              
428             sub _as_string {
429 0   0 0     my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
430 0           my $pad = ' ' x 2;
431 0           my $indent = $pad x $depth;
432 0 0         if ( !defined $rule ) {
    0          
433 0           return "$indent(undef)\n";
434             }
435             elsif ( 'ARRAY' eq ref $rule ) {
436 0 0         return unless @$rule;
437 0           my $type = ( 'par', 'seq' )[ $depth % 2 ];
438             return join(
439             '', "$indent$type:\n",
440 0           map { $self->_as_string( $_, $depth + 1 ) } @$rule
  0            
441             );
442             }
443             else {
444 0           return "$indent'" . $rule->filename . "'\n";
445             }
446             }
447              
448             1;