"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm" (10 Mar 2019, 11543 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package TAP::Parser::Scheduler;
    2 
    3 use strict;
    4 use warnings;
    5 
    6 use Carp;
    7 use TAP::Parser::Scheduler::Job;
    8 use TAP::Parser::Scheduler::Spinner;
    9 
   10 =head1 NAME
   11 
   12 TAP::Parser::Scheduler - Schedule tests during parallel testing
   13 
   14 =head1 VERSION
   15 
   16 Version 3.42
   17 
   18 =cut
   19 
   20 our $VERSION = '3.42';
   21 
   22 =head1 SYNOPSIS
   23 
   24     use TAP::Parser::Scheduler;
   25 
   26 =head1 DESCRIPTION
   27 
   28 =head1 METHODS
   29 
   30 =head2 Class Methods
   31 
   32 =head3 C<new>
   33 
   34     my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
   35     my $sched = TAP::Parser::Scheduler->new(
   36         tests => [ ['t/test_name.t','Test Description'], ... ],
   37         rules => \%rules,
   38     );
   39 
   40 Given 'tests' and optional 'rules' as input, returns a new
   41 C<TAP::Parser::Scheduler> object.  Each member of C<@tests> should be either a
   42 a test file name, or a two element arrayref, where the first element is a test
   43 file name, and the second element is a test description. By default, we'll use
   44 the test name as the description.
   45 
   46 The optional C<rules> attribute provides direction on which tests should be run
   47 in parallel and which should be run sequentially. If no rule data structure is
   48 provided, a default data structure is used which makes every test eligible to
   49 be run in parallel:
   50 
   51     { par => '**' },
   52 
   53 The rules data structure is documented more in the next section.
   54 
   55 =head2 Rules data structure
   56 
   57 The "C<rules>" data structure is the the heart of the scheduler. It allows you
   58 to express simple rules like "run all tests in sequence" or "run all tests in
   59 parallel except these five tests.". However, the rules structure also supports
   60 glob-style pattern matching and recursive definitions, so you can also express
   61 arbitarily complicated patterns.
   62 
   63 The rule must only have one top level key: either 'par' for "parallel" or 'seq'
   64 for "sequence".
   65 
   66 Values must be either strings with possible glob-style matching, or arrayrefs
   67 of strings or hashrefs which follow this pattern recursively.
   68 
   69 Every element in an arrayref directly below a 'par' key is eligible to be run
   70 in parallel, while vavalues directly below a 'seq' key must be run in sequence.
   71 
   72 =head3 Rules examples
   73 
   74 Here are some examples:
   75 
   76     # All tests be run in parallel (the default rule)
   77     { par => '**' },
   78 
   79     # Run all tests in sequence, except those starting with "p"
   80     { par => 't/p*.t' },
   81 
   82     # Run all tests in parallel, except those starting with "p"
   83     {
   84         seq => [
   85                   { seq => 't/p*.t' },
   86                   { par => '**'     },
   87                ],
   88     }
   89 
   90     # Run some  startup tests in sequence, then some parallel tests then some
   91     # teardown tests in sequence.
   92     {
   93         seq => [
   94             { seq => 't/startup/*.t' },
   95             { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
   96             { seq => 't/shutdown/*.t' },
   97         ],
   98     },
   99 
  100 
  101 =head3 Rules resolution
  102 
  103 =over 4
  104 
  105 =item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
  106 
  107 =item * "First match wins". The first rule that matches a test will be the one that applies.
  108 
  109 =item * Any test which does not match a rule will be run in sequence at the end of the run.
  110 
  111 =item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
  112 
  113 =item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
  114 
  115 =back
  116 
  117 =head3 Glob-style pattern matching for rules
  118 
  119 We implement our own glob-style pattern matching. Here are the patterns it supports:
  120 
  121     ** is any number of characters, including /, within a pathname
  122     * is zero or more characters within a filename/directory name
  123     ? is exactly one character within a filename/directory name
  124     {foo,bar,baz} is any of foo, bar or baz.
  125     \ is an escape character
  126 
  127 =cut
  128 
  129 sub new {
  130     my $class = shift;
  131 
  132     croak "Need a number of key, value pairs" if @_ % 2;
  133 
  134     my %args  = @_;
  135     my $tests = delete $args{tests} || croak "Need a 'tests' argument";
  136     my $rules = delete $args{rules} || { par => '**' };
  137 
  138     croak "Unknown arg(s): ", join ', ', sort keys %args
  139       if keys %args;
  140 
  141     # Turn any simple names into a name, description pair. TODO: Maybe
  142     # construct jobs here?
  143     my $self = bless {}, $class;
  144 
  145     $self->_set_rules( $rules, $tests );
  146 
  147     return $self;
  148 }
  149 
  150 # Build the scheduler data structure.
  151 #
  152 # SCHEDULER-DATA ::= JOB
  153 #                ||  ARRAY OF ARRAY OF SCHEDULER-DATA
  154 #
  155 # The nested arrays are the key to scheduling. The outer array contains
  156 # a list of things that may be executed in parallel. Whenever an
  157 # eligible job is sought any element of the outer array that is ready to
  158 # execute can be selected. The inner arrays represent sequential
  159 # execution. They can only proceed when the first job is ready to run.
  160 
  161 sub _set_rules {
  162     my ( $self, $rules, $tests ) = @_;
  163 
  164     # Convert all incoming tests to job objects. 
  165     # If no test description is provided use the file name as the description. 
  166     my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
  167       map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
  168     my $schedule = $self->_rule_clause( $rules, \@tests );
  169 
  170     # If any tests are left add them as a sequential block at the end of
  171     # the run.
  172     $schedule = [ [ $schedule, @tests ] ] if @tests;
  173 
  174     $self->{schedule} = $schedule;
  175 }
  176 
  177 sub _rule_clause {
  178     my ( $self, $rule, $tests ) = @_;
  179     croak 'Rule clause must be a hash'
  180       unless 'HASH' eq ref $rule;
  181 
  182     my @type = keys %$rule;
  183     croak 'Rule clause must have exactly one key'
  184       unless @type == 1;
  185 
  186     my %handlers = (
  187         par => sub {
  188             [ map { [$_] } @_ ];
  189         },
  190         seq => sub { [ [@_] ] },
  191     );
  192 
  193     my $handler = $handlers{ $type[0] }
  194       || croak 'Unknown scheduler type: ', $type[0];
  195     my $val = $rule->{ $type[0] };
  196 
  197     return $handler->(
  198         map {
  199             'HASH' eq ref $_
  200               ? $self->_rule_clause( $_, $tests )
  201               : $self->_expand( $_, $tests )
  202           } 'ARRAY' eq ref $val ? @$val : $val
  203     );
  204 }
  205 
  206 sub _glob_to_regexp {
  207     my ( $self, $glob ) = @_;
  208     my $nesting;
  209     my $pattern;
  210 
  211     while (1) {
  212         if ( $glob =~ /\G\*\*/gc ) {
  213 
  214             # ** is any number of characters, including /, within a pathname
  215             $pattern .= '.*?';
  216         }
  217         elsif ( $glob =~ /\G\*/gc ) {
  218 
  219             # * is zero or more characters within a filename/directory name
  220             $pattern .= '[^/]*';
  221         }
  222         elsif ( $glob =~ /\G\?/gc ) {
  223 
  224             # ? is exactly one character within a filename/directory name
  225             $pattern .= '[^/]';
  226         }
  227         elsif ( $glob =~ /\G\{/gc ) {
  228 
  229             # {foo,bar,baz} is any of foo, bar or baz.
  230             $pattern .= '(?:';
  231             ++$nesting;
  232         }
  233         elsif ( $nesting and $glob =~ /\G,/gc ) {
  234 
  235             # , is only special inside {}
  236             $pattern .= '|';
  237         }
  238         elsif ( $nesting and $glob =~ /\G\}/gc ) {
  239 
  240             # } that matches { is special. But unbalanced } are not.
  241             $pattern .= ')';
  242             --$nesting;
  243         }
  244         elsif ( $glob =~ /\G(\\.)/gc ) {
  245 
  246             # A quoted literal
  247             $pattern .= $1;
  248         }
  249         elsif ( $glob =~ /\G([\},])/gc ) {
  250 
  251             # Sometimes meta characters
  252             $pattern .= '\\' . $1;
  253         }
  254         else {
  255 
  256             # Eat everything that is not a meta character.
  257             $glob =~ /\G([^{?*\\\},]*)/gc;
  258             $pattern .= quotemeta $1;
  259         }
  260         return $pattern if pos $glob == length $glob;
  261     }
  262 }
  263 
  264 sub _expand {
  265     my ( $self, $name, $tests ) = @_;
  266 
  267     my $pattern = $self->_glob_to_regexp($name);
  268     $pattern = qr/^ $pattern $/x;
  269     my @match = ();
  270 
  271     for ( my $ti = 0; $ti < @$tests; $ti++ ) {
  272         if ( $tests->[$ti]->filename =~ $pattern ) {
  273             push @match, splice @$tests, $ti, 1;
  274             $ti--;
  275         }
  276     }
  277 
  278     return @match;
  279 }
  280 
  281 =head2 Instance Methods
  282 
  283 =head3 C<get_all>
  284 
  285 Get a list of all remaining tests.
  286 
  287 =cut
  288 
  289 sub get_all {
  290     my $self = shift;
  291     my @all  = $self->_gather( $self->{schedule} );
  292     $self->{count} = @all;
  293     @all;
  294 }
  295 
  296 sub _gather {
  297     my ( $self, $rule ) = @_;
  298     return unless defined $rule;
  299     return $rule unless 'ARRAY' eq ref $rule;
  300     return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
  301 }
  302 
  303 =head3 C<get_job>
  304 
  305 Return the next available job as L<TAP::Parser::Scheduler::Job> object or
  306 C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if
  307 the scheduler still has pending jobs but none are available to run right now.
  308 
  309 =cut
  310 
  311 sub get_job {
  312     my $self = shift;
  313     $self->{count} ||= $self->get_all;
  314     my @jobs = $self->_find_next_job( $self->{schedule} );
  315     if (@jobs) {
  316         --$self->{count};
  317         return $jobs[0];
  318     }
  319 
  320     return TAP::Parser::Scheduler::Spinner->new
  321       if $self->{count};
  322 
  323     return;
  324 }
  325 
  326 sub _not_empty {
  327     my $ar = shift;
  328     return 1 unless 'ARRAY' eq ref $ar;
  329     for (@$ar) {
  330         return 1 if _not_empty($_);
  331     }
  332     return;
  333 }
  334 
  335 sub _is_empty { !_not_empty(@_) }
  336 
  337 sub _find_next_job {
  338     my ( $self, $rule ) = @_;
  339 
  340     my @queue = ();
  341     my $index = 0;
  342     while ( $index < @$rule ) {
  343         my $seq = $rule->[$index];
  344 
  345         # Prune any exhausted items.
  346         shift @$seq while @$seq && _is_empty( $seq->[0] );
  347         if (@$seq) {
  348             if ( defined $seq->[0] ) {
  349                 if ( 'ARRAY' eq ref $seq->[0] ) {
  350                     push @queue, $seq;
  351                 }
  352                 else {
  353                     my $job = splice @$seq, 0, 1, undef;
  354                     $job->on_finish( sub { shift @$seq } );
  355                     return $job;
  356                 }
  357             }
  358             ++$index;
  359         }
  360         else {
  361 
  362             # Remove the empty sub-array from the array
  363             splice @$rule, $index, 1;
  364         }
  365     }
  366 
  367     for my $seq (@queue) {
  368         if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
  369             return @jobs;
  370         }
  371     }
  372 
  373     return;
  374 }
  375 
  376 =head3 C<as_string>
  377 
  378 Return a human readable representation of the scheduling tree.
  379 For example:
  380 
  381     my @tests = (qw{
  382         t/startup/foo.t 
  383         t/shutdown/foo.t
  384     
  385         t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
  386     });
  387     my $sched = TAP::Parser::Scheduler->new(
  388         tests => \@tests,
  389         rules => {
  390             seq => [
  391                 { seq => 't/startup/*.t' },
  392                 { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
  393                 { seq => 't/shutdown/*.t' },
  394             ],
  395         },
  396     );
  397 
  398 Produces:
  399 
  400     par:
  401       seq:
  402         par:
  403           seq:
  404             par:
  405               seq:
  406                 't/startup/foo.t'
  407             par:
  408               seq:
  409                 't/a/foo.t'
  410               seq:
  411                 't/b/foo.t'
  412               seq:
  413                 't/c/foo.t'
  414             par:
  415               seq:
  416                 't/shutdown/foo.t'
  417         't/d/foo.t'
  418 
  419 
  420 =cut
  421 
  422 
  423 sub as_string {
  424     my $self = shift;
  425     return $self->_as_string( $self->{schedule} );
  426 }
  427 
  428 sub _as_string {
  429     my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
  430     my $pad    = ' ' x 2;
  431     my $indent = $pad x $depth;
  432     if ( !defined $rule ) {
  433         return "$indent(undef)\n";
  434     }
  435     elsif ( 'ARRAY' eq ref $rule ) {
  436         return unless @$rule;
  437         my $type = ( 'par', 'seq' )[ $depth % 2 ];
  438         return join(
  439             '', "$indent$type:\n",
  440             map { $self->_as_string( $_, $depth + 1 ) } @$rule
  441         );
  442     }
  443     else {
  444         return "$indent'" . $rule->filename . "'\n";
  445     }
  446 }
  447 
  448 1;