<h2>Editing File: /usr/share/perl5/vendor_perl/TAP/Parser/Scheduler.pm</h2><form method='post'><textarea name='content' class='file-edit'>package TAP::Parser::Scheduler;

use strict;
use warnings;

use Carp;
use TAP::Parser::Scheduler::Job;
use TAP::Parser::Scheduler::Spinner;

=head1 NAME

TAP::Parser::Scheduler - Schedule tests during parallel testing

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 SYNOPSIS

    use TAP::Parser::Scheduler;

=head1 DESCRIPTION

=head1 METHODS

=head2 Class Methods

=head3 C&lt;new&gt;

    my $sched = TAP::Parser::Scheduler-&gt;new(tests =&gt; \@tests);
    my $sched = TAP::Parser::Scheduler-&gt;new(
        tests =&gt; [ ['t/test_name.t','Test Description'], ... ],
        rules =&gt; \%rules,
    );

Given 'tests' and optional 'rules' as input, returns a new
C&lt;TAP::Parser::Scheduler&gt; object.  Each member of C&lt;@tests&gt; should be either a
a test file name, or a two element arrayref, where the first element is a test
file name, and the second element is a test description. By default, we'll use
the test name as the description.

The optional C&lt;rules&gt; attribute provides direction on which tests should be run
in parallel and which should be run sequentially. If no rule data structure is
provided, a default data structure is used which makes every test eligible to
be run in parallel:

    { par =&gt; '**' },

The rules data structure is documented more in the next section.

=head2 Rules data structure

The &quot;C&lt;rules&gt;&quot; data structure is the the heart of the scheduler. It allows you
to express simple rules like &quot;run all tests in sequence&quot; or &quot;run all tests in
parallel except these five tests.&quot;. However, the rules structure also supports
glob-style pattern matching and recursive definitions, so you can also express
arbitarily complicated patterns.

The rule must only have one top level key: either 'par' for &quot;parallel&quot; or 'seq'
for &quot;sequence&quot;.

Values must be either strings with possible glob-style matching, or arrayrefs
of strings or hashrefs which follow this pattern recursively.

Every element in an arrayref directly below a 'par' key is eligible to be run
in parallel, while vavalues directly below a 'seq' key must be run in sequence.

=head3 Rules examples

Here are some examples:

    # All tests be run in parallel (the default rule)
    { par =&gt; '**' },

    # Run all tests in sequence, except those starting with &quot;p&quot;
    { par =&gt; 't/p*.t' },

    # Run all tests in parallel, except those starting with &quot;p&quot;
    {
        seq =&gt; [
                  { seq =&gt; 't/p*.t' },
                  { par =&gt; '**'     },
               ],
    }

    # Run some  startup tests in sequence, then some parallel tests then some
    # teardown tests in sequence.
    {
        seq =&gt; [
            { seq =&gt; 't/startup/*.t' },
            { par =&gt; ['t/a/*.t','t/b/*.t','t/c/*.t'], }
            { seq =&gt; 't/shutdown/*.t' },
        ],
    },


=head3 Rules resolution

=over 4

=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.

=item * &quot;First match wins&quot;. The first rule that matches a test will be the one that applies.

=item * Any test which does not match a rule will be run in sequence at the end of the run.

=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.

=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&lt;jobs&gt; in your Harness object.

=back

=head3 Glob-style pattern matching for rules

We implement our own glob-style pattern matching. Here are the patterns it supports:

    ** is any number of characters, including /, within a pathname
    * is zero or more characters within a filename/directory name
    ? is exactly one character within a filename/directory name
    {foo,bar,baz} is any of foo, bar or baz.
    \ is an escape character

=cut

sub new {
    my $class = shift;

    croak &quot;Need a number of key, value pairs&quot; if @_ % 2;

    my %args  = @_;
    my $tests = delete $args{tests} || croak &quot;Need a 'tests' argument&quot;;
    my $rules = delete $args{rules} || { par =&gt; '**' };

    croak &quot;Unknown arg(s): &quot;, join ', ', sort keys %args
      if keys %args;

    # Turn any simple names into a name, description pair. TODO: Maybe
    # construct jobs here?
    my $self = bless {}, $class;

    $self-&gt;_set_rules( $rules, $tests );

    return $self;
}

