Commit | Line | Data |
---|---|---|
7f01fda6 NC |
1 | package App::Prove::State; |
2 | ||
3 | use strict; | |
befb5359 | 4 | use warnings; |
f7c69158 | 5 | |
7f01fda6 NC |
6 | use File::Find; |
7 | use File::Spec; | |
8 | use Carp; | |
27fc0087 NC |
9 | |
10 | use App::Prove::State::Result; | |
7f01fda6 NC |
11 | use TAP::Parser::YAMLish::Reader (); |
12 | use TAP::Parser::YAMLish::Writer (); | |
406e3fef | 13 | use base 'TAP::Base'; |
7f01fda6 | 14 | |
bdaf8c65 | 15 | BEGIN { |
bdaf8c65 SH |
16 | __PACKAGE__->mk_methods('result_class'); |
17 | } | |
7f01fda6 NC |
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 | ||
406e3fef | 28 | Version 3.30 |
7f01fda6 NC |
29 | |
30 | =cut | |
31 | ||
406e3fef | 32 | our $VERSION = '3.30'; |
7f01fda6 NC |
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 | |
dbd04185 | 43 | $ prove --state=failed,save -rbv |
7f01fda6 NC |
44 | |
45 | =cut | |
46 | ||
47 | =head1 METHODS | |
48 | ||
49 | =head2 Class Methods | |
50 | ||
51 | =head3 C<new> | |
52 | ||
bdaf8c65 SH |
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 | ||
686add28 | 61 | =item * C<extensions> (optional) |
bdaf8c65 | 62 | |
686add28 | 63 | The test name extensions. Defaults to C<.t>. |
bdaf8c65 SH |
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 | ||
7f01fda6 NC |
71 | =cut |
72 | ||
f7c69158 | 73 | # override TAP::Base::new: |
7f01fda6 NC |
74 | sub new { |
75 | my $class = shift; | |
76 | my %args = %{ shift || {} }; | |
77 | ||
78 | my $self = bless { | |
f0e2c26d CBW |
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' ), | |
7f01fda6 NC |
85 | }, $class; |
86 | ||
bdaf8c65 SH |
87 | $self->{_} = $self->result_class->new( |
88 | { tests => {}, | |
89 | generation => 1, | |
90 | } | |
91 | ); | |
7f01fda6 NC |
92 | my $store = $self->{store}; |
93 | $self->load($store) | |
94 | if defined $store && -f $store; | |
95 | ||
96 | return $self; | |
97 | } | |
98 | ||
27fc0087 NC |
99 | =head2 C<result_class> |
100 | ||
bdaf8c65 SH |
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 | |
27fc0087 NC |
103 | identical interface. |
104 | ||
105 | =cut | |
106 | ||
686add28 | 107 | =head2 C<extensions> |
f7c69158 | 108 | |
686add28 CBW |
109 | Get or set the list of extensions that files must have in order to be |
110 | considered tests. Defaults to ['.t']. | |
f7c69158 NC |
111 | |
112 | =cut | |
113 | ||
686add28 | 114 | sub extensions { |
f7c69158 | 115 | my $self = shift; |
686add28 CBW |
116 | $self->{extensions} = shift if @_; |
117 | return $self->{extensions}; | |
f7c69158 NC |
118 | } |
119 | ||
27fc0087 NC |
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; | |
bdaf8c65 | 128 | $self->{_} || $self->result_class->new; |
27fc0087 NC |
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 { | |
7f01fda6 | 138 | my $self = shift; |
bdaf8c65 SH |
139 | if ( $self->{should_save} ) { |
140 | $self->save; | |
7f01fda6 NC |
141 | } |
142 | } | |
143 | ||
144 | =head2 Instance Methods | |
145 | ||
146 | =head3 C<apply_switch> | |
147 | ||
a39e16d8 SP |
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" | |
7f01fda6 NC |
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 | ||
27fc0087 NC |
210 | my $last_gen = $self->results->generation - 1; |
211 | my $last_run_time = $self->results->last_run_time; | |
212 | my $now = $self->get_time; | |
7f01fda6 NC |
213 | |
214 | my @switches = map { split /,/ } @opts; | |
215 | ||
216 | my %handler = ( | |
217 | last => sub { | |
218 | $self->_select( | |
f0e2c26d | 219 | limit => shift, |
27fc0087 NC |
220 | where => sub { $_->generation >= $last_gen }, |
221 | order => sub { $_->sequence } | |
7f01fda6 NC |
222 | ); |
223 | }, | |
224 | failed => sub { | |
225 | $self->_select( | |
f0e2c26d | 226 | limit => shift, |
27fc0087 NC |
227 | where => sub { $_->result != 0 }, |
228 | order => sub { -$_->result } | |
7f01fda6 NC |
229 | ); |
230 | }, | |
231 | passed => sub { | |
f0e2c26d CBW |
232 | $self->_select( |
233 | limit => shift, | |
234 | where => sub { $_->result == 0 } | |
235 | ); | |
7f01fda6 NC |
236 | }, |
237 | all => sub { | |
f0e2c26d | 238 | $self->_select( limit => shift ); |
7f01fda6 NC |
239 | }, |
240 | todo => sub { | |
241 | $self->_select( | |
f0e2c26d | 242 | limit => shift, |
27fc0087 NC |
243 | where => sub { $_->num_todo != 0 }, |
244 | order => sub { -$_->num_todo; } | |
7f01fda6 NC |
245 | ); |
246 | }, | |
247 | hot => sub { | |
248 | $self->_select( | |
f0e2c26d | 249 | limit => shift, |
27fc0087 NC |
250 | where => sub { defined $_->last_fail_time }, |
251 | order => sub { $now - $_->last_fail_time } | |
7f01fda6 NC |
252 | ); |
253 | }, | |
254 | slow => sub { | |
f0e2c26d CBW |
255 | $self->_select( |
256 | limit => shift, | |
257 | order => sub { -$_->elapsed } | |
258 | ); | |
7f01fda6 NC |
259 | }, |
260 | fast => sub { | |
f0e2c26d CBW |
261 | $self->_select( |
262 | limit => shift, | |
263 | order => sub { $_->elapsed } | |
264 | ); | |
7f01fda6 NC |
265 | }, |
266 | new => sub { | |
f0e2c26d CBW |
267 | $self->_select( |
268 | limit => shift, | |
269 | order => sub { -$_->mtime } | |
270 | ); | |
7f01fda6 NC |
271 | }, |
272 | old => sub { | |
f0e2c26d CBW |
273 | $self->_select( |
274 | limit => shift, | |
275 | order => sub { $_->mtime } | |
276 | ); | |
27fc0087 NC |
277 | }, |
278 | fresh => sub { | |
f0e2c26d CBW |
279 | $self->_select( |
280 | limit => shift, | |
281 | where => sub { $_->mtime >= $last_run_time } | |
282 | ); | |
7f01fda6 NC |
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 | } | |
a39e16d8 | 301 | return; |
7f01fda6 NC |
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} } ) { | |
f7c69158 NC |
324 | @argv = $recurse ? '.' : 't'; |
325 | croak qq{No tests named and '@argv' directory not found} | |
326 | unless -d $argv[0]; | |
7f01fda6 NC |
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" | |
27fc0087 | 337 | unless $self->results->num_tests; |
7f01fda6 NC |
338 | return map { $self->_query_clause($_) } @sel; |
339 | } | |
340 | return; | |
341 | } | |
342 | ||
343 | sub _query_clause { | |
344 | my ( $self, $clause ) = @_; | |
345 | my @got; | |
27fc0087 | 346 | my $results = $self->results; |
7f01fda6 NC |
347 | my $where = $clause->{where} || sub {1}; |
348 | ||
349 | # Select | |
27fc0087 NC |
350 | for my $name ( $results->test_names ) { |
351 | next unless -f $name; | |
352 | local $_ = $results->test($name); | |
353 | push @got, $name if $where->(); | |
7f01fda6 NC |
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 | [ $_, | |
27fc0087 | 364 | do { local $_ = $results->test($_); $order->() } |
7f01fda6 NC |
365 | ] |
366 | } @got; | |
367 | } | |
368 | ||
f0e2c26d CBW |
369 | if ( my $limit = $clause->{limit} ) { |
370 | @got = splice @got, 0, $limit if @got > $limit; | |
371 | } | |
372 | ||
7f01fda6 NC |
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. | |
f0e2c26d CBW |
383 | if (NEED_GLOB) { |
384 | eval "use File::Glob::Windows"; # [49732] | |
385 | @argv = map { glob "$_" } @argv; | |
386 | } | |
686add28 | 387 | my $extensions = $self->{extensions}; |
7f01fda6 NC |
388 | |
389 | for my $arg (@argv) { | |
390 | if ( '-' eq $arg ) { | |
391 | push @argv => <STDIN>; | |
392 | chomp(@argv); | |
393 | next; | |
394 | } | |
395 | ||
396 | push @tests, | |
69f36734 | 397 | sort -d $arg |
7f01fda6 | 398 | ? $recurse |
686add28 | 399 | ? $self->_expand_dir_recursive( $arg, $extensions ) |
f0e2c26d CBW |
400 | : map { glob( File::Spec->catfile( $arg, "*$_" ) ) } |
401 | @{$extensions} | |
7f01fda6 NC |
402 | : $arg; |
403 | } | |
404 | return @tests; | |
405 | } | |
406 | ||
407 | sub _expand_dir_recursive { | |
686add28 | 408 | my ( $self, $dir, $extensions ) = @_; |
7f01fda6 NC |
409 | |
410 | my @tests; | |
f0e2c26d | 411 | my $ext_string = join( '|', map {quotemeta} @{$extensions} ); |
686add28 | 412 | |
7f01fda6 | 413 | find( |
27fc0087 NC |
414 | { follow => 1, #21938 |
415 | follow_skip => 2, | |
416 | wanted => sub { | |
f0e2c26d | 417 | -f |
686add28 | 418 | && /(?:$ext_string)$/ |
7f01fda6 NC |
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 | ||
7f01fda6 NC |
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 | |
bdaf8c65 SH |
442 | # parser |
443 | ||
444 | sub observe_test { | |
7f01fda6 | 445 | |
bdaf8c65 SH |
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); | |
7f01fda6 | 454 | |
27fc0087 NC |
455 | $test->sequence( $self->{seq}++ ); |
456 | $test->generation( $self->results->generation ); | |
7f01fda6 | 457 | |
27fc0087 NC |
458 | $test->run_time($end_time); |
459 | $test->result($fail); | |
460 | $test->num_todo($todo); | |
461 | $test->elapsed( $end_time - $start_time ); | |
7f01fda6 | 462 | |
bdaf8c65 SH |
463 | $test->parser($parser); |
464 | ||
7f01fda6 | 465 | if ($fail) { |
27fc0087 NC |
466 | $test->total_failures( $test->total_failures + 1 ); |
467 | $test->last_fail_time($end_time); | |
7f01fda6 NC |
468 | } |
469 | else { | |
27fc0087 NC |
470 | $test->total_passes( $test->total_passes + 1 ); |
471 | $test->last_pass_time($end_time); | |
7f01fda6 NC |
472 | } |
473 | } | |
474 | ||
475 | =head3 C<save> | |
476 | ||
477 | Write the state to a file. | |
478 | ||
479 | =cut | |
480 | ||
481 | sub save { | |
bdaf8c65 | 482 | my ($self) = @_; |
27fc0087 | 483 | |
bdaf8c65 | 484 | my $store = $self->{store} or return; |
27fc0087 NC |
485 | $self->results->last_run_time( $self->get_time ); |
486 | ||
7f01fda6 NC |
487 | my $writer = TAP::Parser::YAMLish::Writer->new; |
488 | local *FH; | |
bdaf8c65 | 489 | open FH, ">$store" or croak "Can't write $store ($!)"; |
27fc0087 | 490 | $writer->write( $self->results->raw, \*FH ); |
7f01fda6 NC |
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 ($!)"; | |
27fc0087 NC |
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 | ) | |
7f01fda6 NC |
515 | ); |
516 | ||
517 | # $writer->write( $self->{tests} || {}, \*FH ); | |
518 | close FH; | |
519 | $self->_regen_seq; | |
69f36734 | 520 | $self->_prune_and_stamp; |
27fc0087 | 521 | $self->results->generation( $self->results->generation + 1 ); |
7f01fda6 NC |
522 | } |
523 | ||
69f36734 AA |
524 | sub _prune_and_stamp { |
525 | my $self = shift; | |
27fc0087 NC |
526 | |
527 | my $results = $self->results; | |
528 | my @tests = $self->results->tests; | |
529 | for my $test (@tests) { | |
530 | my $name = $test->name; | |
69f36734 | 531 | if ( my @stat = stat $name ) { |
27fc0087 | 532 | $test->mtime( $stat[9] ); |
69f36734 AA |
533 | } |
534 | else { | |
27fc0087 | 535 | $results->remove($name); |
69f36734 AA |
536 | } |
537 | } | |
538 | } | |
539 | ||
7f01fda6 NC |
540 | sub _regen_seq { |
541 | my $self = shift; | |
27fc0087 NC |
542 | for my $test ( $self->results->tests ) { |
543 | $self->{seq} = $test->sequence + 1 | |
544 | if defined $test->sequence && $test->sequence >= $self->{seq}; | |
7f01fda6 NC |
545 | } |
546 | } | |
27fc0087 NC |
547 | |
548 | 1; |