]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - lib/Test/Valgrind/Action/Test.pm
Make sure File::Temp is recent enough for ->newdir
[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.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