Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.

Test-Valgrind documentation Contained in the Test-Valgrind distribution.

Index

Code Index:

NAME

Top

Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.

VERSION

Top

Version 1.12

DESCRIPTION

Top

This action just writes the contents of the suppressions reports received into the suppression file.

METHODS

Top

This class inherits Test::Valgrind::Action.

new name => $name, target => $target, ...

Your usual constructor.

You need to specify the suppression prefix as the value of name, and the target file as target.

Other arguments are passed straight to Test::Valgrind::Action->new.

name

Read-only accessor for the name option.

target

Read-only accessor for the target option.

SEE ALSO

Top

Test::Valgrind, Test::Valgrind::Action.

AUTHOR

Top

Vincent Pit, <perl at profvince.com>, http://www.profvince.com.

You can contact me by mail or on irc.perl.org (vincent).

BUGS

Top

Please report any bugs or feature requests to bug-test-valgrind at rt.cpan.org, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

SUPPORT

Top

You can find documentation for this module with the perldoc command.

    perldoc Test::Valgrind::Action::Suppressions

COPYRIGHT & LICENSE

Top

Copyright 2009 Vincent Pit, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Test-Valgrind documentation Contained in the Test-Valgrind distribution. 
package Test::Valgrind::Action::Suppressions;

use strict;
use warnings;


our $VERSION = '1.12';


use base qw/Test::Valgrind::Action Test::Valgrind::Action::Captor/;


sub new {
 my $class = shift;
 $class = ref($class) || $class;

 my %args = @_;

 my %validated;

 for (qw/name target/) {
  my $arg = delete $args{$_};
  $class->_croak("'$_' is expected to be a plain scalar")
                                                   unless $arg and not ref $arg;
  $validated{$_} = $arg;
 }

 my $self = $class->SUPER::new(%args);

 $self->{$_} = $validated{$_} for qw/name target/;

 $self;
}

sub do_suppressions { 1 }


sub name   { $_[0]->{name} }


sub target { $_[0]->{target} }

sub start {
 my ($self, $sess) = @_;

 $self->SUPER::start($sess);

 delete @{$self}{qw/status supps diagnostics/};

 $self->save_fh(\*STDOUT => '>' => undef);
 $self->save_fh(\*STDERR => '>' => undef);

 return;
}

sub abort {
 my $self = shift;

 $self->restore_all_fh;

 print $self->{diagnostics} if defined $self->{diagnostics};
 delete $self->{diagnostics};

 $self->{status} = 255;

 $self->SUPER::abort(@_);
}

sub report {
 my ($self, $sess, $report) = @_;

 if ($report->is_diag) {
  my $data = $report->data;
  1 while chomp $data;
  $self->{diagnostics} .= "$data\n";
  return;
 }

 $self->SUPER::report($sess, $report);

 push @{$self->{supps}}, $report;

 return;
}

sub finish {
 my ($self, $sess) = @_;

 $self->SUPER::finish($sess);

 $self->restore_all_fh;

 print $self->{diagnostics} if defined $self->{diagnostics};
 delete $self->{diagnostics};

 my $target = $self->target;

 require File::Spec;
 my ($vol, $dir, $file) = File::Spec->splitpath($target);
 my $base = File::Spec->catpath($vol, $dir, '');
 unless (-e $base) {
  require File::Path;
  File::Path::mkpath([ $base ]);
 } else {
  1 while unlink $target;
 }

 open my $fh, '>', $target
                        or $self->_croak("open(\$fh, '>', \$self->target): $!");

 my (%seen, $id);
 for (sort { $a->data cmp $b->data }
       grep !$seen{$_->data}++, @{$self->{supps}}) {
  print $fh "{\n"
            . $self->name . ++$id . "\n"
            . $_->data
            . "}\n";
 }

 close $fh or $self->_croak("close(\$fh): $!");

 print "Found $id distinct suppressions\n";

 $self->{status} = 0;

 return;
}

sub status { $_[0]->{status} }


1; # End of Test::Valgrind::Action::Supressions