1package TAP::Parser::Scheduler;
2
3use strict;
4use vars qw($VERSION);
5use Carp;
6use TAP::Parser::Scheduler::Job;
7use TAP::Parser::Scheduler::Spinner;
8
9=head1 NAME
10
11TAP::Parser::Scheduler - Schedule tests during parallel testing
12
13=head1 VERSION
14
15Version 3.17
16
17=cut
18
19$VERSION = '3.17';
20
21=head1 SYNOPSIS
22
23    use TAP::Parser::Scheduler;
24
25=head1 DESCRIPTION
26
27=head1 METHODS
28
29=head2 Class Methods
30
31=head3 C<new>
32
33    my $sched = TAP::Parser::Scheduler->new;
34
35Returns a new C<TAP::Parser::Scheduler> object.
36
37=cut
38
39sub new {
40    my $class = shift;
41
42    croak "Need a number of key, value pairs" if @_ % 2;
43
44    my %args  = @_;
45    my $tests = delete $args{tests} || croak "Need a 'tests' argument";
46    my $rules = delete $args{rules} || { par => '**' };
47
48    croak "Unknown arg(s): ", join ', ', sort keys %args
49      if keys %args;
50
51    # Turn any simple names into a name, description pair. TODO: Maybe
52    # construct jobs here?
53    my $self = bless {}, $class;
54
55    $self->_set_rules( $rules, $tests );
56
57    return $self;
58}
59
60# Build the scheduler data structure.
61#
62# SCHEDULER-DATA ::= JOB
63#                ||  ARRAY OF ARRAY OF SCHEDULER-DATA
64#
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.
70
71sub _set_rules {
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 );
76
77    # If any tests are left add them as a sequential block at the end of
78    # the run.
79    $schedule = [ [ $schedule, @tests ] ] if @tests;
80
81    $self->{schedule} = $schedule;
82}
83
84sub _rule_clause {
85    my ( $self, $rule, $tests ) = @_;
86    croak 'Rule clause must be a hash'
87      unless 'HASH' eq ref $rule;
88
89    my @type = keys %$rule;
90    croak 'Rule clause must have exactly one key'
91      unless @type == 1;
92
93    my %handlers = (
94        par => sub {
95            [ map { [$_] } @_ ];
96        },
97        seq => sub { [ [@_] ] },
98    );
99
100    my $handler = $handlers{ $type[0] }
101      || croak 'Unknown scheduler type: ', $type[0];
102    my $val = $rule->{ $type[0] };
103
104    return $handler->(
105        map {
106            'HASH' eq ref $_
107              ? $self->_rule_clause( $_, $tests )
108              : $self->_expand( $_, $tests )
109          } 'ARRAY' eq ref $val ? @$val : $val
110    );
111}
112
113sub _glob_to_regexp {
114    my ( $self, $glob ) = @_;
115    my $nesting;
116    my $pattern;
117
118    while (1) {
119        if ( $glob =~ /\G\*\*/gc ) {
120
121            # ** is any number of characters, including /, within a pathname
122            $pattern .= '.*?';
123        }
124        elsif ( $glob =~ /\G\*/gc ) {
125
126            # * is zero or more characters within a filename/directory name
127            $pattern .= '[^/]*';
128        }
129        elsif ( $glob =~ /\G\?/gc ) {
130
131            # ? is exactly one character within a filename/directory name
132            $pattern .= '[^/]';
133        }
134        elsif ( $glob =~ /\G\{/gc ) {
135
136            # {foo,bar,baz} is any of foo, bar or baz.
137            $pattern .= '(?:';
138            ++$nesting;
139        }
140        elsif ( $nesting and $glob =~ /\G,/gc ) {
141
142            # , is only special inside {}
143            $pattern .= '|';
144        }
145        elsif ( $nesting and $glob =~ /\G\}/gc ) {
146
147            # } that matches { is special. But unbalanced } are not.
148            $pattern .= ')';
149            --$nesting;
150        }
151        elsif ( $glob =~ /\G(\\.)/gc ) {
152
153            # A quoted literal
154            $pattern .= $1;
155        }
156        elsif ( $glob =~ /\G([\},])/gc ) {
157
158            # Sometimes meta characters
159            $pattern .= '\\' . $1;
160        }
161        else {
162
163            # Eat everything that is not a meta character.
164            $glob =~ /\G([^{?*\\\},]*)/gc;
165            $pattern .= quotemeta $1;
166        }
167        return $pattern if pos $glob == length $glob;
168    }
169}
170
171sub _expand {
172    my ( $self, $name, $tests ) = @_;
173
174    my $pattern = $self->_glob_to_regexp($name);
175    $pattern = qr/^ $pattern $/x;
176    my @match = ();
177
178    for ( my $ti = 0; $ti < @$tests; $ti++ ) {
179        if ( $tests->[$ti]->filename =~ $pattern ) {
180            push @match, splice @$tests, $ti, 1;
181            $ti--;
182        }
183    }
184
185    return @match;
186}
187
188=head3 C<get_all>
189
190Get a list of all remaining tests.
191
192=cut
193
194sub get_all {
195    my $self = shift;
196    my @all  = $self->_gather( $self->{schedule} );
197    $self->{count} = @all;
198    @all;
199}
200
201sub _gather {
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;
206}
207
208=head3 C<get_job>
209
210Return the next available job or C<undef> if none are available. Returns
211a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
212jobs but none are available to run right now.
213
214=cut
215
216sub get_job {
217    my $self = shift;
218    $self->{count} ||= $self->get_all;
219    my @jobs = $self->_find_next_job( $self->{schedule} );
220    if (@jobs) {
221        --$self->{count};
222        return $jobs[0];
223    }
224
225    return TAP::Parser::Scheduler::Spinner->new
226      if $self->{count};
227
228    return;
229}
230
231sub _not_empty {
232    my $ar = shift;
233    return 1 unless 'ARRAY' eq ref $ar;
234    foreach (@$ar) {
235        return 1 if _not_empty($_);
236    }
237    return;
238}
239
240sub _is_empty { !_not_empty(@_) }
241
242sub _find_next_job {
243    my ( $self, $rule ) = @_;
244
245    my @queue = ();
246    my $index = 0;
247    while ( $index < @$rule ) {
248        my $seq = $rule->[$index];
249
250        # Prune any exhausted items.
251        shift @$seq while @$seq && _is_empty( $seq->[0] );
252        if (@$seq) {
253            if ( defined $seq->[0] ) {
254                if ( 'ARRAY' eq ref $seq->[0] ) {
255                    push @queue, $seq;
256                }
257                else {
258                    my $job = splice @$seq, 0, 1, undef;
259                    $job->on_finish( sub { shift @$seq } );
260                    return $job;
261                }
262            }
263            ++$index;
264        }
265        else {
266
267            # Remove the empty sub-array from the array
268            splice @$rule, $index, 1;
269        }
270    }
271
272    for my $seq (@queue) {
273        if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
274            return @jobs;
275        }
276    }
277
278    return;
279}
280
281=head3 C<as_string>
282
283Return a human readable representation of the scheduling tree.
284
285=cut
286
287sub as_string {
288    my $self = shift;
289    return $self->_as_string( $self->{schedule} );
290}
291
292sub _as_string {
293    my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
294    my $pad    = ' ' x 2;
295    my $indent = $pad x $depth;
296    if ( !defined $rule ) {
297        return "$indent(undef)\n";
298    }
299    elsif ( 'ARRAY' eq ref $rule ) {
300        return unless @$rule;
301        my $type = ( 'par', 'seq' )[ $depth % 2 ];
302        return join(
303            '', "$indent$type:\n",
304            map { $self->_as_string( $_, $depth + 1 ) } @$rule
305        );
306    }
307    else {
308        return "$indent'" . $rule->filename . "'\n";
309    }
310}
311
3121;
313