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

package App::Prove::State;

use strict;
use File::Find;
use File::Spec;
use Carp;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use TAP::Base;

use vars qw($VERSION @ISA);
@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.06

=cut

$VERSION = '3.06';

=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

sub new {
    my $class = shift;
    my %args = %{ shift || {} };

    my $self = bless {
        _ => {
            tests      => {},
            generation => 1
        },
        select => [],
        seq    => 1,
        store  => delete $args{store},
    }, $class;

    my $store = $self->{store};
    $self->load($store)
      if defined $store && -f $store;

    return $self;
}

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} } ) {
        croak q{No tests named and 't' directory not found}
          unless -d 't';
        @argv = 't';
    }

    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;

    for my $arg (@argv) {
        if ( '-' eq $arg ) {
            push @argv => <STDIN>;
            chomp(@argv);
            next;
        }

        push @tests,
            sort -d $arg
          ? $recurse
              ? $self->_expand_dir_recursive($arg)
              : glob( File::Spec->catfile( $arg, '*.t' ) )
          : $arg;
    }
    return @tests;
}

sub _expand_dir_recursive {
    my ( $self, $dir ) = @_;

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