1 package TAP::Parser::Scheduler;
6 use TAP::Parser::Scheduler::Job;
7 use TAP::Parser::Scheduler::Spinner;
11 TAP::Parser::Scheduler - Schedule tests during parallel testing
23 use TAP::Parser::Scheduler;
33 my $sched = TAP::Parser::Scheduler->new;
35 Returns a new C<TAP::Parser::Scheduler> object.
42 croak "Need a number of key, value pairs" if @_ % 2;
45 my $tests = delete $args{tests} || croak "Need a 'tests' argument";
46 my $rules = delete $args{rules} || { par => '**' };
48 croak "Unknown arg(s): ", join ', ', sort keys %args
51 # Turn any simple names into a name, description pair. TODO: Maybe
52 # construct jobs here?
53 my $self = bless {}, $class;
55 $self->_set_rules( $rules, $tests );
60 # Build the scheduler data structure.
62 # SCHEDULER-DATA ::= JOB
63 # || ARRAY OF ARRAY OF SCHEDULER-DATA
65 # The nested arrays are the key to scheduling. The outer array contains
66 # a list of things that may be executed in parallel. Whenever an
67 # eligible job is sought any element of the outer array that is ready to
68 # execute can be selected. The inner arrays represent sequential
69 # execution. They can only proceed when the first job is ready to run.
72 my ( $self, $rules, $tests ) = @_;
73 my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
74 map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
75 my $schedule = $self->_rule_clause( $rules, \@tests );
77 # If any tests are left add them as a sequential block at the end of
79 $schedule = [ [ $schedule, @tests ] ] if @tests;
81 $self->{schedule} = $schedule;
85 my ( $self, $rule, $tests ) = @_;
86 croak 'Rule clause must be a hash'
87 unless 'HASH' eq ref $rule;
89 my @type = keys %$rule;
90 croak 'Rule clause must have exactly one key'
97 seq => sub { [ [@_] ] },
100 my $handler = $handlers{ $type[0] }
101 || croak 'Unknown scheduler type: ', $type[0];
102 my $val = $rule->{ $type[0] };
107 ? $self->_rule_clause( $_, $tests )
108 : $self->_expand( $_, $tests )
109 } 'ARRAY' eq ref $val ? @$val : $val
113 sub _glob_to_regexp {
114 my ( $self, $glob ) = @_;
119 if ( $glob =~ /\G\*\*/gc ) {
121 # ** is any number of characters, including /, within a pathname
124 elsif ( $glob =~ /\G\*/gc ) {
126 # * is zero or more characters within a filename/directory name
129 elsif ( $glob =~ /\G\?/gc ) {
131 # ? is exactly one character within a filename/directory name
134 elsif ( $glob =~ /\G\{/gc ) {
136 # {foo,bar,baz} is any of foo, bar or baz.
140 elsif ( $nesting and $glob =~ /\G,/gc ) {
142 # , is only special inside {}
145 elsif ( $nesting and $glob =~ /\G\}/gc ) {
147 # } that matches { is special. But unbalanced } are not.
151 elsif ( $glob =~ /\G(\\.)/gc ) {
156 elsif ( $glob =~ /\G([\},])/gc ) {
158 # Sometimes meta characters
159 $pattern .= '\\' . $1;
163 # Eat everything that is not a meta character.
164 $glob =~ /\G([^{?*\\\},]*)/gc;
165 $pattern .= quotemeta $1;
167 return $pattern if pos $glob == length $glob;
172 my ( $self, $name, $tests ) = @_;
174 my $pattern = $self->_glob_to_regexp($name);
175 $pattern = qr/^ $pattern $/x;
178 for ( my $ti = 0; $ti < @$tests; $ti++ ) {
179 if ( $tests->[$ti]->filename =~ $pattern ) {
180 push @match, splice @$tests, $ti, 1;
190 Get a list of all remaining tests.
196 my @all = $self->_gather( $self->{schedule} );
197 $self->{count} = @all;
202 my ( $self, $rule ) = @_;
203 return unless defined $rule;
204 return $rule unless 'ARRAY' eq ref $rule;
205 return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
210 Return the next available job or C<undef> if none are available. Returns
211 a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
212 jobs but none are available to run right now.
218 $self->{count} ||= $self->get_all;
219 my @jobs = $self->_find_next_job( $self->{schedule} );
225 return TAP::Parser::Scheduler::Spinner->new
233 return 1 unless 'ARRAY' eq ref $ar;
235 return 1 if _not_empty($_);
240 sub _is_empty { !_not_empty(@_) }
243 my ( $self, $rule ) = @_;
247 while ( $index < @$rule ) {
248 my $seq = $rule->[$index];
250 # Prune any exhausted items.
251 shift @$seq while @$seq && _is_empty( $seq->[0] );
253 if ( defined $seq->[0] ) {
254 if ( 'ARRAY' eq ref $seq->[0] ) {
258 my $job = splice @$seq, 0, 1, undef;
259 $job->on_finish( sub { shift @$seq } );
267 # Remove the empty sub-array from the array
268 splice @$rule, $index, 1;
272 for my $seq (@queue) {
273 if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
283 Return a human readable representation of the scheduling tree.
289 return $self->_as_string( $self->{schedule} );
293 my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
295 my $indent = $pad x $depth;
296 if ( !defined $rule ) {
297 return "$indent(undef)\n";
299 elsif ( 'ARRAY' eq ref $rule ) {
300 return unless @$rule;
301 my $type = ( 'par', 'seq' )[ $depth % 2 ];
303 '', "$indent$type:\n",
304 map { $self->_as_string( $_, $depth + 1 ) } @$rule
308 return "$indent'" . $rule->filename . "'\n";