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 | |
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 | } |