This is 1.17

[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind / Action / Suppressions.pm

diff --git a/lib/Test/Valgrind/Action/Suppressions.pm b/lib/Test/Valgrind/Action/Suppressions.pm
index 03f412d85f7c34fa8ab28e0058de3cf9adae2586..9002afc2514fcc2fe0667db0533cc8358d501a96 100644 (file)
--- a/lib/Test/Valgrind/Action/Suppressions.pm
+++ b/lib/Test/Valgrind/Action/Suppressions.pm
@@ -9,11 +9,11 @@ Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.
 
 =head1 VERSION
 
-Version 1.00
+Version 1.17
 
 =cut
 
-our $VERSION = '1.00';
+our $VERSION = '1.17';
 
 =head1 DESCRIPTION
 
@@ -21,13 +21,19 @@ This action just writes the contents of the suppressions reports received into t
 
 =cut
 
-use base qw/Test::Valgrind::Action Test::Valgrind::Action::Captor/;
+use base qw<Test::Valgrind::Action Test::Valgrind::Action::Captor>;
 
 =head1 METHODS
 
 This class inherits L<Test::Valgrind::Action>.
 
-=head2 C<< new name => $name, target => $target, ... >>
+=head2 C<new>
+
+    my $tvas = Test::Valgrind::Action::Suppressions->new(
+     name   => $name,
+     target => $target,
+     %extra_args,
+    );
 
 Your usual constructor.
 
@@ -45,7 +51,7 @@ sub new {
 
  my %validated;
 
- for (qw/name target/) {
+ for (qw<name target>) {
   my $arg = delete $args{$_};
   $class->_croak("'$_' is expected to be a plain scalar")
                                                    unless $arg and not ref $arg;
@@ -54,7 +60,7 @@ sub new {
 
  my $self = $class->SUPER::new(%args);
 
- $self->{$_} = $validated{$_} for qw/name target/;
+ $self->{$_} = $validated{$_} for qw<name target>;
 
  $self;
 }
@@ -63,6 +69,8 @@ sub do_suppressions { 1 }
 
 =head2 C<name>
 
+    my $name = $tvas->name;
+
 Read-only accessor for the C<name> option.
 
 =cut
@@ -71,6 +79,8 @@ sub name   { $_[0]->{name} }
 
 =head2 C<target>
 
+    my $target = $tvas->target;
+
 Read-only accessor for the C<target> option.
 
 =cut
@@ -82,28 +92,7 @@ sub start {
 
  $self->SUPER::start($sess);
 
- $self->{status} = undef;
- $self->{total}  = 0;
- delete $self->{diagnostics};
-
- if ($self->{fh}) {
-  close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
- }
-
- 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 $self->{fh}, '>', $target
-                or $self->_croak("open(\$self->{fh}, '>', \$self->target): $!");
+ delete @{$self}{qw<status supps diagnostics>};
 
  $self->save_fh(\*STDOUT => '>' => undef);
  $self->save_fh(\*STDERR => '>' => undef);
@@ -136,12 +125,7 @@ sub report {
 
  $self->SUPER::report($sess, $report);
 
- ++$self->{total};
-
- print { $self->{fh} } "{\n"
-                       . $self->name . $report->id . "\n"
-                       . $report->data
-                       . "}\n";
+ push @{$self->{supps}}, $report;
 
  return;
 }
@@ -153,11 +137,37 @@ sub finish {
 
  $self->restore_all_fh;
 
- close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
-
  print $self->{diagnostics} if defined $self->{diagnostics};
  delete $self->{diagnostics};
- print "Found $self->{total} distinct suppressions\n";
+
+ my $target = $self->target;
+
+ require File::Spec;
+ my ($vol, $dir, $file) = File::Spec->splitpath($target);
+ my $base = File::Spec->catpath($vol, $dir, '');
+ if (-e $base) {
+  1 while unlink $target;
+ } else {
+  require File::Path;
+  File::Path::mkpath([ $base ]);
+ }
+
+ open my $fh, '>', $target
+                        or $self->_croak("open(\$fh, '>', \$self->target): $!");
+
+ my $id = 0;
+ my %seen;
+ 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;
 
@@ -189,7 +199,7 @@ You can find documentation for this module with the perldoc command.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2009 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011,2013,2015 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.