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.10
  13
  14 =cut
  15
  16 our $VERSION = '1.10';
  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  delete @{$self}{qw/status supps diagnostics/};
  86
  87  $self->save_fh(\*STDOUT => '>' => undef);
  88  $self->save_fh(\*STDERR => '>' => undef);
  89
  90  return;
  91 }
  92
  93 sub abort {
  94  my $self = shift;
  95
  96  $self->restore_all_fh;
  97
  98  print $self->{diagnostics} if defined $self->{diagnostics};
  99  delete $self->{diagnostics};
 100
 101  $self->{status} = 255;
 102
 103  $self->SUPER::abort(@_);
 104 }
 105
 106 sub report {
 107  my ($self, $sess, $report) = @_;
 108
 109  if ($report->is_diag) {
 110   my $data = $report->data;
 111   1 while chomp $data;
 112   $self->{diagnostics} .= "$data\n";
 113   return;
 114  }
 115
 116  $self->SUPER::report($sess, $report);
 117
 118  push @{$self->{supps}}, $report;
 119
 120  return;
 121 }
 122
 123 sub finish {
 124  my ($self, $sess) = @_;
 125
 126  $self->SUPER::finish($sess);
 127
 128  $self->restore_all_fh;
 129
 130  print $self->{diagnostics} if defined $self->{diagnostics};
 131  delete $self->{diagnostics};
 132
 133  my $target = $self->target;
 134
 135  require File::Spec;
 136  my ($vol, $dir, $file) = File::Spec->splitpath($target);
 137  my $base = File::Spec->catpath($vol, $dir, '');
 138  unless (-e $base) {
 139   require File::Path;
 140   File::Path::mkpath([ $base ]);
 141  } else {
 142   1 while unlink $target;
 143  }
 144
 145  open my $fh, '>', $target
 146                         or $self->_croak("open(\$fh, '>', \$self->target): $!");
 147
 148  my (%seen, $id);
 149  for (sort { $a->data cmp $b->data }
 150        grep !$seen{$_->data}++, @{$self->{supps}}) {
 151   print $fh "{\n"
 152             . $self->name . ++$id . "\n"
 153             . $_->data
 154             . "}\n";
 155  }
 156
 157  close $fh or $self->_croak("close(\$fh): $!");
 158
 159  print "Found $id distinct suppressions\n";
 160
 161  $self->{status} = 0;
 162
 163  return;
 164 }
 165
 166 sub status { $_[0]->{status} }
 167
 168 =head1 SEE ALSO
 169
 170 L<Test::Valgrind>, L<Test::Valgrind::Action>.
 171
 172 =head1 AUTHOR
 173
 174 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 175
 176 You can contact me by mail or on C<irc.perl.org> (vincent).
 177
 178 =head1 BUGS
 179
 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.
 182
 183 =head1 SUPPORT
 184
 185 You can find documentation for this module with the perldoc command.
 186
 187     perldoc Test::Valgrind::Action::Suppressions
 188
 189 =head1 COPYRIGHT & LICENSE
 190
 191 Copyright 2009 Vincent Pit, all rights reserved.
 192
 193 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 194
 195 =cut
 196
 197 1; # End of Test::Valgrind::Action::Supressions