X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Fi386%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Flib%2FTAP%2FParser%2FScheduler.pm;fp=dev%2Fi386%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Flib%2FTAP%2FParser%2FScheduler.pm;h=a8e05b212b66884d19c8db7c2d95fa418aa7cbff;hp=0000000000000000000000000000000000000000;hb=8977e561d8a9eae6959218b0306c9df2056a38a9;hpb=df794b845212301ea0d267c919232538bfef356a diff --git a/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/TAP/Parser/Scheduler.pm b/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/TAP/Parser/Scheduler.pm new file mode 100644 index 0000000..a8e05b2 --- /dev/null +++ b/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/TAP/Parser/Scheduler.pm @@ -0,0 +1,241 @@ +package TAP::Parser::Scheduler; + +use strict; +use vars qw($VERSION); +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.12 + +=cut + +$VERSION = '3.12'; + +=head1 SYNOPSIS + + use TAP::Parser::Scheduler; + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $sched = TAP::Parser::Scheduler->new; + +Returns a new C object. + +=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 ) = @_; + 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 _expand { + my ( $self, $name, $tests ) = @_; + + $name =~ s{(.)}{ + $1 eq '?' ? '[^/]' + : $1 eq '*' ? '[^/]*' + : quotemeta($1); + }gex; + + my $pattern = qr{^$name$}; + my @match = (); + + for ( my $ti = 0; $ti < @$tests; $ti++ ) { + if ( $tests->[$ti]->filename =~ $pattern ) { + push @match, splice @$tests, $ti, 1; + $ti--; + } + } + + return @match; +} + +=head3 C + +Get a list of all remaining tests. + +=cut + +sub get_all { + my $self = shift; + $self->_gather( $self->{schedule} ); +} + +sub _gather { + my ( $self, $rule ) = @_; + return unless defined $rule; + return $rule unless 'ARRAY' eq ref $rule; + return map { $self->_gather($_) } grep {defined} map {@$_} @$rule; +} + +=head3 C + +Return the next available job or C if none are available. Returns +a C if the scheduler still has pending +jobs but none are available to run right now. + +=cut + +sub get_job { + my $self = shift; + my @jobs = $self->_find_next_job( $self->{schedule} ); + return $jobs[0] if @jobs; + + # TODO: This isn't very efficient... + return TAP::Parser::Scheduler::Spinner->new + if $self->get_all; + + return; +} + +sub _not_empty { + my $ar = shift; + return 1 unless defined $ar && 'ARRAY' eq ref $ar; + return 1 if grep { _not_empty($_) } @$ar; + return; +} + +sub _is_empty { !_not_empty(@_) } + +sub _find_next_job { + my ( $self, $rule ) = @_; + + my @queue = (); + for my $seq (@$rule) { + + # Prune any exhausted items. + shift @$seq while @$seq && _is_empty( $seq->[0] ); + if ( @$seq && 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; + } + } + } + + for my $seq (@queue) { + if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) { + return @jobs; + } + } + + return; +} + +=head3 C + +Return a human readable representation of the scheduling tree. + +=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 ) { + 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;