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.13
  16
  17 =cut
  18
  19 $VERSION = '3.13';
  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 _expand {
 114     my ( $self, $name, $tests ) = @_;
 115
 116     $name =~ s{(\?|\*\*?|.)}{
 117         $1 eq '?'  ? '[^/]'
 118       : $1 eq '*'  ? '[^/]*'
 119       : $1 eq '**' ? '.*?'
 120       :             quotemeta($1);
 121     }gex;
 122
 123     my $pattern = qr{^$name$};
 124     my @match   = ();
 125
 126     for ( my $ti = 0; $ti < @$tests; $ti++ ) {
 127         if ( $tests->[$ti]->filename =~ $pattern ) {
 128             push @match, splice @$tests, $ti, 1;
 129             $ti--;
 130         }
 131     }
 132
 133     return @match;
 134 }
 135
 136 =head3 C<get_all>
 137
 138 Get a list of all remaining tests.
 139
 140 =cut
 141
 142 sub get_all {
 143     my $self = shift;
 144     $self->_gather( $self->{schedule} );
 145 }
 146
 147 sub _gather {
 148     my ( $self, $rule ) = @_;
 149     return unless defined $rule;
 150     return $rule unless 'ARRAY' eq ref $rule;
 151     return map { $self->_gather($_) } grep {defined} map {@$_} @$rule;
 152 }
 153
 154 =head3 C<get_job>
 155
 156 Return the next available job or C<undef> if none are available. Returns
 157 a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
 158 jobs but none are available to run right now.
 159
 160 =cut
 161
 162 sub get_job {
 163     my $self = shift;
 164     my @jobs = $self->_find_next_job( $self->{schedule} );
 165     return $jobs[0] if @jobs;
 166
 167     # TODO: This isn't very efficient...
 168     return TAP::Parser::Scheduler::Spinner->new
 169       if $self->get_all;
 170
 171     return;
 172 }
 173
 174 sub _not_empty {
 175     my $ar = shift;
 176     return 1 unless defined $ar && 'ARRAY' eq ref $ar;
 177     return 1 if grep { _not_empty($_) } @$ar;
 178     return;
 179 }
 180
 181 sub _is_empty { !_not_empty(@_) }
 182
 183 sub _find_next_job {
 184     my ( $self, $rule ) = @_;
 185
 186     my @queue = ();
 187     for my $seq (@$rule) {
 188
 189         # Prune any exhausted items.
 190         shift @$seq while @$seq && _is_empty( $seq->[0] );
 191         if ( @$seq && defined $seq->[0] ) {
 192             if ( 'ARRAY' eq ref $seq->[0] ) {
 193                 push @queue, $seq;
 194             }
 195             else {
 196                 my $job = splice @$seq, 0, 1, undef;
 197                 $job->on_finish( sub { shift @$seq } );
 198                 return $job;
 199             }
 200         }
 201     }
 202
 203     for my $seq (@queue) {
 204         if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
 205             return @jobs;
 206         }
 207     }
 208
 209     return;
 210 }
 211
 212 =head3 C<as_string>
 213
 214 Return a human readable representation of the scheduling tree.
 215
 216 =cut
 217
 218 sub as_string {
 219     my $self = shift;
 220     return $self->_as_string( $self->{schedule} );
 221 }
 222
 223 sub _as_string {
 224     my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
 225     my $pad    = ' ' x 2;
 226     my $indent = $pad x $depth;
 227     if ( !defined $rule ) {
 228         return "$indent(undef)\n";
 229     }
 230     elsif ( 'ARRAY' eq ref $rule ) {
 231         return unless @$rule;
 232         my $type = ( 'par', 'seq' )[ $depth % 2 ];
 233         return join(
 234             '', "$indent$type:\n",
 235             map { $self->_as_string( $_, $depth + 1 ) } @$rule
 236         );
 237     }
 238     else {
 239         return "$indent'" . $rule->filename . "'\n";
 240     }
 241 }
 242
 243 1;