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.19
  13
  14 =cut
  15
  16 our $VERSION = '1.19';
  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,2016 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