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 | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/App/Prove')
3 files changed, 933 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; 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; |