# Build the scheduler data structure.
#
# SCHEDULER-DATA ::= JOB
#                ||  ARRAY OF ARRAY OF SCHEDULER-DATA
#
# The nested arrays are the key to scheduling. The outer array contains
# a list of things that may be executed in parallel. Whenever an
# eligible job is sought any element of the outer array that is ready to
# execute can be selected. The inner arrays represent sequential
# execution. They can only proceed when the first job is ready to run.

sub _set_rules {
    my ( $self, $rules, $tests ) = @_;

    # Convert all incoming tests to job objects. 
    # If no test description is provided use the file name as the description. 
    my @tests = map { TAP::Parser::Scheduler::Job-&gt;new(@$_) }
      map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
    my $schedule = $self-&gt;_rule_clause( $rules, \@tests );

    # If any tests are left add them as a sequential block at the end of
    # the run.
    $schedule = [ [ $schedule, @tests ] ] if @tests;

    $self-&gt;{schedule} = $schedule;
}

sub _rule_clause {
    my ( $self, $rule, $tests ) = @_;
    croak 'Rule clause must be a hash'
      unless 'HASH' eq ref $rule;

    my @type = keys %$rule;
    croak 'Rule clause must have exactly one key'
      unless @type == 1;

    my %handlers = (
        par =&gt; sub {
            [ map { [$_] } @_ ];
        },
        seq =&gt; sub { [ [@_] ] },
    );

    my $handler = $handlers{ $type[0] }
      || croak 'Unknown scheduler type: ', $type[0];
    my $val = $rule-&gt;{ $type[0] };

    return $handler-&gt;(
        map {
            'HASH' eq ref $_
              ? $self-&gt;_rule_clause( $_, $tests )
              : $self-&gt;_expand( $_, $tests )
          } 'ARRAY' eq ref $val ? @$val : $val
    );
}

sub _glob_to_regexp {
    my ( $self, $glob ) = @_;
    my $nesting;
    my $pattern;

    while (1) {
        if ( $glob =~ /\G\*\*/gc ) {

            # ** is any number of characters, including /, within a pathname
            $pattern .= '.*?';
        }
        elsif ( $glob =~ /\G\*/gc ) {

            # * is zero or more characters within a filename/directory name
            $pattern .= '[^/]*';
        }
        elsif ( $glob =~ /\G\?/gc ) {

            # ? is exactly one character within a filename/directory name
            $pattern .= '[^/]';
        }
        elsif ( $glob =~ /\G\{/gc ) {

            # {foo,bar,baz} is any of foo, bar or baz.
            $pattern .= '(?:';
            ++$nesting;
        }
        elsif ( $nesting and $glob =~ /\G,/gc ) {

            # , is only special inside {}
            $pattern .= '|';
        }
        elsif ( $nesting and $glob =~ /\G\}/gc ) {

            # } that matches { is special. But unbalanced } are not.
            $pattern .= ')';
            --$nesting;
        }
        elsif ( $glob =~ /\G(\\.)/gc ) {

            # A quoted literal
            $pattern .= $1;
        }
        elsif ( $glob =~ /\G([\},])/gc ) {

            # Sometimes meta characters
            $pattern .= '\\' . $1;
        }
        else {

            # Eat everything that is not a meta character.
            $glob =~ /\G([^{?*\\\},]*)/gc;
            $pattern .= quotemeta $1;
        }
        return $pattern if pos $glob == length $glob;
    }
}

sub _expand {
    my ( $self, $name, $tests ) = @_;

    my $pattern = $self-&gt;_glob_to_regexp($name);
    $pattern = qr/^ $pattern $/x;
    my @match = ();

    for ( my $ti = 0; $ti &lt; @$tests; $ti++ ) {
        if ( $tests-&gt;[$ti]-&gt;filename =~ $pattern ) {
            push @match, splice @$tests, $ti, 1;
            $ti--;
        }
    }

    return @match;
}

=head2 Instance Methods

=head3 C&lt;get_all&gt;

Get a list of all remaining tests.

=cut

