[gitmo/moose-presentations.git] / moose-class / exercises / t / lib / Test / 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;

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.17

=cut

$VERSION = '3.17';

=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<extension> (optional)

The test name extension.  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},
        extension => ( delete $args{extension} || '.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<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} ) {
        $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(
                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);
    }
    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;
    }

    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

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