1 package Test::Valgrind::Action::Suppressions;
8 Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.
16 our $VERSION = '1.12';
20 This action just writes the contents of the suppressions reports received into the suppression file.
24 use base qw<Test::Valgrind::Action Test::Valgrind::Action::Captor>;
28 This class inherits L<Test::Valgrind::Action>.
30 =head2 C<< new name => $name, target => $target, ... >>
32 Your usual constructor.
34 You need to specify the suppression prefix as the value of C<name>, and the target file as C<target>.
36 Other arguments are passed straight to C<< Test::Valgrind::Action->new >>.
42 $class = ref($class) || $class;
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;
55 my $self = $class->SUPER::new(%args);
57 $self->{$_} = $validated{$_} for qw<name target>;
62 sub do_suppressions { 1 }
66 Read-only accessor for the C<name> option.
70 sub name { $_[0]->{name} }
74 Read-only accessor for the C<target> option.
78 sub target { $_[0]->{target} }
81 my ($self, $sess) = @_;
83 $self->SUPER::start($sess);
85 delete @{$self}{qw<status supps diagnostics>};
87 $self->save_fh(\*STDOUT => '>' => undef);
88 $self->save_fh(\*STDERR => '>' => undef);
96 $self->restore_all_fh;
98 print $self->{diagnostics} if defined $self->{diagnostics};
99 delete $self->{diagnostics};
101 $self->{status} = 255;
103 $self->SUPER::abort(@_);
107 my ($self, $sess, $report) = @_;
109 if ($report->is_diag) {
110 my $data = $report->data;
112 $self->{diagnostics} .= "$data\n";
116 $self->SUPER::report($sess, $report);
118 push @{$self->{supps}}, $report;
124 my ($self, $sess) = @_;
126 $self->SUPER::finish($sess);
128 $self->restore_all_fh;
130 print $self->{diagnostics} if defined $self->{diagnostics};
131 delete $self->{diagnostics};
133 my $target = $self->target;
136 my ($vol, $dir, $file) = File::Spec->splitpath($target);
137 my $base = File::Spec->catpath($vol, $dir, '');
140 File::Path::mkpath([ $base ]);
142 1 while unlink $target;
145 open my $fh, '>', $target
146 or $self->_croak("open(\$fh, '>', \$self->target): $!");
149 for (sort { $a->data cmp $b->data }
150 grep !$seen{$_->data}++, @{$self->{supps}}) {
152 . $self->name . ++$id . "\n"
157 close $fh or $self->_croak("close(\$fh): $!");
159 print "Found $id distinct suppressions\n";
166 sub status { $_[0]->{status} }
170 L<Test::Valgrind>, L<Test::Valgrind::Action>.
174 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
176 You can contact me by mail or on C<irc.perl.org> (vincent).
180 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>.
181 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
185 You can find documentation for this module with the perldoc command.
187 perldoc Test::Valgrind::Action::Suppressions
189 =head1 COPYRIGHT & LICENSE
191 Copyright 2009,2010,2011 Vincent Pit, all rights reserved.
193 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
197 1; # End of Test::Valgrind::Action::Supressions