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