This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Missing files from Test::Harness 3.05
[perl5.git] / lib / App / Prove / State.pm
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
23 Version 3.05
24
25 =cut
26
27 $VERSION = '3.05';
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 {
181             $self->_select(
182                 order => sub {
183                         ( $_->{total_failures} || 0 )
184                       + ( $_->{total_passes} || 0 );
185                 }
186             );
187         },
188         old => sub {
189             $self->_select(
190                 order => sub {
191                     -(    ( $_->{total_failures} || 0 )
192                         + ( $_->{total_passes} || 0 ) );
193                 }
194             );
195         },
196         save => sub {
197             $self->{should_save}++;
198         },
199         adrian => sub {
200             unshift @switches, qw( hot all save );
201         },
202     );
203
204     while ( defined( my $ele = shift @switches ) ) {
205         my ( $opt, $arg )
206           = ( $ele =~ /^([^:]+):(.*)/ )
207           ? ( $1, $2 )
208           : ( $ele, undef );
209         my $code = $handler{$opt}
210           || croak "Illegal state option: $opt";
211         $code->($arg);
212     }
213 }
214
215 sub _select {
216     my ( $self, %spec ) = @_;
217     push @{ $self->{select} }, \%spec;
218 }
219
220 =head3 C<get_tests>
221
222 Given a list of args get the names of tests that should run
223
224 =cut
225
226 sub get_tests {
227     my $self    = shift;
228     my $recurse = shift;
229     my @argv    = @_;
230     my %seen;
231
232     my @selected = $self->_query;
233
234     unless ( @argv || @{ $self->{select} } ) {
235         croak q{No tests named and 't' directory not found}
236           unless -d 't';
237         @argv = 't';
238     }
239
240     push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
241     return grep { !$seen{$_}++ } @selected;
242 }
243
244 sub _query {
245     my $self = shift;
246     if ( my @sel = @{ $self->{select} } ) {
247         warn "No saved state, selection will be empty\n"
248           unless keys %{ $self->{_}->{tests} };
249         return map { $self->_query_clause($_) } @sel;
250     }
251     return;
252 }
253
254 sub _query_clause {
255     my ( $self, $clause ) = @_;
256     my @got;
257     my $tests = $self->{_}->{tests};
258     my $where = $clause->{where} || sub {1};
259
260     # Select
261     for my $test ( sort keys %$tests ) {
262         local $_ = $tests->{$test};
263         push @got, $test if $where->();
264     }
265
266     # Sort
267     if ( my $order = $clause->{order} ) {
268         @got = map { $_->[0] }
269           sort {
270                  ( defined $b->[1] <=> defined $a->[1] )
271               || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
272           } map {
273             [   $_,
274                 do { local $_ = $tests->{$_}; $order->() }
275             ]
276           } @got;
277     }
278
279     return @got;
280 }
281
282 sub _get_raw_tests {
283     my $self    = shift;
284     my $recurse = shift;
285     my @argv    = @_;
286     my @tests;
287
288     # Do globbing on Win32.
289     @argv = map { glob "$_" } @argv if NEED_GLOB;
290
291     for my $arg (@argv) {
292         if ( '-' eq $arg ) {
293             push @argv => <STDIN>;
294             chomp(@argv);
295             next;
296         }
297
298         push @tests,
299           sort -d $arg
300           ? $recurse
301               ? $self->_expand_dir_recursive($arg)
302               : glob( File::Spec->catfile( $arg, '*.t' ) )
303           : $arg;
304     }
305     return @tests;
306 }
307
308 sub _expand_dir_recursive {
309     my ( $self, $dir ) = @_;
310
311     my @tests;
312     find(
313         {   follow => 1,      #21938
314             wanted => sub {
315                 -f 
316                   && /\.t$/
317                   && push @tests => $File::Find::name;
318               }
319         },
320         $dir
321     );
322     return @tests;
323 }
324
325 =head3 C<observe_test>
326
327 Store the results of a test.
328
329 =cut
330
331 sub observe_test {
332     my ( $self, $test, $parser ) = @_;
333     $self->_record_test(
334         $test, scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
335         scalar( $parser->todo ), $parser->start_time, $parser->end_time
336     );
337 }
338
339 # Store:
340 #     last fail time
341 #     last pass time
342 #     last run time
343 #     most recent result
344 #     most recent todos
345 #     total failures
346 #     total passes
347 #     state generation
348
349 sub _record_test {
350     my ( $self, $test, $fail, $todo, $start_time, $end_time ) = @_;
351     my $rec = $self->{_}->{tests}->{ $test->[0] } ||= {};
352
353     $rec->{seq} = $self->{seq}++;
354     $rec->{gen} = $self->{_}->{generation};
355
356     $rec->{last_run_time} = $end_time;
357     $rec->{last_result}   = $fail;
358     $rec->{last_todo}     = $todo;
359     $rec->{elapsed}       = $end_time - $start_time;
360
361     if ($fail) {
362         $rec->{total_failures}++;
363         $rec->{last_fail_time} = $end_time;
364     }
365     else {
366         $rec->{total_passes}++;
367         $rec->{last_pass_time} = $end_time;
368     }
369 }
370
371 =head3 C<save>
372
373 Write the state to a file.
374
375 =cut
376
377 sub save {
378     my ( $self, $name ) = @_;
379     my $writer = TAP::Parser::YAMLish::Writer->new;
380     local *FH;
381     open FH, ">$name" or croak "Can't write $name ($!)";
382     $writer->write( $self->{_} || {}, \*FH );
383     close FH;
384 }
385
386 =head3 C<load>
387
388 Load the state from a file
389
390 =cut
391
392 sub load {
393     my ( $self, $name ) = @_;
394     my $reader = TAP::Parser::YAMLish::Reader->new;
395     local *FH;
396     open FH, "<$name" or croak "Can't read $name ($!)";
397     $self->{_} = $reader->read(
398         sub {
399             my $line = <FH>;
400             defined $line && chomp $line;
401             return $line;
402         }
403     );
404
405     # $writer->write( $self->{tests} || {}, \*FH );
406     close FH;
407     $self->_regen_seq;
408     $self->{_}->{generation}++;
409 }
410
411 sub _regen_seq {
412     my $self = shift;
413     for my $rec ( values %{ $self->{_}->{tests} || {} } ) {
414         $self->{seq} = $rec->{seq} + 1
415           if defined $rec->{seq} && $rec->{seq} >= $self->{seq};
416     }
417 }