package App::Prove::State;

use strict;
use vars qw($VERSION @ISA);

use File::Find;
use File::Spec;
use Carp;

use App::Prove::State::Result;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use TAP::Base;

BEGIN {
@ISA = qw( TAP::Base );
__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.26

=cut

$VERSION = '3.26';

=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>

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;