diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/App')
4 files changed, 1750 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove.pm new file mode 100755 index 0000000000..a7230ddea7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove.pm @@ -0,0 +1,817 @@ +package App::Prove; + +use strict; +use warnings; + +use TAP::Harness::Env; +use Text::ParseWords qw(shellwords); +use File::Spec; +use Getopt::Long; +use App::Prove::State; +use Carp; + +use base 'TAP::Object'; + +=head1 NAME + +App::Prove - Implements the C<prove> command. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +L<Test::Harness> provides a command, C<prove>, which runs a TAP based +test suite and prints a report. The C<prove> command is a minimal +wrapper around an instance of this module. + +=head1 SYNOPSIS + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + $app->run; + +=cut + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => $^O eq 'VMS'; +use constant IS_UNIXY => !( IS_VMS || IS_WIN32 ); + +use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove'; +use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc'; + +use constant PLUGINS => 'App::Prove::Plugin'; + +my @ATTR; + +BEGIN { + @ATTR = qw( + archive argv blib show_count color directives exec failures comments + formatter harness includes modules plugins jobs lib merge parse quiet + really_quiet recurse backwards shuffle taint_fail taint_warn timer + verbose warnings_fail warnings_warn show_help show_man show_version + state_class test_args state dry extensions ignore_exit rules state_manager + normalize sources tapversion trap + statefile + ); + __PACKAGE__->mk_methods(@ATTR); +} + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + +Create a new C<App::Prove>. Optionally a hash ref of attribute +initializers may be passed. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my $self = shift; + my $args = shift || {}; + + my @is_array = qw( + argv rc_opts includes modules state plugins rules sources + ); + + # setup defaults: + for my $key (@is_array) { + $self->{$key} = []; + } + + for my $attr (@ATTR) { + if ( exists $args->{$attr} ) { + + # TODO: Some validation here + $self->{$attr} = $args->{$attr}; + } + } + + $self->state_class('App::Prove::State'); + return $self; +} + +=head3 C<state_class> + +Getter/setter for the name of the class used for maintaining state. This +class should either subclass from C<App::Prove::State> or provide an identical +interface. + +=head3 C<state_manager> + +Getter/setter for the instance of the C<state_class>. + +=cut + +=head3 C<add_rc_file> + + $prove->add_rc_file('myproj/.proverc'); + +Called before C<process_args> to prepend the contents of an rc file to +the options. + +=cut + +sub add_rc_file { + my ( $self, $rc_file ) = @_; + + local *RC; + open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; + while ( defined( my $line = <RC> ) ) { + push @{ $self->{rc_opts} }, + grep { defined and not /^#/ } + $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg; + } + close RC; +} + +=head3 C<process_args> + + $prove->process_args(@args); + +Processes the command-line arguments. Attributes will be set +appropriately. Any filenames may be found in the C<argv> attribute. + +Dies on invalid arguments. + +=cut + +sub process_args { + my $self = shift; + + my @rc = RC_FILE; + unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; + + # Preprocess meta-args. + my @args; + while ( defined( my $arg = shift ) ) { + if ( $arg eq '--norc' ) { + @rc = (); + } + elsif ( $arg eq '--rc' ) { + defined( my $rc = shift ) + or croak "Missing argument to --rc"; + push @rc, $rc; + } + elsif ( $arg =~ m{^--rc=(.+)$} ) { + push @rc, $1; + } + else { + push @args, $arg; + } + } + + # Everything after the arisdottle '::' gets passed as args to + # test programs. + if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { + my @test_args = splice @args, $stop_at; + shift @test_args; + $self->{test_args} = \@test_args; + } + + # Grab options from RC files + $self->add_rc_file($_) for grep -f, @rc; + unshift @args, @{ $self->{rc_opts} }; + + if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { + die "Long options should be written with two dashes: ", + join( ', ', @bad ), "\n"; + } + + # And finally... + + { + local @ARGV = @args; + Getopt::Long::Configure(qw(no_ignore_case bundling pass_through)); + + # Don't add coderefs to GetOptions + GetOptions( + 'v|verbose' => \$self->{verbose}, + 'f|failures' => \$self->{failures}, + 'o|comments' => \$self->{comments}, + 'l|lib' => \$self->{lib}, + 'b|blib' => \$self->{blib}, + 's|shuffle' => \$self->{shuffle}, + 'color!' => \$self->{color}, + 'colour!' => \$self->{color}, + 'count!' => \$self->{show_count}, + 'c' => \$self->{color}, + 'D|dry' => \$self->{dry}, + 'ext=s@' => sub { + my ( $opt, $val ) = @_; + + # Workaround for Getopt::Long 2.25 handling of + # multivalue options + push @{ $self->{extensions} ||= [] }, $val; + }, + 'harness=s' => \$self->{harness}, + 'ignore-exit' => \$self->{ignore_exit}, + 'source=s@' => $self->{sources}, + 'formatter=s' => \$self->{formatter}, + 'r|recurse' => \$self->{recurse}, + 'reverse' => \$self->{backwards}, + 'p|parse' => \$self->{parse}, + 'q|quiet' => \$self->{quiet}, + 'Q|QUIET' => \$self->{really_quiet}, + 'e|exec=s' => \$self->{exec}, + 'm|merge' => \$self->{merge}, + 'I=s@' => $self->{includes}, + 'M=s@' => $self->{modules}, + 'P=s@' => $self->{plugins}, + 'state=s@' => $self->{state}, + 'statefile=s' => \$self->{statefile}, + 'directives' => \$self->{directives}, + 'h|help|?' => \$self->{show_help}, + 'H|man' => \$self->{show_man}, + 'V|version' => \$self->{show_version}, + 'a|archive=s' => \$self->{archive}, + 'j|jobs=i' => \$self->{jobs}, + 'timer' => \$self->{timer}, + 'T' => \$self->{taint_fail}, + 't' => \$self->{taint_warn}, + 'W' => \$self->{warnings_fail}, + 'w' => \$self->{warnings_warn}, + 'normalize' => \$self->{normalize}, + 'rules=s@' => $self->{rules}, + 'tapversion=s' => \$self->{tapversion}, + 'trap' => \$self->{trap}, + ) or croak('Unable to continue'); + + # Stash the remainder of argv for later + $self->{argv} = [@ARGV]; + } + + return; +} + +sub _first_pos { + my $want = shift; + for ( 0 .. $#_ ) { + return $_ if $_[$_] eq $want; + } + return; +} + +sub _help { + my ( $self, $verbosity ) = @_; + + eval('use Pod::Usage 1.12 ()'); + if ( my $err = $@ ) { + die 'Please install Pod::Usage for the --help option ' + . '(or try `perldoc prove`.)' + . "\n ($@)"; + } + + Pod::Usage::pod2usage( { -verbose => $verbosity } ); + + return; +} + +sub _color_default { + my $self = shift; + + return -t STDOUT && !$ENV{HARNESS_NOTTY}; +} + +sub _get_args { + my $self = shift; + + my %args; + + $args{trap} = 1 if $self->trap; + + if ( defined $self->color ? $self->color : $self->_color_default ) { + $args{color} = 1; + } + if ( !defined $self->show_count ) { + $args{show_count} = 1; + } + else { + $args{show_count} = $self->show_count; + } + + if ( $self->archive ) { + $self->require_harness( archive => 'TAP::Harness::Archive' ); + $args{archive} = $self->archive; + } + + if ( my $jobs = $self->jobs ) { + $args{jobs} = $jobs; + } + + if ( my $harness_opt = $self->harness ) { + $self->require_harness( harness => $harness_opt ); + } + + if ( my $formatter = $self->formatter ) { + $args{formatter_class} = $formatter; + } + + for my $handler ( @{ $self->sources } ) { + my ( $name, $config ) = $self->_parse_source($handler); + $args{sources}->{$name} = $config; + } + + if ( $self->ignore_exit ) { + $args{ignore_exit} = 1; + } + + if ( $self->taint_fail && $self->taint_warn ) { + die '-t and -T are mutually exclusive'; + } + + if ( $self->warnings_fail && $self->warnings_warn ) { + die '-w and -W are mutually exclusive'; + } + + for my $a (qw( lib switches )) { + my $method = "_get_$a"; + my $val = $self->$method(); + $args{$a} = $val if defined $val; + } + + # Handle verbose, quiet, really_quiet flags + my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); + + my @verb_adj = map { $self->$_() ? $verb_map{$_} : () } + keys %verb_map; + + die "Only one of verbose, quiet or really_quiet should be specified\n" + if @verb_adj > 1; + + $args{verbosity} = shift @verb_adj if @verb_adj; + + for my $a (qw( merge failures comments timer directives normalize )) { + $args{$a} = 1 if $self->$a(); + } + + $args{errors} = 1 if $self->parse; + + # defined but zero-length exec runs test files as binaries + $args{exec} = [ split( /\s+/, $self->exec ) ] + if ( defined( $self->exec ) ); + + $args{version} = $self->tapversion if defined( $self->tapversion ); + + if ( defined( my $test_args = $self->test_args ) ) { + $args{test_args} = $test_args; + } + + if ( @{ $self->rules } ) { + my @rules; + for ( @{ $self->rules } ) { + if (/^par=(.*)/) { + push @rules, $1; + } + elsif (/^seq=(.*)/) { + push @rules, { seq => $1 }; + } + } + $args{rules} = { par => [@rules] }; + } + $args{harness_class} = $self->{harness_class} if $self->{harness_class}; + + return \%args; +} + +sub _find_module { + my ( $self, $class, @search ) = @_; + + croak "Bad module name $class" + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + for my $pfx (@search) { + my $name = join( '::', $pfx, $class ); + eval "require $name"; + return $name unless $@; + } + + eval "require $class"; + return $class unless $@; + return; +} + +sub _load_extension { + my ( $self, $name, @search ) = @_; + + my @args = (); + if ( $name =~ /^(.*?)=(.*)/ ) { + $name = $1; + @args = split( /,/, $2 ); + } + + if ( my $class = $self->_find_module( $name, @search ) ) { + if ( $class->can('load') ) { + $class->load( { app_prove => $self, args => [@args] } ); + } + } + else { + croak "Can't load module $name"; + } +} + +sub _load_extensions { + my ( $self, $ext, @search ) = @_; + $self->_load_extension( $_, @search ) for @$ext; +} + +sub _parse_source { + my ( $self, $handler ) = @_; + + # Load any options. + ( my $opt_name = lc $handler ) =~ s/::/-/g; + local @ARGV = @{ $self->{argv} }; + my %config; + Getopt::Long::GetOptions( + "$opt_name-option=s%" => sub { + my ( $name, $k, $v ) = @_; + if ( $v =~ /(?<!\\)=/ ) { + + # It's a hash option. + croak "Option $name must be consistently used as a hash" + if exists $config{$k} && ref $config{$k} ne 'HASH'; + $config{$k} ||= {}; + my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2; + $config{$k}{$hk} = $hv; + } + else { + $v =~ s/\\=/=/g; + if ( exists $config{$k} ) { + $config{$k} = [ $config{$k} ] + unless ref $config{$k} eq 'ARRAY'; + push @{ $config{$k} } => $v; + } + else { + $config{$k} = $v; + } + } + } + ); + $self->{argv} = \@ARGV; + return ( $handler, \%config ); +} + +=head3 C<run> + +Perform whatever actions the command line args specified. The C<prove> +command line tool consists of the following code: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + exit( $app->run ? 0 : 1 ); # if you need the exit code + +=cut + +sub run { + my $self = shift; + + unless ( $self->state_manager ) { + $self->state_manager( + $self->state_class->new( { store => $self->statefile || STATE_FILE } ) ); + } + + if ( $self->show_help ) { + $self->_help(1); + } + elsif ( $self->show_man ) { + $self->_help(2); + } + elsif ( $self->show_version ) { + $self->print_version; + } + elsif ( $self->dry ) { + print "$_\n" for $self->_get_tests; + } + else { + + $self->_load_extensions( $self->modules ); + $self->_load_extensions( $self->plugins, PLUGINS ); + + local $ENV{TEST_VERBOSE} = 1 if $self->verbose; + + return $self->_runtests( $self->_get_args, $self->_get_tests ); + } + + return 1; +} + +sub _get_tests { + my $self = shift; + + my $state = $self->state_manager; + my $ext = $self->extensions; + $state->extensions($ext) if defined $ext; + if ( defined( my $state_switch = $self->state ) ) { + $state->apply_switch(@$state_switch); + } + + my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); + + $self->_shuffle(@tests) if $self->shuffle; + @tests = reverse @tests if $self->backwards; + + return @tests; +} + +sub _runtests { + my ( $self, $args, @tests ) = @_; + my $harness = TAP::Harness::Env->create($args); + + my $state = $self->state_manager; + + $harness->callback( + after_test => sub { + $state->observe_test(@_); + } + ); + + $harness->callback( + after_runtests => sub { + $state->commit(@_); + } + ); + + my $aggregator = $harness->runtests(@tests); + + return !$aggregator->has_errors; +} + +sub _get_switches { + my $self = shift; + my @switches; + + # notes that -T or -t must be at the front of the switches! + if ( $self->taint_fail ) { + push @switches, '-T'; + } + elsif ( $self->taint_warn ) { + push @switches, '-t'; + } + if ( $self->warnings_fail ) { + push @switches, '-W'; + } + elsif ( $self->warnings_warn ) { + push @switches, '-w'; + } + + return @switches ? \@switches : (); +} + +sub _get_lib { + my $self = shift; + my @libs; + if ( $self->lib ) { + push @libs, 'lib'; + } + if ( $self->blib ) { + push @libs, 'blib/lib', 'blib/arch'; + } + if ( @{ $self->includes } ) { + push @libs, @{ $self->includes }; + } + + #24926 + @libs = map { File::Spec->rel2abs($_) } @libs; + + # Huh? + return @libs ? \@libs : (); +} + +sub _shuffle { + my $self = shift; + + # Fisher-Yates shuffle + my $i = @_; + while ($i) { + my $j = rand $i--; + @_[ $i, $j ] = @_[ $j, $i ]; + } + return; +} + +=head3 C<require_harness> + +Load a harness replacement class. + + $prove->require_harness($for => $class_name); + +=cut + +sub require_harness { + my ( $self, $for, $class ) = @_; + + my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; + + # Emulate Perl's -MModule=arg1,arg2 behaviour + $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; + + eval("use $class;"); + die "$class_name is required to use the --$for feature: $@" if $@; + + $self->{harness_class} = $class_name; + + return; +} + +=head3 C<print_version> + +Display the version numbers of the loaded L<TAP::Harness> and the +current Perl. + +=cut + +sub print_version { + my $self = shift; + require TAP::Harness; + printf( + "TAP::Harness v%s and Perl v%vd\n", + $TAP::Harness::VERSION, $^V + ); + + return; +} + +1; + +# vim:ts=4:sw=4:et:sta + +__END__ + +=head2 Attributes + +After command line parsing the following attributes reflect the values +of the corresponding command line switches. They may be altered before +calling C<run>. + +=over + +=item C<archive> + +=item C<argv> + +=item C<backwards> + +=item C<blib> + +=item C<color> + +=item C<directives> + +=item C<dry> + +=item C<exec> + +=item C<extensions> + +=item C<failures> + +=item C<comments> + +=item C<formatter> + +=item C<harness> + +=item C<ignore_exit> + +=item C<includes> + +=item C<jobs> + +=item C<lib> + +=item C<merge> + +=item C<modules> + +=item C<parse> + +=item C<plugins> + +=item C<quiet> + +=item C<really_quiet> + +=item C<recurse> + +=item C<rules> + +=item C<show_count> + +=item C<show_help> + +=item C<show_man> + +=item C<show_version> + +=item C<shuffle> + +=item C<state> + +=item C<state_class> + +=item C<taint_fail> + +=item C<taint_warn> + +=item C<test_args> + +=item C<timer> + +=item C<verbose> + +=item C<warnings_fail> + +=item C<warnings_warn> + +=item C<tapversion> + +=item C<trap> + +=back + +=head1 PLUGINS + +C<App::Prove> provides support for 3rd-party plugins. These are currently +loaded at run-time, I<after> arguments have been parsed (so you can not +change the way arguments are processed, sorry), typically with the +C<< -PI<plugin> >> switch, eg: + + prove -PMyPlugin + +This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing +that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit. + +You can pass an argument to your plugin by appending an C<=> after the plugin +name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: + + prove -PMyPlugin=foo,bar,baz + +These are passed in to your plugin's C<load()> class method (if it has one), +along with a reference to the C<App::Prove> object that is invoking your plugin: + + sub load { + my ($class, $p) = @_; + + my @args = @{ $p->{args} }; + # @args will contain ( 'foo', 'bar', 'baz' ) + $p->{app_prove}->do_something; + ... + } + +=head2 Sample Plugin + +Here's a sample plugin, for your reference: + + package App::Prove::Plugin::Foo; + + # Sample plugin, try running with: + # prove -PFoo=bar -r -j3 + # prove -PFoo -Q + # prove -PFoo=bar,My::Formatter + + use strict; + use warnings; + + sub load { + my ($class, $p) = @_; + my @args = @{ $p->{args} }; + my $app = $p->{app_prove}; + + print "loading plugin: $class, args: ", join(', ', @args ), "\n"; + + # turn on verbosity + $app->verbose( 1 ); + + # set the formatter? + $app->formatter( $args[1] ) if @args > 1; + + # print some of App::Prove's state: + for my $attr (qw( jobs quiet really_quiet recurse verbose )) { + my $val = $app->$attr; + $val = 'undef' unless defined( $val ); + print "$attr: $val\n"; + } + + return 1; + } + + 1; + +=head1 SEE ALSO + +L<prove>, L<TAP::Harness> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm new file mode 100755 index 0000000000..d4477e2b25 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm @@ -0,0 +1,548 @@ +package App::Prove::State; + +use strict; +use warnings; + +use File::Find; +use File::Spec; +use Carp; + +use App::Prove::State::Result; +use TAP::Parser::YAMLish::Reader (); +use TAP::Parser::YAMLish::Writer (); +use base 'TAP::Base'; + +BEGIN { + __PACKAGE__->mk_methods('result_class'); +} + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant NEED_GLOB => IS_WIN32; + +=head1 NAME + +App::Prove::State - State storage for the C<prove> command. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +The C<prove> command supports a C<--state> option that instructs it to +store persistent state across runs. This module implements that state +and the operations that may be performed on it. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=failed,save -rbv + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + +Accepts a hashref with the following key/value pairs: + +=over 4 + +=item * C<store> + +The filename of the data store holding the data that App::Prove::State reads. + +=item * C<extensions> (optional) + +The test name extensions. Defaults to C<.t>. + +=item * C<result_class> (optional) + +The name of the C<result_class>. Defaults to C<App::Prove::State::Result>. + +=back + +=cut + +# override TAP::Base::new: +sub new { + my $class = shift; + my %args = %{ shift || {} }; + + my $self = bless { + select => [], + seq => 1, + store => delete $args{store}, + extensions => ( delete $args{extensions} || ['.t'] ), + result_class => + ( delete $args{result_class} || 'App::Prove::State::Result' ), + }, $class; + + $self->{_} = $self->result_class->new( + { tests => {}, + generation => 1, + } + ); + my $store = $self->{store}; + $self->load($store) + if defined $store && -f $store; + + return $self; +} + +=head2 C<result_class> + +Getter/setter for the name of the class used for tracking test results. This +class should either subclass from C<App::Prove::State::Result> or provide an +identical interface. + +=cut + +=head2 C<extensions> + +Get or set the list of extensions that files must have in order to be +considered tests. Defaults to ['.t']. + +=cut + +sub extensions { + my $self = shift; + $self->{extensions} = shift if @_; + return $self->{extensions}; +} + +=head2 C<results> + +Get the results of the last test run. Returns a C<result_class()> instance. + +=cut + +sub results { + my $self = shift; + $self->{_} || $self->result_class->new; +} + +=head2 C<commit> + +Save the test results. Should be called after all tests have run. + +=cut + +sub commit { + my $self = shift; + if ( $self->{should_save} ) { + $self->save; + } +} + +=head2 Instance Methods + +=head3 C<apply_switch> + + $self->apply_switch('failed,save'); + +Apply a list of switch options to the state, updating the internal +object state as a result. Nothing is returned. + +Diagnostics: + - "Illegal state option: %s" + +=over + +=item C<last> + +Run in the same order as last time + +=item C<failed> + +Run only the failed tests from last time + +=item C<passed> + +Run only the passed tests from last time + +=item C<all> + +Run all tests in normal order + +=item C<hot> + +Run the tests that most recently failed first + +=item C<todo> + +Run the tests ordered by number of todos. + +=item C<slow> + +Run the tests in slowest to fastest order. + +=item C<fast> + +Run test tests in fastest to slowest order. + +=item C<new> + +Run the tests in newest to oldest order. + +=item C<old> + +Run the tests in oldest to newest order. + +=item C<save> + +Save the state on exit. + +=back + +=cut + +sub apply_switch { + my $self = shift; + my @opts = @_; + + my $last_gen = $self->results->generation - 1; + my $last_run_time = $self->results->last_run_time; + my $now = $self->get_time; + + my @switches = map { split /,/ } @opts; + + my %handler = ( + last => sub { + $self->_select( + limit => shift, + where => sub { $_->generation >= $last_gen }, + order => sub { $_->sequence } + ); + }, + failed => sub { + $self->_select( + limit => shift, + where => sub { $_->result != 0 }, + order => sub { -$_->result } + ); + }, + passed => sub { + $self->_select( + limit => shift, + where => sub { $_->result == 0 } + ); + }, + all => sub { + $self->_select( limit => shift ); + }, + todo => sub { + $self->_select( + limit => shift, + where => sub { $_->num_todo != 0 }, + order => sub { -$_->num_todo; } + ); + }, + hot => sub { + $self->_select( + limit => shift, + where => sub { defined $_->last_fail_time }, + order => sub { $now - $_->last_fail_time } + ); + }, + slow => sub { + $self->_select( + limit => shift, + order => sub { -$_->elapsed } + ); + }, + fast => sub { + $self->_select( + limit => shift, + order => sub { $_->elapsed } + ); + }, + new => sub { + $self->_select( + limit => shift, + order => sub { -$_->mtime } + ); + }, + old => sub { + $self->_select( + limit => shift, + order => sub { $_->mtime } + ); + }, + fresh => sub { + $self->_select( + limit => shift, + where => sub { $_->mtime >= $last_run_time } + ); + }, + save => sub { + $self->{should_save}++; + }, + adrian => sub { + unshift @switches, qw( hot all save ); + }, + ); + + while ( defined( my $ele = shift @switches ) ) { + my ( $opt, $arg ) + = ( $ele =~ /^([^:]+):(.*)/ ) + ? ( $1, $2 ) + : ( $ele, undef ); + my $code = $handler{$opt} + || croak "Illegal state option: $opt"; + $code->($arg); + } + return; +} + +sub _select { + my ( $self, %spec ) = @_; + push @{ $self->{select} }, \%spec; +} + +=head3 C<get_tests> + +Given a list of args get the names of tests that should run + +=cut + +sub get_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my %seen; + + my @selected = $self->_query; + + unless ( @argv || @{ $self->{select} } ) { + @argv = $recurse ? '.' : 't'; + croak qq{No tests named and '@argv' directory not found} + unless -d $argv[0]; + } + + push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv; + return grep { !$seen{$_}++ } @selected; +} + +sub _query { + my $self = shift; + if ( my @sel = @{ $self->{select} } ) { + warn "No saved state, selection will be empty\n" + unless $self->results->num_tests; + return map { $self->_query_clause($_) } @sel; + } + return; +} + +sub _query_clause { + my ( $self, $clause ) = @_; + my @got; + my $results = $self->results; + my $where = $clause->{where} || sub {1}; + + # Select + for my $name ( $results->test_names ) { + next unless -f $name; + local $_ = $results->test($name); + push @got, $name if $where->(); + } + + # Sort + if ( my $order = $clause->{order} ) { + @got = map { $_->[0] } + sort { + ( defined $b->[1] <=> defined $a->[1] ) + || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) ) + } map { + [ $_, + do { local $_ = $results->test($_); $order->() } + ] + } @got; + } + + if ( my $limit = $clause->{limit} ) { + @got = splice @got, 0, $limit if @got > $limit; + } + + return @got; +} + +sub _get_raw_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my @tests; + + # Do globbing on Win32. + if (NEED_GLOB) { + eval "use File::Glob::Windows"; # [49732] + @argv = map { glob "$_" } @argv; + } + my $extensions = $self->{extensions}; + + for my $arg (@argv) { + if ( '-' eq $arg ) { + push @argv => <STDIN>; + chomp(@argv); + next; + } + + push @tests, + sort -d $arg + ? $recurse + ? $self->_expand_dir_recursive( $arg, $extensions ) + : map { glob( File::Spec->catfile( $arg, "*$_" ) ) } + @{$extensions} + : $arg; + } + return @tests; +} + +sub _expand_dir_recursive { + my ( $self, $dir, $extensions ) = @_; + + my @tests; + my $ext_string = join( '|', map {quotemeta} @{$extensions} ); + + find( + { follow => 1, #21938 + follow_skip => 2, + wanted => sub { + -f + && /(?:$ext_string)$/ + && push @tests => $File::Find::name; + } + }, + $dir + ); + return @tests; +} + +=head3 C<observe_test> + +Store the results of a test. + +=cut + +# Store: +# last fail time +# last pass time +# last run time +# most recent result +# most recent todos +# total failures +# total passes +# state generation +# parser + +sub observe_test { + + my ( $self, $test_info, $parser ) = @_; + my $name = $test_info->[0]; + my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ); + my $todo = scalar( $parser->todo ); + my $start_time = $parser->start_time; + my $end_time = $parser->end_time, + + my $test = $self->results->test($name); + + $test->sequence( $self->{seq}++ ); + $test->generation( $self->results->generation ); + + $test->run_time($end_time); + $test->result($fail); + $test->num_todo($todo); + $test->elapsed( $end_time - $start_time ); + + $test->parser($parser); + + if ($fail) { + $test->total_failures( $test->total_failures + 1 ); + $test->last_fail_time($end_time); + } + else { + $test->total_passes( $test->total_passes + 1 ); + $test->last_pass_time($end_time); + } +} + +=head3 C<save> + +Write the state to a file. + +=cut + +sub save { + my ($self) = @_; + + my $store = $self->{store} or return; + $self->results->last_run_time( $self->get_time ); + + my $writer = TAP::Parser::YAMLish::Writer->new; + local *FH; + open FH, ">$store" or croak "Can't write $store ($!)"; + $writer->write( $self->results->raw, \*FH ); + close FH; +} + +=head3 C<load> + +Load the state from a file + +=cut + +sub load { + my ( $self, $name ) = @_; + my $reader = TAP::Parser::YAMLish::Reader->new; + local *FH; + open FH, "<$name" or croak "Can't read $name ($!)"; + + # XXX this is temporary + $self->{_} = $self->result_class->new( + $reader->read( + sub { + my $line = <FH>; + defined $line && chomp $line; + return $line; + } + ) + ); + + # $writer->write( $self->{tests} || {}, \*FH ); + close FH; + $self->_regen_seq; + $self->_prune_and_stamp; + $self->results->generation( $self->results->generation + 1 ); +} + +sub _prune_and_stamp { + my $self = shift; + + my $results = $self->results; + my @tests = $self->results->tests; + for my $test (@tests) { + my $name = $test->name; + if ( my @stat = stat $name ) { + $test->mtime( $stat[9] ); + } + else { + $results->remove($name); + } + } +} + +sub _regen_seq { + my $self = shift; + for my $test ( $self->results->tests ) { + $self->{seq} = $test->sequence + 1 + if defined $test->sequence && $test->sequence >= $self->{seq}; + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result.pm new file mode 100755 index 0000000000..38faf6f24d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result.pm @@ -0,0 +1,233 @@ +package App::Prove::State::Result; + +use strict; +use warnings; +use Carp 'croak'; + +use App::Prove::State::Result::Test; + +use constant STATE_VERSION => 1; + +=head1 NAME + +App::Prove::State::Result - Individual test suite results. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +The C<prove> command supports a C<--state> option that instructs it to +store persistent state across runs. This module encapsulates the results for a +single test suite run. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=failed,save -rbv + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my $result = App::Prove::State::Result->new({ + generation => $generation, + tests => \%tests, + }); + +Returns a new C<App::Prove::State::Result> instance. + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + $arg_for ||= {}; + my %instance_data = %$arg_for; # shallow copy + $instance_data{version} = $class->state_version; + my $tests = delete $instance_data{tests} || {}; + my $self = bless \%instance_data => $class; + $self->_initialize($tests); + return $self; +} + +sub _initialize { + my ( $self, $tests ) = @_; + my %tests; + while ( my ( $name, $test ) = each %$tests ) { + $tests{$name} = $self->test_class->new( + { %$test, + name => $name + } + ); + } + $self->tests( \%tests ); + return $self; +} + +=head2 C<state_version> + +Returns the current version of state storage. + +=cut + +sub state_version {STATE_VERSION} + +=head2 C<test_class> + +Returns the name of the class used for tracking individual tests. This class +should either subclass from C<App::Prove::State::Result::Test> or provide an +identical interface. + +=cut + +sub test_class { + return 'App::Prove::State::Result::Test'; +} + +my %methods = ( + generation => { method => 'generation', default => 0 }, + last_run_time => { method => 'last_run_time', default => undef }, +); + +while ( my ( $key, $description ) = each %methods ) { + my $default = $description->{default}; + no strict 'refs'; + *{ $description->{method} } = sub { + my $self = shift; + if (@_) { + $self->{$key} = shift; + return $self; + } + return $self->{$key} || $default; + }; +} + +=head3 C<generation> + +Getter/setter for the "generation" of the test suite run. The first +generation is 1 (one) and subsequent generations are 2, 3, etc. + +=head3 C<last_run_time> + +Getter/setter for the time of the test suite run. + +=head3 C<tests> + +Returns the tests for a given generation. This is a hashref or a hash, +depending on context called. The keys to the hash are the individual +test names and the value is a hashref with various interesting values. +Each k/v pair might resemble something like this: + + 't/foo.t' => { + elapsed => '0.0428488254547119', + gen => '7', + last_pass_time => '1219328376.07815', + last_result => '0', + last_run_time => '1219328376.07815', + last_todo => '0', + mtime => '1191708862', + seq => '192', + total_passes => '6', + } + +=cut + +sub tests { + my $self = shift; + if (@_) { + $self->{tests} = shift; + return $self; + } + my %tests = %{ $self->{tests} }; + my @tests = sort { $a->sequence <=> $b->sequence } values %tests; + return wantarray ? @tests : \@tests; +} + +=head3 C<test> + + my $test = $result->test('t/customer/create.t'); + +Returns an individual C<App::Prove::State::Result::Test> instance for the +given test name (usually the filename). Will return a new +C<App::Prove::State::Result::Test> instance if the name is not found. + +=cut + +sub test { + my ( $self, $name ) = @_; + croak("test() requires a test name") unless defined $name; + + my $tests = $self->{tests} ||= {}; + if ( my $test = $tests->{$name} ) { + return $test; + } + else { + my $test = $self->test_class->new( { name => $name } ); + $self->{tests}->{$name} = $test; + return $test; + } +} + +=head3 C<test_names> + +Returns an list of test names, sorted by run order. + +=cut + +sub test_names { + my $self = shift; + return map { $_->name } $self->tests; +} + +=head3 C<remove> + + $result->remove($test_name); # remove the test + my $test = $result->test($test_name); # fatal error + +Removes a given test from results. This is a no-op if the test name is not +found. + +=cut + +sub remove { + my ( $self, $name ) = @_; + delete $self->{tests}->{$name}; + return $self; +} + +=head3 C<num_tests> + +Returns the number of tests for a given test suite result. + +=cut + +sub num_tests { keys %{ shift->{tests} } } + +=head3 C<raw> + +Returns a hashref of raw results, suitable for serialization by YAML. + +=cut + +sub raw { + my $self = shift; + my %raw = %$self; + + my %tests; + for my $test ( $self->tests ) { + $tests{ $test->name } = $test->raw; + } + $raw{tests} = \%tests; + return \%raw; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result/Test.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result/Test.pm new file mode 100755 index 0000000000..61a5173cfa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State/Result/Test.pm @@ -0,0 +1,152 @@ +package App::Prove::State::Result::Test; + +use strict; +use warnings; + +=head1 NAME + +App::Prove::State::Result::Test - Individual test results. + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +The C<prove> command supports a C<--state> option that instructs it to +store persistent state across runs. This module encapsulates the results for a +single test. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=failed,save -rbv + +=cut + +my %methods = ( + name => { method => 'name' }, + elapsed => { method => 'elapsed', default => 0 }, + gen => { method => 'generation', default => 1 }, + last_pass_time => { method => 'last_pass_time', default => undef }, + last_fail_time => { method => 'last_fail_time', default => undef }, + last_result => { method => 'result', default => 0 }, + last_run_time => { method => 'run_time', default => undef }, + last_todo => { method => 'num_todo', default => 0 }, + mtime => { method => 'mtime', default => undef }, + seq => { method => 'sequence', default => 1 }, + total_passes => { method => 'total_passes', default => 0 }, + total_failures => { method => 'total_failures', default => 0 }, + parser => { method => 'parser' }, +); + +while ( my ( $key, $description ) = each %methods ) { + my $default = $description->{default}; + no strict 'refs'; + *{ $description->{method} } = sub { + my $self = shift; + if (@_) { + $self->{$key} = shift; + return $self; + } + return $self->{$key} || $default; + }; +} + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + $arg_for ||= {}; + bless $arg_for => $class; +} + +=head2 Instance Methods + +=head3 C<name> + +The name of the test. Usually a filename. + +=head3 C<elapsed> + +The total elapsed times the test took to run, in seconds from the epoch.. + +=head3 C<generation> + +The number for the "generation" of the test run. The first generation is 1 +(one) and subsequent generations are 2, 3, etc. + +=head3 C<last_pass_time> + +The last time the test program passed, in seconds from the epoch. + +Returns C<undef> if the program has never passed. + +=head3 C<last_fail_time> + +The last time the test suite failed, in seconds from the epoch. + +Returns C<undef> if the program has never failed. + +=head3 C<mtime> + +Returns the mtime of the test, in seconds from the epoch. + +=head3 C<raw> + +Returns a hashref of raw test data, suitable for serialization by YAML. + +=head3 C<result> + +Currently, whether or not the test suite passed with no 'problems' (such as +TODO passed). + +=head3 C<run_time> + +The total time it took for the test to run, in seconds. If C<Time::HiRes> is +available, it will have finer granularity. + +=head3 C<num_todo> + +The number of tests with TODO directives. + +=head3 C<sequence> + +The order in which this test was run for the given test suite result. + +=head3 C<total_passes> + +The number of times the test has passed. + +=head3 C<total_failures> + +The number of times the test has failed. + +=head3 C<parser> + +The underlying parser object. This is useful if you need the full +information for the test program. + +=cut + +sub raw { + my $self = shift; + my %raw = %$self; + + # this is backwards-compatibility hack and is not guaranteed. + delete $raw{name}; + delete $raw{parser}; + return \%raw; +} + +1; |