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