--- /dev/null
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+@ISA = qw( TAP::Base );
+
+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.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+# override TAP::Base::new:
+sub new {
+ my $class = shift;
+ my %args = %{ shift || {} };
+
+ my $self = bless {
+ _ => {
+ tests => {},
+ generation => 1
+ },
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => delete $args{extension} || '.t',
+ }, $class;
+
+ my $store = $self->{store};
+ $self->load($store)
+ if defined $store && -f $store;
+
+ return $self;
+}
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+ my $self = shift;
+ $self->{extension} = shift if @_;
+ return $self->{extension};
+}
+
+sub DESTROY {
+ my $self = shift;
+ if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
+ $self->save($store);
+ }
+}
+
+=head2 Instance Methods
+
+=head3 C<apply_switch>
+
+Apply a list of switch options to the state.
+
+=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->{_}->{generation} - 1;
+ my $now = $self->get_time;
+
+ my @switches = map { split /,/ } @opts;
+
+ my %handler = (
+ last => sub {
+ $self->_select(
+ where => sub { $_->{gen} >= $last_gen },
+ order => sub { $_->{seq} }
+ );
+ },
+ failed => sub {
+ $self->_select(
+ where => sub { $_->{last_result} != 0 },
+ order => sub { -$_->{last_result} }
+ );
+ },
+ passed => sub {
+ $self->_select( where => sub { $_->{last_result} == 0 } );
+ },
+ all => sub {
+ $self->_select();
+ },
+ todo => sub {
+ $self->_select(
+ where => sub { $_->{last_todo} != 0 },
+ order => sub { -$_->{last_todo}; }
+ );
+ },
+ hot => sub {
+ $self->_select(
+ where => sub { defined $_->{last_fail_time} },
+ order => sub { $now - $_->{last_fail_time} }
+ );
+ },
+ slow => sub {
+ $self->_select( order => sub { -$_->{elapsed} } );
+ },
+ fast => sub {
+ $self->_select( order => sub { $_->{elapsed} } );
+ },
+ new => sub {
+ $self->_select( order => sub { -$_->{mtime} } );
+ },
+ old => sub {
+ $self->_select( order => sub { $_->{mtime} } );
+ },
+ 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);
+ }
+}
+
+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 keys %{ $self->{_}->{tests} };
+ return map { $self->_query_clause($_) } @sel;
+ }
+ return;
+}
+
+sub _query_clause {
+ my ( $self, $clause ) = @_;
+ my @got;
+ my $tests = $self->{_}->{tests};
+ my $where = $clause->{where} || sub {1};
+
+ # Select
+ for my $test ( sort keys %$tests ) {
+ next unless -f $test;
+ local $_ = $tests->{$test};
+ push @got, $test 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 $_ = $tests->{$_}; $order->() }
+ ]
+ } @got;
+ }
+
+ return @got;
+}
+
+sub _get_raw_tests {
+ my $self = shift;
+ my $recurse = shift;
+ my @argv = @_;
+ my @tests;
+
+ # Do globbing on Win32.
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
+
+ for my $arg (@argv) {
+ if ( '-' eq $arg ) {
+ push @argv => <STDIN>;
+ chomp(@argv);
+ next;
+ }
+
+ push @tests,
+ sort -d $arg
+ ? $recurse
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ : $arg;
+ }
+ return @tests;
+}
+
+sub _expand_dir_recursive {
+ my ( $self, $dir, $extension ) = @_;
+
+ my @tests;
+ find(
+ { follow => 1, #21938
+ wanted => sub {
+ -f
+ && /\Q$extension\E$/
+ && push @tests => $File::Find::name;
+ }
+ },
+ $dir
+ );
+ return @tests;
+}
+
+=head3 C<observe_test>
+
+Store the results of a test.
+
+=cut
+
+sub observe_test {
+ my ( $self, $test, $parser ) = @_;
+ $self->_record_test(
+ $test, scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
+ scalar( $parser->todo ), $parser->start_time, $parser->end_time
+ );
+}
+
+# Store:
+# last fail time
+# last pass time
+# last run time
+# most recent result
+# most recent todos
+# total failures
+# total passes
+# state generation
+
+sub _record_test {
+ my ( $self, $test, $fail, $todo, $start_time, $end_time ) = @_;
+ my $rec = $self->{_}->{tests}->{ $test->[0] } ||= {};
+
+ $rec->{seq} = $self->{seq}++;
+ $rec->{gen} = $self->{_}->{generation};
+
+ $rec->{last_run_time} = $end_time;
+ $rec->{last_result} = $fail;
+ $rec->{last_todo} = $todo;
+ $rec->{elapsed} = $end_time - $start_time;
+
+ if ($fail) {
+ $rec->{total_failures}++;
+ $rec->{last_fail_time} = $end_time;
+ }
+ else {
+ $rec->{total_passes}++;
+ $rec->{last_pass_time} = $end_time;
+ }
+}
+
+=head3 C<save>
+
+Write the state to a file.
+
+=cut
+
+sub save {
+ my ( $self, $name ) = @_;
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+ local *FH;
+ open FH, ">$name" or croak "Can't write $name ($!)";
+ $writer->write( $self->{_} || {}, \*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 ($!)";
+ $self->{_} = $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->{_}->{generation}++;
+}
+
+sub _prune_and_stamp {
+ my $self = shift;
+ for my $name ( keys %{ $self->{_}->{tests} || {} } ) {
+ if ( my @stat = stat $name ) {
+ $self->{_}->{tests}->{$name}->{mtime} = $stat[9];
+ }
+ else {
+ delete $self->{_}->{tests}->{$name};
+ }
+ }
+}
+
+sub _regen_seq {
+ my $self = shift;
+ for my $rec ( values %{ $self->{_}->{tests} || {} } ) {
+ $self->{seq} = $rec->{seq} + 1
+ if defined $rec->{seq} && $rec->{seq} >= $self->{seq};
+ }
+}
projects / dh-make-perl / blobdiff