exiftool-vendored.exe 12.82.0 → 12.82.1

package/bin/exiftool_files/lib/TAP/Parser/Scheduler.pm

@@ -0,0 +1,448 @@
+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<new>
+
+    my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
+    my $sched = TAP::Parser::Scheduler->new(
+        tests => [ ['t/test_name.t','Test Description'], ... ],
+        rules => \%rules,
+    );
+
+Given 'tests' and optional 'rules' as input, returns a new
+C<TAP::Parser::Scheduler> object.  Each member of C<@tests> 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<rules> 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 => '**' },
+
+The rules data structure is documented more in the next section.
+
+=head2 Rules data structure
+
+The "C<rules>" data structure is the the heart of the scheduler. It allows you
+to express simple rules like "run all tests in sequence" or "run all tests in
+parallel except these five tests.". 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 "parallel" or 'seq'
+for "sequence".
+
+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 => '**' },
+
+    # Run all tests in sequence, except those starting with "p"
+    { par => 't/p*.t' },
+
+    # Run all tests in parallel, except those starting with "p"
+    {
+        seq => [
+                  { seq => 't/p*.t' },
+                  { par => '**'     },
+               ],
+    }
+
+    # Run some  startup tests in sequence, then some parallel tests then some
+    # teardown tests in sequence.
+    {
+        seq => [
+            { seq => 't/startup/*.t' },
+            { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
+            { seq => '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 * "First match wins". 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<jobs> 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 "Need a number of key, value pairs" if @_ % 2;
+
+    my %args  = @_;
+    my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+    my $rules = delete $args{rules} || { par => '**' };
+
+    croak "Unknown arg(s): ", 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->_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->new(@$_) }
+      map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+    my $schedule = $self->_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->{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 => sub {
+            [ map { [$_] } @_ ];
+        },
+        seq => sub { [ [@_] ] },
+    );
+
+    my $handler = $handlers{ $type[0] }
+      || croak 'Unknown scheduler type: ', $type[0];
+    my $val = $rule->{ $type[0] };
+
+    return $handler->(
+        map {
+            'HASH' eq ref $_
+              ? $self->_rule_clause( $_, $tests )
+              : $self->_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->_glob_to_regexp($name);
+    $pattern = qr/^ $pattern $/x;
+    my @match = ();
+
+    for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+        if ( $tests->[$ti]->filename =~ $pattern ) {
+            push @match, splice @$tests, $ti, 1;
+            $ti--;
+        }
+    }
+
+    return @match;
+}
+
+=head2 Instance Methods
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+    my $self = shift;
+    my @all  = $self->_gather( $self->{schedule} );
+    $self->{count} = @all;
+    @all;
+}
+
+sub _gather {
+    my ( $self, $rule ) = @_;
+    return unless defined $rule;
+    return $rule unless 'ARRAY' eq ref $rule;
+    return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job as L<TAP::Parser::Scheduler::Job> object or
+C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if
+the scheduler still has pending jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+    my $self = shift;
+    $self->{count} ||= $self->get_all;
+    my @jobs = $self->_find_next_job( $self->{schedule} );
+    if (@jobs) {
+        --$self->{count};
+        return $jobs[0];
+    }
+
+    return TAP::Parser::Scheduler::Spinner->new
+      if $self->{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 < @$rule ) {
+        my $seq = $rule->[$index];
+
+        # Prune any exhausted items.
+        shift @$seq while @$seq && _is_empty( $seq->[0] );
+        if (@$seq) {
+            if ( defined $seq->[0] ) {
+                if ( 'ARRAY' eq ref $seq->[0] ) {
+                    push @queue, $seq;
+                }
+                else {
+                    my $job = splice @$seq, 0, 1, undef;
+                    $job->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->_find_next_job( $seq->[0] ) ) {
+            return @jobs;
+        }
+    }
+
+    return;
+}
+
+=head3 C<as_string>
+
+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->new(
+        tests => \@tests,
+        rules => {
+            seq => [
+                { seq => 't/startup/*.t' },
+                { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
+                { seq => '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->_as_string( $self->{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 "$indent(undef)\n";
+    }
+    elsif ( 'ARRAY' eq ref $rule ) {
+        return unless @$rule;
+        my $type = ( 'par', 'seq' )[ $depth % 2 ];
+        return join(
+            '', "$indent$type:\n",
+            map { $self->_as_string( $_, $depth + 1 ) } @$rule
+        );
+    }
+    else {
+        return "$indent'" . $rule->filename . "'\n";
+    }
+}
+
+1;