Commit | Line | Data |
3fea05b9 |
1 | package TAP::Parser::Scheduler; |
2 | |
3 | use strict; |
4 | use vars qw($VERSION); |
5 | use Carp; |
6 | use TAP::Parser::Scheduler::Job; |
7 | use TAP::Parser::Scheduler::Spinner; |
8 | |
9 | =head1 NAME |
10 | |
11 | TAP::Parser::Scheduler - Schedule tests during parallel testing |
12 | |
13 | =head1 VERSION |
14 | |
15 | Version 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 | |
35 | Returns a new C<TAP::Parser::Scheduler> object. |
36 | |
37 | =cut |
38 | |
39 | sub 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 | |
71 | sub _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 | |
84 | sub _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 | |
113 | sub _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 | |
171 | sub _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 | |
190 | Get a list of all remaining tests. |
191 | |
192 | =cut |
193 | |
194 | sub get_all { |
195 | my $self = shift; |
196 | my @all = $self->_gather( $self->{schedule} ); |
197 | $self->{count} = @all; |
198 | @all; |
199 | } |
200 | |
201 | sub _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 | |
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. |
213 | |
214 | =cut |
215 | |
216 | sub 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 | |
231 | sub _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 | |
240 | sub _is_empty { !_not_empty(@_) } |
241 | |
242 | sub _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 | |
283 | Return a human readable representation of the scheduling tree. |
284 | |
285 | =cut |
286 | |
287 | sub as_string { |
288 | my $self = shift; |
289 | return $self->_as_string( $self->{schedule} ); |
290 | } |
291 | |
292 | sub _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 | |
312 | 1; |