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