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