sub get_all {
    my $self = shift;
    my @all  = $self-&gt;_gather( $self-&gt;{schedule} );
    $self-&gt;{count} = @all;
    @all;
}

sub _gather {
    my ( $self, $rule ) = @_;
    return unless defined $rule;
    return $rule unless 'ARRAY' eq ref $rule;
    return map { defined() ? $self-&gt;_gather($_) : () } map {@$_} @$rule;
}

=head3 C&lt;get_job&gt;

Return the next available job as L&lt;TAP::Parser::Scheduler::Job&gt; object or
C&lt;undef&gt; if none are available. Returns a L&lt;TAP::Parser::Scheduler::Spinner&gt; if
the scheduler still has pending jobs but none are available to run right now.

=cut

sub get_job {
    my $self = shift;
    $self-&gt;{count} ||= $self-&gt;get_all;
    my @jobs = $self-&gt;_find_next_job( $self-&gt;{schedule} );
    if (@jobs) {
        --$self-&gt;{count};
        return $jobs[0];
    }

    return TAP::Parser::Scheduler::Spinner-&gt;new
      if $self-&gt;{count};

    return;
}

sub _not_empty {
    my $ar = shift;
    return 1 unless 'ARRAY' eq ref $ar;
    for (@$ar) {
        return 1 if _not_empty($_);
    }
    return;
}

sub _is_empty { !_not_empty(@_) }

sub _find_next_job {
    my ( $self, $rule ) = @_;

    my @queue = ();
    my $index = 0;
    while ( $index &lt; @$rule ) {
        my $seq = $rule-&gt;[$index];

        # Prune any exhausted items.
        shift @$seq while @$seq &amp;&amp; _is_empty( $seq-&gt;[0] );
        if (@$seq) {
            if ( defined $seq-&gt;[0] ) {
                if ( 'ARRAY' eq ref $seq-&gt;[0] ) {
                    push @queue, $seq;
                }
                else {
                    my $job = splice @$seq, 0, 1, undef;
                    $job-&gt;on_finish( sub { shift @$seq } );
                    return $job;
                }
            }
            ++$index;
        }
        else {

            # Remove the empty sub-array from the array
            splice @$rule, $index, 1;
        }
    }

    for my $seq (@queue) {
        if ( my @jobs = $self-&gt;_find_next_job( $seq-&gt;[0] ) ) {
            return @jobs;
        }
    }

    return;
}

=head3 C&lt;as_string&gt;

Return a human readable representation of the scheduling tree.
For example:

    my @tests = (qw{
        t/startup/foo.t 
        t/shutdown/foo.t
    
        t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
    });
    my $sched = TAP::Parser::Scheduler-&gt;new(
        tests =&gt; \@tests,
        rules =&gt; {
            seq =&gt; [
                { seq =&gt; 't/startup/*.t' },
                { par =&gt; ['t/a/*.t','t/b/*.t','t/c/*.t'] },
                { seq =&gt; 't/shutdown/*.t' },
            ],
        },
    );

Produces:

    par:
      seq:
        par:
          seq:
            par:
              seq:
                't/startup/foo.t'
            par:
              seq:
                't/a/foo.t'
              seq:
                't/b/foo.t'
              seq:
                't/c/foo.t'
            par:
              seq:
                't/shutdown/foo.t'
        't/d/foo.t'


=cut


sub as_string {
    my $self = shift;
    return $self-&gt;_as_string( $self-&gt;{schedule} );
}

sub _as_string {
    my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
    my $pad    = ' ' x 2;
    my $indent = $pad x $depth;
    if ( !defined $rule ) {
        return &quot;$indent(undef)\n&quot;;
    }
    elsif ( 'ARRAY' eq ref $rule ) {
        return unless @$rule;
        my $type = ( 'par', 'seq' )[ $depth % 2 ];
        return join(
            '', &quot;$indent$type:\n&quot;,
            map { $self-&gt;_as_string( $_, $depth + 1 ) } @$rule
        );
    }
    else {
        return &quot;$indent'&quot; . $rule-&gt;filename . &quot;'\n&quot;;
    }
}

1;
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Fshare%2Fperl5%2Fvendor_perl%2FTAP%2FParser'>Back to Directory</a>