File Coverage

blib/lib/App/Prove/State.pm
Criterion Covered Total %
statement 157 206 76.2
branch 29 62 46.7
condition 12 25 48.0
subroutine 37 44 84.0
pod 9 9 100.0
total 244 346 70.5


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