lib/Test/Valgrind/Action/Test.pm

   1 package Test::Valgrind::Action::Test;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Action::Test - Test that an analysis didn't generate any error report.
   9
  10 =head1 VERSION
  11
  12 Version 1.17
  13
  14 =cut
  15
  16 our $VERSION = '1.17';
  17
  18 =head1 DESCRIPTION
  19
  20 This action uses C<Test::Builder> to plan and pass or fail tests according to the reports received.
  21
  22 =cut
  23
  24 use Test::Builder;
  25
  26 use base qw<Test::Valgrind::Action Test::Valgrind::Action::Captor>;
  27
  28 =head1 METHODS
  29
  30 This class inherits L<Test::Valgrind::Action> and L<Test::Valgrind::Action::Captor>.
  31
  32 =head2 C<new>
  33
  34     my $tvat = Test::Valgrind::Action::Test->new(
  35      diag        => $diag,
  36      extra_tests => $extra_tests,
  37      %extra_args,
  38     );
  39
  40 Your usual constructor.
  41
  42 When C<$diag> is true, the original output of the command and the error reports are intermixed as diagnostics.
  43
  44 C<$extra_tests> specifies how many extraneous tests you want to plan in addition to the default ones.
  45
  46 Other arguments are passed straight to C<< Test::Valgrind::Action->new >>.
  47
  48 =cut
  49
  50 sub new {
  51  my $class = shift;
  52  $class = ref($class) || $class;
  53
  54  my %args = @_;
  55
  56  my $diag        = delete $args{diag};
  57  my $extra_tests = delete $args{extra_tests} || 0;
  58
  59  my $self = bless $class->SUPER::new(%args), $class;
  60
  61  $self->{diag}        = $diag;
  62  $self->{extra_tests} = $extra_tests;
  63
  64  $self;
  65 }
  66
  67 =head2 C<diag>
  68
  69     my $diag = $tvat->diag;
  70
  71 Read-only accessor for the C<diag> option.
  72
  73 =cut
  74
  75 sub diag { $_[0]->{diag} }
  76
  77 =head2 C<kinds>
  78
  79     my @kinds = $tvat->kinds;
  80
  81 Returns the list of all the monitored report kinds.
  82
  83 =cut
  84
  85 sub kinds { @{$_[0]->{kinds} || []} }
  86
  87 sub start {
  88  my ($self, $sess) = @_;
  89
  90  $self->SUPER::start($sess);
  91
  92  my @kinds = grep $_ ne 'Diag', $sess->report_class->kinds;
  93  $self->{kinds}  = \@kinds;
  94  $self->{status} = 0;
  95
  96  my $tb = Test::Builder->new;
  97
  98  $tb->plan(tests => $self->{extra_tests} + scalar @kinds);
  99
 100  $self->restore_all_fh;
 101
 102  delete $self->{capture};
 103  if ($self->diag) {
 104   require File::Temp;
 105   $self->{capture}     = File::Temp::tempfile();
 106   $self->{capture_pos} = 0;
 107  }
 108
 109  $self->save_fh(\*STDOUT => '>' => $self->{capture});
 110  $self->save_fh(\*STDERR => '>' => $self->{capture});
 111
 112  return;
 113 }
 114
 115 sub abort {
 116  my ($self, $sess, $msg) = @_;
 117
 118  $self->restore_all_fh;
 119
 120  my $tb = Test::Builder->new;
 121  my $plan = $tb->has_plan;
 122  if (defined $plan) {
 123   $tb->BAIL_OUT($msg);
 124   $self->{status} = 255;
 125  } else {
 126   $tb->skip_all($msg);
 127   $self->{status} = 0;
 128  }
 129
 130  return;
 131 }
 132
 133 sub report {
 134  my ($self, $sess, $report) = @_;
 135
 136  if ($report->is_diag) {
 137   my $tb = Test::Builder->new;
 138   $tb->diag($report->data);
 139   return;
 140  }
 141
 142  $self->SUPER::report($sess, $report);
 143
 144  $self->{reports}->{$report->kind}->{$report->id} = $report;
 145
 146  if ($self->diag) {
 147   my $tb = Test::Builder->new;
 148   my $fh = $self->{capture};
 149   seek $fh, $self->{capture_pos}, 0;
 150   $tb->diag($_) while <$fh>;
 151   $self->{capture_pos} = tell $fh;
 152   $tb->diag($report->dump);
 153  }
 154
 155  return;
 156 }
 157
 158 sub finish {
 159  my ($self, $sess) = @_;
 160
 161  $self->SUPER::finish($sess);
 162
 163  my $tb = Test::Builder->new;
 164
 165  $self->restore_all_fh;
 166
 167  if (my $fh = $self->{capture}) {
 168   seek $fh, $self->{capture_pos}, 0;
 169   $tb->diag($_) while <$fh>;
 170   close $fh or $self->_croak('close(capture[' . fileno($fh) . "]): $!");
 171   delete @{$self}{qw<capture capture_pos>};
 172  }
 173
 174  my $failed = 0;
 175
 176  for my $kind ($self->kinds) {
 177   my $reports = $self->{reports}->{$kind} || { };
 178   my $errors  = keys %$reports;
 179   $tb->is_num($errors, 0, $kind);
 180   if ($errors) {
 181    ++$failed;
 182    unless ($self->diag) {
 183     $tb->diag("\n" . $_->dump) for values %$reports;
 184    }
 185   }
 186  }
 187
 188  $self->{status} = $failed < 255 ? $failed : 254;
 189
 190  return;
 191 }
 192
 193 sub status {
 194  my ($self, $sess) = @_;
 195
 196  $self->SUPER::status($sess);
 197
 198  $self->{status};
 199 }
 200
 201 =head1 SEE ALSO
 202
 203 L<Test::Valgrind>, L<Test::Valgrind::Action>.
 204
 205 =head1 AUTHOR
 206
 207 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 208
 209 You can contact me by mail or on C<irc.perl.org> (vincent).
 210
 211 =head1 BUGS
 212
 213 Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
 214 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 215
 216 =head1 SUPPORT
 217
 218 You can find documentation for this module with the perldoc command.
 219
 220     perldoc Test::Valgrind::Action::Test
 221
 222 =head1 COPYRIGHT & LICENSE
 223
 224 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
 225
 226 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 227
 228 =cut
 229
 230 1; # End of Test::Valgrind::Action::Test