]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - lib/Test/Valgrind/Action/Test.pm
This is 1.00
[perl/modules/Test-Valgrind.git] / 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.00
13
14 =cut
15
16 our $VERSION = '1.00';
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