[p5sagit/p5-mst-13.2.git] / ext / Test / Harness / lib / App / Prove / State.pm

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;

@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.14

=cut

$VERSION = '3.14';

=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 {
        _ => $class->result_class->new(
            {   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<result_class>

Returns 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

sub result_class {
    return 'App::Prove::State::Result';
}

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

=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} && 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->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(
                where => sub { $_->generation >= $last_gen },
                order => sub { $_->sequence }
            );
        },
        failed => sub {
            $self->_select(
                where => sub { $_->result != 0 },
                order => sub { -$_->result }
            );
        },
        passed => sub {
            $self->_select( where => sub { $_->result == 0 } );
        },
        all => sub {
            $self->_select();
        },
        todo => sub {
            $self->_select(
                where => sub { $_->num_todo != 0 },
                order => sub { -$_->num_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 } );
        },
        fresh => sub {
            $self->_select( 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);
    }
}

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;
    }

    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
            follow_skip => 2,
            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->[0],
        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, $name, $fail, $todo, $start_time, $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 );

    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, $name ) = @_;

    $self->results->last_run_time( $self->get_time );

    my $writer = TAP::Parser::YAMLish::Writer->new;
    local *FH;
    open FH, ">$name" or croak "Can't write $name ($!)";
    $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;
Commit	Line	Data
7f01fda6	1	package App::Prove::State;
	2
	3	use strict;
f7c69158	4	use vars qw($VERSION @ISA);
f7c69158	5
7f01fda6	6	use File::Find;
	7	use File::Spec;
	8	use Carp;
27fc0087	9
27fc0087	10	use App::Prove::State::Result;
7f01fda6	11	use TAP::Parser::YAMLish::Reader ();
	12	use TAP::Parser::YAMLish::Writer ();
	13	use TAP::Base;
	14
7f01fda6	15	@ISA = qw( TAP::Base );
	16
	17	use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
	18	use constant NEED_GLOB => IS_WIN32;
	19
	20	=head1 NAME
	21
	22	App::Prove::State - State storage for the C<prove> command.
	23
	24	=head1 VERSION
	25
27fc0087	26	Version 3.14
7f01fda6	27
	28	=cut
	29
27fc0087	30	$VERSION = '3.14';
7f01fda6	31
	32	=head1 DESCRIPTION
	33
	34	The C<prove> command supports a C<--state> option that instructs it to
	35	store persistent state across runs. This module implements that state
	36	and the operations that may be performed on it.
	37
	38	=head1 SYNOPSIS
	39
	40	# Re-run failed tests
	41	$ prove --state=fail,save -rbv
	42
	43	=cut
	44
	45	=head1 METHODS
	46
	47	=head2 Class Methods
	48
	49	=head3 C<new>
	50
	51	=cut
	52
f7c69158	53	# override TAP::Base::new:
7f01fda6	54	sub new {
	55	my $class = shift;
	56	my %args = %{ shift \|\| {} };
	57
	58	my $self = bless {
27fc0087	59	_ => $class->result_class->new(
	60	{ tests => {},
	61	generation => 1,
	62	}
	63	),
f7c69158	64	select => [],
	65	seq => 1,
	66	store => delete $args{store},
	67	extension => delete $args{extension} \|\| '.t',
7f01fda6	68	}, $class;
	69
	70	my $store = $self->{store};
	71	$self->load($store)
	72	if defined $store && -f $store;
	73
	74	return $self;
	75	}
	76
27fc0087	77	=head2 C<result_class>
	78
	79	Returns the name of the class used for tracking test results. This class
	80	should either subclass from C<App::Prove::State::Result> or provide an
	81	identical interface.
	82
	83	=cut
	84
	85	sub result_class {
	86	return 'App::Prove::State::Result';
	87	}
	88
f7c69158	89	=head2 C<extension>
	90
	91	Get or set the extension files must have in order to be considered
	92	tests. Defaults to '.t'.
	93
	94	=cut
	95
	96	sub extension {
	97	my $self = shift;
	98	$self->{extension} = shift if @_;
	99	return $self->{extension};
	100	}
	101
