[p5sagit/p5-mst-13.2.git] / 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 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.13

=cut

$VERSION = '3.13';

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