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

   1 package App::Prove::State::Result;
   2
   3 use strict;
   4 use Carp 'croak';
   5
   6 use App::Prove::State::Result::Test;
   7 use vars qw($VERSION);
   8
   9 use constant STATE_VERSION => 1;
  10
  11 =head1 NAME
  12
  13 App::Prove::State::Result - Individual test suite results.
  14
  15 =head1 VERSION
  16
  17 Version 3.14
  18
  19 =cut
  20
  21 $VERSION = '3.14';
  22
  23 =head1 DESCRIPTION
  24
  25 The C<prove> command supports a C<--state> option that instructs it to
  26 store persistent state across runs. This module encapsulates the results for a
  27 single test suite run.
  28
  29 =head1 SYNOPSIS
  30
  31     # Re-run failed tests
  32     $ prove --state=fail,save -rbv
  33
  34 =cut
  35
  36 =head1 METHODS
  37
  38 =head2 Class Methods
  39
  40 =head3 C<new>
  41
  42     my $result = App::Prove::State::Result->new({
  43         generation => $generation,
  44         tests      => \%tests,
  45     });
  46
  47 Returns a new C<App::Prove::State::Result> instance.
  48
  49 =cut
  50
  51 sub new {
  52     my ( $class, $arg_for ) = @_;
  53     $arg_for ||= {};
  54     my %instance_data = %$arg_for;    # shallow copy
  55     $instance_data{version} = $class->state_version;
  56     my $tests = delete $instance_data{tests} || {};
  57     my $self = bless \%instance_data => $class;
  58     $self->_initialize($tests);
  59     return $self;
  60 }
  61
  62 sub _initialize {
  63     my ( $self, $tests ) = @_;
  64     my %tests;
  65     while ( my ( $name, $test ) = each %$tests ) {
  66         $tests{$name} = $self->test_class->new({
  67             %$test,
  68             name => $name
  69         });
  70     }
  71     $self->tests( \%tests );
  72     return $self;
  73 }
  74
  75 =head2 C<state_version>
  76
  77 Returns the current version of state storage.
  78
  79 =cut
  80
  81 sub state_version {STATE_VERSION}
  82
  83 =head2 C<test_class>
  84
  85 Returns the name of the class used for tracking individual tests.  This class
  86 should either subclass from C<App::Prove::State::Result::Test> or provide an
  87 identical interface.
  88
  89 =cut
  90
  91 sub test_class {
  92     return 'App::Prove::State::Result::Test';
  93 }
  94
  95 my %methods = (
  96     generation    => { method => 'generation',    default => 0 },
  97     last_run_time => { method => 'last_run_time', default => undef },
  98 );
  99
 100 while ( my ( $key, $description ) = each %methods ) {
 101     my $default = $description->{default};
 102     no strict 'refs';
 103     *{ $description->{method} } = sub {
 104         my $self = shift;
 105         if (@_) {
 106             $self->{$key} = shift;
 107             return $self;
 108         }
 109         return $self->{$key} || $default;
 110     };
 111 }
 112
 113 =head3 C<generation>
 114
 115 Getter/setter for the "generation" of the test suite run. The first
 116 generation is 1 (one) and subsequent generations are 2, 3, etc.
 117
 118 =head3 C<last_run_time>
 119
 120 Getter/setter for the time of the test suite run.
 121
 122 =head3 C<tests>
 123
 124 Returns the tests for a given generation. This is a hashref or a hash,
 125 depending on context called. The keys to the hash are the individual
 126 test names and the value is a hashref with various interesting values.
 127 Each k/v pair might resemble something like this:
 128
 129  't/foo.t' => {
 130     elapsed        => '0.0428488254547119',
 131     gen            => '7',
 132     last_pass_time => '1219328376.07815',
 133     last_result    => '0',
 134     last_run_time  => '1219328376.07815',
 135     last_todo      => '0',
 136     mtime          => '1191708862',
 137     seq            => '192',
 138     total_passes   => '6',
 139   }
 140
 141 =cut
 142
 143 sub tests {
 144     my $self = shift;
 145     if (@_) {
 146         $self->{tests} = shift;
 147         return $self;
 148     }
 149     my %tests = %{ $self->{tests} };
 150     my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
 151     return wantarray ? @tests : \@tests;
 152 }
 153
 154 =head3 C<test>
 155
 156  my $test = $result->test('t/customer/create.t');
 157
 158 Returns an individual C<App::Prove::State::Result::Test> instance for the
 159 given test name (usually the filename).  Will return a new
 160 C<App::Prove::State::Result::Test> instance if the name is not found.
 161
 162 =cut
 163
 164 sub test {
 165     my ( $self, $name ) = @_;
 166     croak("test() requires a test name") unless defined $name;
 167
 168     my $tests = $self->{tests} ||= {};
 169     if ( my $test = $tests->{$name} ) {
 170         return $test;
 171     }
 172     else {
 173         my $test = $self->test_class->new({name => $name});
 174         $self->{tests}->{$name} = $test;
 175         return $test;
 176     }
 177 }
 178
 179 =head3 C<test_names>
 180
 181 Returns an list of test names, sorted by run order.
 182
 183 =cut
 184
 185 sub test_names {
 186     my $self = shift;
 187     return map { $_->name } $self->tests;
 188 }
 189
 190 =head3 C<remove>
 191
 192  $result->remove($test_name);            # remove the test
 193  my $test = $result->test($test_name);   # fatal error
 194
 195 Removes a given test from results.  This is a no-op if the test name is not
 196 found.
 197
 198 =cut
 199
 200 sub remove {
 201     my ( $self, $name ) = @_;
 202     delete $self->{tests}->{$name};
 203     return $self;
 204 }
 205
 206 =head3 C<num_tests>
 207
 208 Returns the number of tests for a given test suite result.
 209
 210 =cut
 211
 212 sub num_tests { keys %{ shift->{tests} } }
 213
 214 =head3 C<raw>
 215
 216 Returns a hashref of raw results, suitable for serialization by YAML.
 217
 218 =cut
 219
 220 sub raw {
 221     my $self = shift;
 222     my %raw  = %$self;
 223
 224     my %tests;
 225     foreach my $test ( $self->tests ) {
 226         $tests{ $test->name } = $test->raw;
 227     }
 228     $raw{tests} = \%tests;
 229     return \%raw;
 230 }
 231
 232 1;