lib/App/Prove/State.pm

   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.06
  24
  25 =cut
  26
  27 $VERSION = '3.06';
  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( order => sub { -$_->{mtime} } );
 182         },
 183         old => sub {
 184             $self->_select( order => sub { $_->{mtime} } );
 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 ) {
 252         next unless -f $test;
 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,
 290             sort -d $arg
 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;
 399     $self->_prune_and_stamp;
 400     $self->{_}->{generation}++;
 401 }
 402
 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
 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 }