lib/Test/Valgrind/Tool/SuppressionsParser.pm

   1 package Test::Valgrind::Tool::SuppressionsParser;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Tool::SuppressionsParser - Mock Test::Valgrind::Tool for parsing valgrind suppressions.
   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 class provides a default C<parse_suppressions> method, so that real tools for which suppressions are meaningful can exploit it by inheriting.
  21
  22 It's not meant to be used directly as a tool.
  23
  24 =cut
  25
  26 use base qw/Test::Valgrind::Carp/;
  27
  28 =head1 METHODS
  29
  30 =head2 C<new>
  31
  32 Just a croaking stub to remind you not to use this class as a real tool.
  33
  34 If your tool both inherit from this class and from C<Test::Valgrind::Tool>, and that you want to dispatch the call to your C<new> to its ancestors', be careful with C<SUPER> which may end up calling this dieing version of C<new>.
  35 The solution is to either put C<Test::Valgrind::Tool> first in the C<@ISA> list or to explicitely call C<Test::Valgrind::Tool::new> instead of C<SUPER::new>.
  36
  37 =cut
  38
  39 sub new { shift->_croak('This mock tool isn\'t meant to be used directly') }
  40
  41 =head2 C<report_class_suppressions $session>
  42
  43 Generated reports are L<Test::Valgrind::Report::Suppressions> objects.
  44 Their C<data> member contains the raw text of the suppression.
  45
  46 =cut
  47
  48 sub report_class_suppressions { 'Test::Valgrind::Report::Suppressions' }
  49
  50 =head2 C<parse_suppressions $session, $fh>
  51
  52 Parses the filehandle C<$fh> fed with the output of F<valgrind --gen-suppressions=all> and sends a report to the session C<$session> for each suppression.
  53
  54 =cut
  55
  56 sub parse_suppressions {
  57  my ($self, $sess, $fh) = @_;
  58
  59  my ($s, $in) = ('', 0);
  60  my @supps;
  61
  62  while (<$fh>) {
  63   s/^\s*#\s//;
  64   next if /^==/;
  65   next if /valgrind/; # and /\Q$file\E/;
  66   s/^\s*//;
  67   s/<[^>]+>//;
  68   s/\s*$//;
  69   next unless length;
  70   if ($_ eq '{') {
  71    $in = 1;
  72   } elsif ($_ eq '}') {
  73    my $unknown_tail;
  74    ++$unknown_tail while $s =~ s/(\n)\s*obj:\*\s*$/$1/;
  75    $s .= "...\n" if $unknown_tail and $sess->version ge '3.4.0';
  76    push @supps, $s;
  77    $s  = '';
  78    $in = 0;
  79   } elsif ($in) {
  80    $s .= "$_\n";
  81   }
  82  }
  83
  84  my @extra;
  85  for (@supps) {
  86   if (/\bfun:(m|c|re)alloc\b/) {
  87    my $t = $1;
  88    my %call;
  89    if ($t eq 'm') { # malloc can also be called by calloc or realloc
  90     $call{$_} = 1 for qw/calloc realloc/;
  91    } elsif ($t eq 're') { # realloc can also call malloc or free
  92     $call{$_} = 0 for qw/malloc free/;
  93    } elsif ($t eq 'c') { # calloc can also call malloc
  94     $call{$_} = 0 for qw/malloc/;
  95    }
  96    my $c = $_;
  97    for (keys %call) {
  98     my $d = $c;
  99     $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
 100     # Remove one line for each line added or valgrind will hate us
 101     $d =~ s/\n(.+?)\s*$/\n/;
 102     push @extra, $d;
 103    }
 104   }
 105  }
 106
 107  my %dupes;
 108  @dupes{@supps, @extra} = ();
 109  @supps = keys %dupes;
 110
 111  my $num;
 112  $sess->report($self->report_class($sess)->new(
 113   id   => ++$num,
 114   kind => 'Suppression',
 115   data => $_,
 116  )) for @supps;
 117 }
 118
 119 =head1 SEE ALSO
 120
 121 L<Test::Valgrind>, L<Test::Valgrind::Tool>.
 122
 123 =head1 AUTHOR
 124
 125 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 126
 127 You can contact me by mail or on C<irc.perl.org> (vincent).
 128
 129 =head1 BUGS
 130
 131 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>.
 132 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 133
 134 =head1 SUPPORT
 135
 136 You can find documentation for this module with the perldoc command.
 137
 138     perldoc Test::Valgrind::Tool::SuppressionsParser
 139
 140 =head1 COPYRIGHT & LICENSE
 141
 142 Copyright 2009 Vincent Pit, all rights reserved.
 143
 144 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 145
 146 =cut
 147
 148 # End of Test::Valgrind::Tool::SuppressionsParser
 149
 150 package Test::Valgrind::Report::Suppressions;
 151
 152 use base qw/Test::Valgrind::Report/;
 153
 154 sub kinds { shift->SUPER::kinds(), 'Suppression' }
 155
 156 sub valid_kind {
 157  my ($self, $kind) = @_;
 158
 159  $self->SUPER::valid_kind($kind) or $kind eq 'Suppression'
 160 }
 161
 162 1; # End of Test::Valgrind::Report::Suppressions