1package App::Prove::State;
2
3use strict;
4use warnings;
5
6use File::Find;
7use File::Spec;
8use Carp;
9
10use App::Prove::State::Result;
11use TAP::Parser::YAMLish::Reader ();
12use TAP::Parser::YAMLish::Writer ();
13use base 'TAP::Base';
14
15BEGIN {
16    __PACKAGE__->mk_methods('result_class');
17}
18
19use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
20use constant NEED_GLOB => IS_WIN32;
21
22=head1 NAME
23
24App::Prove::State - State storage for the C<prove> command.
25
26=head1 VERSION
27
28Version 3.48
29
30=cut
31
32our $VERSION = '3.48';
33
34=head1 DESCRIPTION
35
36The C<prove> command supports a C<--state> option that instructs it to
37store persistent state across runs. This module implements that state
38and 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
53Accepts a hashref with the following key/value pairs:
54
55=over 4
56
57=item * C<store>
58
59The filename of the data store holding the data that App::Prove::State reads.
60
61=item * C<extensions> (optional)
62
63The test name extensions.  Defaults to C<.t>.
64
65=item * C<result_class> (optional)
66
67The 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:
74sub 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
101Getter/setter for the name of the class used for tracking test results.  This
102class should either subclass from C<App::Prove::State::Result> or provide an
103identical interface.
104
105=cut
106
107=head2 C<extensions>
108
109Get or set the list of extensions that files must have in order to be
110considered tests. Defaults to ['.t'].
111
112=cut
113
114sub extensions {
115    my $self = shift;
116    $self->{extensions} = shift if @_;
117    return $self->{extensions};
118}
119
120=head2 C<results>
121
122Get the results of the last test run.  Returns a C<result_class()> instance.
123
124=cut
125
126sub results {
127    my $self = shift;
128    $self->{_} || $self->result_class->new;
129}
130
131=head2 C<commit>
132
133Save the test results. Should be called after all tests have run.
134
135=cut
136
137sub 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
150Apply a list of switch options to the state, updating the internal
151object state as a result. Nothing is returned.
152
153Diagnostics:
154    - "Illegal state option: %s"
155
156=over
157
158=item C<last>
159
160Run in the same order as last time
161
162=item C<failed>
163
164Run only the failed tests from last time
165
166=item C<passed>
167
168Run only the passed tests from last time
169
170=item C<all>
171
172Run all tests in normal order
173
174=item C<hot>
175
176Run the tests that most recently failed first
177
178=item C<todo>
179
180Run the tests ordered by number of todos.
181
182=item C<slow>
183
184Run the tests in slowest to fastest order.
185
186=item C<fast>
187
188Run test tests in fastest to slowest order.
189
190=item C<new>
191
192Run the tests in newest to oldest order.
193
194=item C<old>
195
196Run the tests in oldest to newest order.
197
198=item C<save>
199
200Save the state on exit.
201
202=back
203
204=cut
205
206sub 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
304sub _select {
305    my ( $self, %spec ) = @_;
306    push @{ $self->{select} }, \%spec;
307}
308
309=head3 C<get_tests>
310
311Given a list of args get the names of tests that should run
312
313=cut
314
315sub 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
333sub _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
343sub _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
376sub _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
407sub _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
429Store 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
444sub 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
477Write the state to a file.
478
479=cut
480
481sub 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
496Load the state from a file
497
498=cut
499
500sub 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
524sub _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
540sub _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
5481;
549