]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - Suppressions.pm
9f4d3fbecbe3fe2bf75adaff270a0402729a3779
[perl/modules/Test-Valgrind.git] / Suppressions.pm
1 package Test::Valgrind::Action::Suppressions;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.
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 just writes the contents of the suppressions reports received into the suppression file.
21
22 =cut
23
24 use base qw/Test::Valgrind::Action Test::Valgrind::Action::Captor/;
25
26 =head1 METHODS
27
28 This class inherits L<Test::Valgrind::Action>.
29
30 =head2 C<< new name => $name, target => $target, ... >>
31
32 Your usual constructor.
33
34 You need to specify the suppression prefix as the value of C<name>, and the target file as C<target>.
35
36 Other arguments are passed straight to C<< Test::Valgrind::Action->new >>.
37
38 =cut
39
40 sub new {
41  my $class = shift;
42  $class = ref($class) || $class;
43
44  my %args = @_;
45
46  my %validated;
47
48  for (qw/name target/) {
49   my $arg = delete $args{$_};
50   $class->_croak("'$_' is expected to be a plain scalar")
51                                                    unless $arg and not ref $arg;
52   $validated{$_} = $arg;
53  }
54
55  my $self = $class->SUPER::new(%args);
56
57  $self->{$_} = $validated{$_} for qw/name target/;
58
59  $self;
60 }
61
62 sub do_suppressions { 1 }
63
64 =head2 C<name>
65
66 Read-only accessor for the C<name> option.
67
68 =cut
69
70 sub name   { $_[0]->{name} }
71
72 =head2 C<target>
73
74 Read-only accessor for the C<target> option.
75
76 =cut
77
78 sub target { $_[0]->{target} }
79
80 sub start {
81  my ($self, $sess) = @_;
82
83  $self->SUPER::start($sess);
84
85  $self->{status} = undef;
86  $self->{total}  = 0;
87  delete $self->{diagnostics};
88
89  if ($self->{fh}) {
90   close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
91  }
92
93  my $target = $self->target;
94
95  require File::Spec;
96  my ($vol, $dir, $file) = File::Spec->splitpath($target);
97  my $base = File::Spec->catpath($vol, $dir, '');
98  unless (-e $base) {
99   require File::Path;
100   File::Path::mkpath([ $base ]);
101  } else {
102   1 while unlink $target;
103  }
104
105  open $self->{fh}, '>', $target
106                 or $self->_croak("open(\$self->{fh}, '>', \$self->target): $!");
107
108  $self->save_fh(\*STDOUT => '>' => undef);
109  $self->save_fh(\*STDERR => '>' => undef);
110
111  return;
112 }
113
114 sub abort {
115  my $self = shift;
116
117  $self->restore_all_fh;
118
119  print $self->{diagnostics} if defined $self->{diagnostics};
120  delete $self->{diagnostics};
121
122  $self->{status} = 255;
123
124  $self->SUPER::abort(@_);
125 }
126
127 sub report {
128  my ($self, $sess, $report) = @_;
129
130  if ($report->is_diag) {
131   my $data = $report->data;
132   1 while chomp $data;
133   $self->{diagnostics} .= "$data\n";
134   return;
135  }
136
137  $self->SUPER::report($sess, $report);
138
139  ++$self->{total};
140
141  print { $self->{fh} } "{\n"
142                        . $self->name . $report->id . "\n"
143                        . $report->data
144                        . "}\n";
145
146  return;
147 }
148
149 sub finish {
150  my ($self, $sess) = @_;
151
152  $self->SUPER::finish($sess);
153
154  $self->restore_all_fh;
155
156  close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
157
158  print $self->{diagnostics} if defined $self->{diagnostics};
159  delete $self->{diagnostics};
160  print "Found $self->{total} distinct suppressions\n";
161
162  $self->{status} = 0;
163
164  return;
165 }
166
167 sub status { $_[0]->{status} }
168
169 =head1 SEE ALSO
170
171 L<Test::Valgrind>, L<Test::Valgrind::Action>.
172
173 =head1 AUTHOR
174
175 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
176
177 You can contact me by mail or on C<irc.perl.org> (vincent).
178
179 =head1 BUGS
180
181 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>.
182 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
183
184 =head1 SUPPORT
185
186 You can find documentation for this module with the perldoc command.
187
188     perldoc Test::Valgrind::Action::Suppressions
189
190 =head1 COPYRIGHT & LICENSE
191
192 Copyright 2009 Vincent Pit, all rights reserved.
193
194 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
195
196 =cut
197
198 1; # End of Test::Valgrind::Action::Supressions