ext/Test-Harness/lib/TAP/Parser/Scheduler.pm

   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;