27fc0087	102	=head2 C<results>
	103
	104	Get the results of the last test run. Returns a C<result_class()> instance.
	105
	106	=cut
	107
	108	sub results {
	109	my $self = shift;
	110	$self->{_} \|\| $self->result_class->new
	111	}
	112
	113	=head2 C<commit>
	114
	115	Save the test results. Should be called after all tests have run.
	116
	117	=cut
	118
	119	sub commit {
7f01fda6	120	my $self = shift;
	121	if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
	122	$self->save($store);
	123	}
	124	}
	125
	126	=head2 Instance Methods
	127
	128	=head3 C<apply_switch>
	129
	130	Apply a list of switch options to the state.
	131
	132	=over
	133
	134	=item C<last>
	135
	136	Run in the same order as last time
	137
	138	=item C<failed>
	139
	140	Run only the failed tests from last time
	141
	142	=item C<passed>
	143
	144	Run only the passed tests from last time
	145
	146	=item C<all>
	147
	148	Run all tests in normal order
	149
	150	=item C<hot>
	151
	152	Run the tests that most recently failed first
	153
	154	=item C<todo>
	155
	156	Run the tests ordered by number of todos.
	157
	158	=item C<slow>
	159
	160	Run the tests in slowest to fastest order.
	161
	162	=item C<fast>
	163
	164	Run test tests in fastest to slowest order.
	165
	166	=item C<new>
	167
	168	Run the tests in newest to oldest order.
	169
	170	=item C<old>
	171
	172	Run the tests in oldest to newest order.
	173
	174	=item C<save>
	175
	176	Save the state on exit.
	177
	178	=back
	179
	180	=cut
	181
	182	sub apply_switch {
	183	my $self = shift;
184	my @opts = @_;
185
27fc0087	186	my $last_gen = $self->results->generation - 1;
	187	my $last_run_time = $self->results->last_run_time;
	188	my $now = $self->get_time;
7f01fda6	189
	190	my @switches = map { split /,/ } @opts;
	191
	192	my %handler = (
	193	last => sub {
	194	$self->_select(
27fc0087	195	where => sub { $_->generation >= $last_gen },
27fc0087	196	order => sub { $_->sequence }
7f01fda6	197	);
	198	},
	199	failed => sub {
	200	$self->_select(
27fc0087	201	where => sub { $_->result != 0 },
27fc0087	202	order => sub { -$_->result }
7f01fda6	203	);
	204	},
	205	passed => sub {
27fc0087	206	$self->_select( where => sub { $_->result == 0 } );
7f01fda6	207	},
	208	all => sub {
	209	$self->_select();
	210	},
	211	todo => sub {
	212	$self->_select(
27fc0087	213	where => sub { $_->num_todo != 0 },
27fc0087	214	order => sub { -$_->num_todo; }
7f01fda6	215	);
	216	},
	217	hot => sub {
	218	$self->_select(
27fc0087	219	where => sub { defined $_->last_fail_time },
27fc0087	220	order => sub { $now - $_->last_fail_time }
7f01fda6	221	);
	222	},
	223	slow => sub {
27fc0087	224	$self->_select( order => sub { -$_->elapsed } );
7f01fda6	225	},
7f01fda6	226	fast => sub {
27fc0087	227	$self->_select( order => sub { $_->elapsed } );
7f01fda6	228	},
7f01fda6	229	new => sub {
27fc0087	230	$self->_select( order => sub { -$_->mtime } );
7f01fda6	231	},
7f01fda6	232	old => sub {
27fc0087	233	$self->_select( order => sub { $_->mtime } );
	234	},
	235	fresh => sub {
	236	$self->_select( where => sub { $_->mtime >= $last_run_time } );
7f01fda6	237	},
	238	save => sub {
	239	$self->{should_save}++;
	240	},
	241	adrian => sub {
	242	unshift @switches, qw( hot all save );
	243	},
	244	);
	245
	246	while ( defined( my $ele = shift @switches ) ) {
	247	my ( $opt, $arg )
	248	= ( $ele =~ /^([^:]+):(.*)/ )
	249	? ( $1, $2 )
	250	: ( $ele, undef );
	251	my $code = $handler{$opt}
	252	\|\| croak "Illegal state option: $opt";
	253	$code->($arg);
	254	}
	255	}
	256
	257	sub _select {
	258	my ( $self, %spec ) = @_;
	259	push @{ $self->{select} }, \%spec;
	260	}
	261
	262	=head3 C<get_tests>
	263
	264	Given a list of args get the names of tests that should run
	265
	266	=cut
	267
	268	sub get_tests {
	269	my $self = shift;
	270	my $recurse = shift;
	271	my @argv = @_;
	272	my %seen;
	273
	274	my @selected = $self->_query;
	275
	276	unless ( @argv \|\| @{ $self->{select} } ) {
f7c69158	277	@argv = $recurse ? '.' : 't';
	278	croak qq{No tests named and '@argv' directory not found}
	279	unless -d $argv[0];
7f01fda6	280	}
	281
	282	push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
	283	return grep { !$seen{$_}++ } @selected;
	284	}
	285
	286	sub _query {
	287	my $self = shift;
	288	if ( my @sel = @{ $self->{select} } ) {
	289	warn "No saved state, selection will be empty\n"
27fc0087	290	unless $self->results->num_tests;
7f01fda6	291	return map { $self->_query_clause($_) } @sel;
	292	}
	293	return;
	294	}
	295
	296	sub _query_clause {
	297	my ( $self, $clause ) = @_;
	298	my @got;
27fc0087	299	my $results = $self->results;
7f01fda6	300	my $where = $clause->{where} \|\| sub {1};
	301
	302	# Select
27fc0087	303	for my $name ( $results->test_names ) {
	304	next unless -f $name;
	305	local $_ = $results->test($name);
	306	push @got, $name if $where->();
7f01fda6	307	}
	308
	309	# Sort
	310	if ( my $order = $clause->{order} ) {
	311	@got = map { $_->[0] }
	312	sort {
	313	( defined $b->[1] <=> defined $a->[1] )
	314	\|\| ( ( $a->[1] \|\| 0 ) <=> ( $b->[1] \|\| 0 ) )
	315	} map {
	316	[ $_,
27fc0087	317	do { local $_ = $results->test($_); $order->() }
7f01fda6	318	]
	319	} @got;
	320	}
	321
	322	return @got;
	323	}
	324
	325	sub _get_raw_tests {
	326	my $self = shift;
	327	my $recurse = shift;
	328	my @argv = @_;
	329	my @tests;
	330
	331	# Do globbing on Win32.
	332	@argv = map { glob "$_" } @argv if NEED_GLOB;
f7c69158	333	my $extension = $self->{extension};
7f01fda6	334
	335	for my $arg (@argv) {
	336	if ( '-' eq $arg ) {
	337	push @argv => <STDIN>;
	338	chomp(@argv);
	339	next;
	340	}
	341
	342	push @tests,
69f36734	343	sort -d $arg
7f01fda6	344	? $recurse
f7c69158	345	? $self->_expand_dir_recursive( $arg, $extension )
f7c69158	346	: glob( File::Spec->catfile( $arg, "*$extension" ) )
7f01fda6	347	: $arg;
	348	}
	349	return @tests;
	350	}
	351
	352	sub _expand_dir_recursive {
f7c69158	353	my ( $self, $dir, $extension ) = @_;
7f01fda6	354
	355	my @tests;
	356	find(
27fc0087	357	{ follow => 1, #21938
	358	follow_skip => 2,
	359	wanted => sub {
7f01fda6	360	-f
f7c69158	361	&& /\Q$extension\E$/
7f01fda6	362	&& push @tests => $File::Find::name;
	363	}
	364	},
	365	$dir
	366	);
	367	return @tests;
	368	}
	369
	370	=head3 C<observe_test>
	371
	372	Store the results of a test.
	373
	374	=cut
	375
	376	sub observe_test {
	377	my ( $self, $test, $parser ) = @_;
	378	$self->_record_test(
27fc0087	379	$test->[0],
	380	scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
	381	scalar( $parser->todo ), $parser->start_time, $parser->end_time,
7f01fda6	382	);
	383	}
	384
	385	# Store:
	386	# last fail time
	387	# last pass time
	388	# last run time
	389	# most recent result
	390	# most recent todos
	391	# total failures
	392	# total passes
	393	# state generation
	394
	395	sub _record_test {
27fc0087	396	my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_;
27fc0087	397	my $test = $self->results->test($name);
7f01fda6	398
27fc0087	399	$test->sequence( $self->{seq}++ );
27fc0087	400	$test->generation( $self->results->generation );
7f01fda6	401
27fc0087	402	$test->run_time($end_time);
	403	$test->result($fail);
	404	$test->num_todo($todo);
	405	$test->elapsed( $end_time - $start_time );
7f01fda6	406
7f01fda6	407	if ($fail) {
27fc0087	408	$test->total_failures( $test->total_failures + 1 );
27fc0087	409	$test->last_fail_time($end_time);
7f01fda6	410	}
7f01fda6	411	else {
27fc0087	412	$test->total_passes( $test->total_passes + 1 );
27fc0087	413	$test->last_pass_time($end_time);
7f01fda6	414	}
	415	}
	416
	417	=head3 C<save>
	418
	419	Write the state to a file.
	420
	421	=cut
	422
	423	sub save {
	424	my ( $self, $name ) = @_;
27fc0087	425
	426	$self->results->last_run_time( $self->get_time );
	427
7f01fda6	428	my $writer = TAP::Parser::YAMLish::Writer->new;
	429	local *FH;
	430	open FH, ">$name" or croak "Can't write $name ($!)";
27fc0087	431	$writer->write( $self->results->raw, \*FH );
7f01fda6	432	close FH;
	433	}
	434
	435	=head3 C<load>
	436
	437	Load the state from a file
	438
	439	=cut
	440
	441	sub load {
	442	my ( $self, $name ) = @_;
	443	my $reader = TAP::Parser::YAMLish::Reader->new;
	444	local *FH;
	445	open FH, "<$name" or croak "Can't read $name ($!)";
27fc0087	446
	447	# XXX this is temporary
	448	$self->{_} = $self->result_class->new(
	449	$reader->read(
	450	sub {
	451	my $line = <FH>;
	452	defined $line && chomp $line;
	453	return $line;
	454	}
	455	)
7f01fda6	456	);
	457
	458	# $writer->write( $self->{tests} \|\| {}, \*FH );
	459	close FH;
	460	$self->_regen_seq;
69f36734	461	$self->_prune_and_stamp;
27fc0087	462	$self->results->generation( $self->results->generation + 1 );
7f01fda6	463	}
7f01fda6	464
69f36734	465	sub _prune_and_stamp {
69f36734	466	my $self = shift;
27fc0087	467
	468	my $results = $self->results;
	469	my @tests = $self->results->tests;
	470	for my $test (@tests) {
	471	my $name = $test->name;
69f36734	472	if ( my @stat = stat $name ) {
27fc0087	473	$test->mtime( $stat[9] );
69f36734	474	}
69f36734	475	else {
27fc0087	476	$results->remove($name);
69f36734	477	}
	478	}
	479	}
	480
7f01fda6	481	sub _regen_seq {
7f01fda6	482	my $self = shift;
27fc0087	483	for my $test ( $self->results->tests ) {
	484	$self->{seq} = $test->sequence + 1
	485	if defined $test->sequence && $test->sequence >= $self->{seq};
7f01fda6	486	}
7f01fda6	487	}
27fc0087	488
27fc0087	489	1;