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