ext/Test/Harness/lib/App/Prove/State.pm

   1 package App::Prove::State;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA);
   5
   6 use File::Find;
   7 use File::Spec;
   8 use Carp;
   9
  10 use App::Prove::State::Result;
  11 use TAP::Parser::YAMLish::Reader ();
  12 use TAP::Parser::YAMLish::Writer ();
  13 use TAP::Base;
  14
  15 @ISA = qw( TAP::Base );
  16
  17 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
  18 use constant NEED_GLOB => IS_WIN32;
  19
  20 =head1 NAME
  21
  22 App::Prove::State - State storage for the C<prove> command.
  23
  24 =head1 VERSION
  25
  26 Version 3.14
  27
  28 =cut
  29
  30 $VERSION = '3.14';
  31
  32 =head1 DESCRIPTION
  33
  34 The C<prove> command supports a C<--state> option that instructs it to
  35 store persistent state across runs. This module implements that state
  36 and the operations that may be performed on it.
  37
  38 =head1 SYNOPSIS
  39
  40     # Re-run failed tests
  41     $ prove --state=fail,save -rbv
  42
  43 =cut
  44
  45 =head1 METHODS
  46
  47 =head2 Class Methods
  48
  49 =head3 C<new>
  50
  51 =cut
  52
  53 # override TAP::Base::new:
  54 sub new {
  55     my $class = shift;
  56     my %args = %{ shift || {} };
  57
  58     my $self = bless {
  59         _ => $class->result_class->new(
  60             {   tests      => {},
  61                 generation => 1,
  62             }
  63         ),
  64         select    => [],
  65         seq       => 1,
  66         store     => delete $args{store},
  67         extension => delete $args{extension} || '.t',
  68     }, $class;
  69
  70     my $store = $self->{store};
  71     $self->load($store)
  72       if defined $store && -f $store;
  73
  74     return $self;
  75 }
  76
  77 =head2 C<result_class>
  78
  79 Returns the name of the class used for tracking test results.  This class
  80 should either subclass from C<App::Prove::State::Result> or provide an
  81 identical interface.
  82
  83 =cut
  84
  85 sub result_class {
  86     return 'App::Prove::State::Result';
  87 }
  88
  89 =head2 C<extension>
  90
  91 Get or set the extension files must have in order to be considered
  92 tests. Defaults to '.t'.
  93
  94 =cut
  95
  96 sub extension {
  97     my $self = shift;
  98     $self->{extension} = shift if @_;
  99     return $self->{extension};
 100 }
 101
 102 =head2 C<results>
 103
 104 Get the results of the last test run.  Returns a C<result_class()> instance.
 105
 106 =cut
 107
 108 sub results {
 109     my $self = shift;
 110     $self->{_} || $self->result_class->new
 111 }
 112
 113 =head2 C<commit>
 114
 115 Save the test results. Should be called after all tests have run.
 116
 117 =cut
 118
 119 sub commit {
 120     my $self = shift;
 121     if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
 122         $self->save($store);
 123     }
 124 }
 125
 126 =head2 Instance Methods
 127
 128 =head3 C<apply_switch>
 129
 130 Apply a list of switch options to the state.
 131
 132 =over
 133
 134 =item C<last>
 135
 136 Run in the same order as last time
 137
 138 =item C<failed>
 139
 140 Run only the failed tests from last time
 141
 142 =item C<passed>
 143
 144 Run only the passed tests from last time
 145
 146 =item C<all>
 147
 148 Run all tests in normal order
 149
 150 =item C<hot>
 151
 152 Run the tests that most recently failed first
 153
 154 =item C<todo>
 155
 156 Run the tests ordered by number of todos.
 157
 158 =item C<slow>
 159
 160 Run the tests in slowest to fastest order.
 161
 162 =item C<fast>
 163
 164 Run test tests in fastest to slowest order.
 165
 166 =item C<new>
 167
 168 Run the tests in newest to oldest order.
 169
 170 =item C<old>
 171
 172 Run the tests in oldest to newest order.
 173
 174 =item C<save>
 175
 176 Save the state on exit.
 177
 178 =back
 179
 180 =cut
 181
 182 sub apply_switch {
 183     my $self = shift;
 184     my @opts = @_;
 185
 186     my $last_gen      = $self->results->generation - 1;
 187     my $last_run_time = $self->results->last_run_time;
 188     my $now           = $self->get_time;
 189
 190     my @switches = map { split /,/ } @opts;
 191
 192     my %handler = (
 193         last => sub {
 194             $self->_select(
 195                 where => sub { $_->generation >= $last_gen },
 196                 order => sub { $_->sequence }
 197             );
 198         },
 199         failed => sub {
 200             $self->_select(
 201                 where => sub { $_->result != 0 },
 202                 order => sub { -$_->result }
 203             );
 204         },
 205         passed => sub {
 206             $self->_select( where => sub { $_->result == 0 } );
 207         },
 208         all => sub {
 209             $self->_select();
 210         },
 211         todo => sub {
 212             $self->_select(
 213                 where => sub { $_->num_todo != 0 },
 214                 order => sub { -$_->num_todo; }
 215             );
 216         },
 217         hot => sub {
 218             $self->_select(
 219                 where => sub { defined $_->last_fail_time },
 220                 order => sub { $now - $_->last_fail_time }
 221             );
 222         },
 223         slow => sub {
 224             $self->_select( order => sub { -$_->elapsed } );
 225         },
 226         fast => sub {
 227             $self->_select( order => sub { $_->elapsed } );
 228         },
 229         new => sub {
 230             $self->_select( order => sub { -$_->mtime } );
 231         },
 232         old => sub {
 233             $self->_select( order => sub { $_->mtime } );
 234         },
 235         fresh => sub {
 236             $self->_select( where => sub { $_->mtime >= $last_run_time } );
 237         },
 238         save => sub {
 239             $self->{should_save}++;
 240         },
 241         adrian => sub {
 242             unshift @switches, qw( hot all save );
 243         },
 244     );
 245
 246     while ( defined( my $ele = shift @switches ) ) {
 247         my ( $opt, $arg )
 248           = ( $ele =~ /^([^:]+):(.*)/ )
 249           ? ( $1, $2 )
 250           : ( $ele, undef );
 251         my $code = $handler{$opt}
 252           || croak "Illegal state option: $opt";
 253         $code->($arg);
 254     }
 255 }
 256
 257 sub _select {
 258     my ( $self, %spec ) = @_;
 259     push @{ $self->{select} }, \%spec;
 260 }
 261
 262 =head3 C<get_tests>
 263
 264 Given a list of args get the names of tests that should run
 265
 266 =cut
 267
 268 sub get_tests {
 269     my $self    = shift;
 270     my $recurse = shift;
 271     my @argv    = @_;
 272     my %seen;
 273
 274     my @selected = $self->_query;
 275
 276     unless ( @argv || @{ $self->{select} } ) {
 277         @argv = $recurse ? '.' : 't';
 278         croak qq{No tests named and '@argv' directory not found}
 279           unless -d $argv[0];
 280     }
 281
 282     push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
 283     return grep { !$seen{$_}++ } @selected;
 284 }
 285
 286 sub _query {
 287     my $self = shift;
 288     if ( my @sel = @{ $self->{select} } ) {
 289         warn "No saved state, selection will be empty\n"
 290           unless $self->results->num_tests;
 291         return map { $self->_query_clause($_) } @sel;
 292     }
 293     return;
 294 }
 295
 296 sub _query_clause {
 297     my ( $self, $clause ) = @_;
 298     my @got;
 299     my $results = $self->results;
 300     my $where = $clause->{where} || sub {1};
 301
 302     # Select
 303     for my $name ( $results->test_names ) {
 304         next unless -f $name;
 305         local $_ = $results->test($name);
 306         push @got, $name if $where->();
 307     }
 308
 309     # Sort
 310     if ( my $order = $clause->{order} ) {
 311         @got = map { $_->[0] }
 312           sort {
 313                  ( defined $b->[1] <=> defined $a->[1] )
 314               || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
 315           } map {
 316             [   $_,
 317                 do { local $_ = $results->test($_); $order->() }
 318             ]
 319           } @got;
 320     }
 321
 322     return @got;
 323 }
 324
 325 sub _get_raw_tests {
 326     my $self    = shift;
 327     my $recurse = shift;
 328     my @argv    = @_;
 329     my @tests;
 330
 331     # Do globbing on Win32.
 332     @argv = map { glob "$_" } @argv if NEED_GLOB;
 333     my $extension = $self->{extension};
 334
 335     for my $arg (@argv) {
 336         if ( '-' eq $arg ) {
 337             push @argv => <STDIN>;
 338             chomp(@argv);
 339             next;
 340         }
 341
 342         push @tests,
 343             sort -d $arg
 344           ? $recurse
 345               ? $self->_expand_dir_recursive( $arg, $extension )
 346               : glob( File::Spec->catfile( $arg, "*$extension" ) )
 347           : $arg;
 348     }
 349     return @tests;
 350 }
 351
 352 sub _expand_dir_recursive {
 353     my ( $self, $dir, $extension ) = @_;
 354
 355     my @tests;
 356     find(
 357         {   follow      => 1,      #21938
 358             follow_skip => 2,
 359             wanted      => sub {
 360                 -f
 361                   && /\Q$extension\E$/
 362                   && push @tests => $File::Find::name;
 363               }
 364         },
 365         $dir
 366     );
 367     return @tests;
 368 }
 369
 370 =head3 C<observe_test>
 371
 372 Store the results of a test.
 373
 374 =cut
 375
 376 sub observe_test {
 377     my ( $self, $test, $parser ) = @_;
 378     $self->_record_test(
 379         $test->[0],
 380         scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
 381         scalar( $parser->todo ), $parser->start_time, $parser->end_time,
 382     );
 383 }
 384
 385 # Store:
 386 #     last fail time
 387 #     last pass time
 388 #     last run time
 389 #     most recent result
 390 #     most recent todos
 391 #     total failures
 392 #     total passes
 393 #     state generation
 394
 395 sub _record_test {
 396     my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_;
 397     my $test = $self->results->test($name);
 398
 399     $test->sequence( $self->{seq}++ );
 400     $test->generation( $self->results->generation );
 401
 402     $test->run_time($end_time);
 403     $test->result($fail);
 404     $test->num_todo($todo);
 405     $test->elapsed( $end_time - $start_time );
 406
 407     if ($fail) {
 408         $test->total_failures( $test->total_failures + 1 );
 409         $test->last_fail_time($end_time);
 410     }
 411     else {
 412         $test->total_passes( $test->total_passes + 1 );
 413         $test->last_pass_time($end_time);
 414     }
 415 }
 416
 417 =head3 C<save>
 418
 419 Write the state to a file.
 420
 421 =cut
 422
 423 sub save {
 424     my ( $self, $name ) = @_;
 425
 426     $self->results->last_run_time( $self->get_time );
 427
 428     my $writer = TAP::Parser::YAMLish::Writer->new;
 429     local *FH;
 430     open FH, ">$name" or croak "Can't write $name ($!)";
 431     $writer->write( $self->results->raw, \*FH );
 432     close FH;
 433 }
 434
 435 =head3 C<load>
 436
 437 Load the state from a file
 438
 439 =cut
 440
 441 sub load {
 442     my ( $self, $name ) = @_;
 443     my $reader = TAP::Parser::YAMLish::Reader->new;
 444     local *FH;
 445     open FH, "<$name" or croak "Can't read $name ($!)";
 446
 447     # XXX this is temporary
 448     $self->{_} = $self->result_class->new(
 449         $reader->read(
 450             sub {
 451                 my $line = <FH>;
 452                 defined $line && chomp $line;
 453                 return $line;
 454             }
 455         )
 456     );
 457
 458     # $writer->write( $self->{tests} || {}, \*FH );
 459     close FH;
 460     $self->_regen_seq;
 461     $self->_prune_and_stamp;
 462     $self->results->generation( $self->results->generation + 1 );
 463 }
 464
 465 sub _prune_and_stamp {
 466     my $self = shift;
 467
 468     my $results = $self->results;
 469     my @tests   = $self->results->tests;
 470     for my $test (@tests) {
 471         my $name = $test->name;
 472         if ( my @stat = stat $name ) {
 473             $test->mtime( $stat[9] );
 474         }
 475         else {
 476             $results->remove($name);
 477         }
 478     }
 479 }
 480
 481 sub _regen_seq {
 482     my $self = shift;
 483     for my $test ( $self->results->tests ) {
 484         $self->{seq} = $test->sequence + 1
 485           if defined $test->sequence && $test->sequence >= $self->{seq};
 486     }
 487 }
 488
 489 1;