diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm')
-rwxr-xr-x | systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove/State.pm | 548 |
1 files changed, 548 insertions, 0 deletions
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; |