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