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