lib/Test/Valgrind/Parser/Suppressions/Text.pm

   1 package Test::Valgrind::Parser::Suppressions::Text;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Parser::Suppressions::Text - Parse valgrind suppressions output as text blocks.
   9
  10 =head1 VERSION
  11
  12 Version 1.15
  13
  14 =cut
  15
  16 our $VERSION = '1.15';
  17
  18 =head1 DESCRIPTION
  19
  20 This is a L<Test::Valgrind::Parser::Text> object that can extract suppressions from C<valgrind>'s text output.
  21
  22 =cut
  23
  24 use Test::Valgrind::Suppressions;
  25
  26 use base qw<Test::Valgrind::Parser::Text Test::Valgrind::Carp>;
  27
  28 =head1 METHODS
  29
  30 =head2 C<report_class>
  31
  32 Generated reports are C<Test::Valgrind::Report::Suppressions> objects.
  33 Their C<data> member contains the raw text of the suppression.
  34
  35 =cut
  36
  37 sub report_class { 'Test::Valgrind::Report::Suppressions' }
  38
  39 sub parse {
  40  my ($self, $sess, $fh) = @_;
  41
  42  my ($s, $in) = ('', 0);
  43  my @supps;
  44
  45  while (<$fh>) {
  46   s/^\s*#\s//;        # Strip comments
  47
  48   if (/^==/) {        # Valgrind info line
  49    if (/Signal 11 being dropped from thread/) {
  50     # This might loop endlessly
  51     return 1;
  52    }
  53    next;
  54   }
  55
  56   s/^\s*//;           # Strip leading spaces
  57   s/<[^>]+>//;        # Strip tags
  58   s/\s*$//;           # Strip trailing spaces
  59   next unless length;
  60
  61   if ($_ eq '{') {      # A suppression block begins
  62    $in = 1;
  63   } elsif ($_ eq '}') { # A suppression block ends
  64    $s = Test::Valgrind::Suppressions->strip_tail($sess, $s); # Strip the tail
  65    push @supps, $s;     # Add the suppression that just ended to the list
  66    $s  = '';            # Reset the state
  67    $in = 0;
  68   } elsif ($in) {       # We're inside a suppresion block
  69    if (/^fun\s*:\s*(.*)/) {
  70     # Sometimes valgrind seems to forget to Z-demangle the symbol names.
  71     # Make sure it's done and append the result to the state.
  72     my $sym = $1;
  73     $s .= 'fun:' . Test::Valgrind::Suppressions->maybe_z_demangle($sym) . "\n";
  74    } else {
  75     $s .= "$_\n";
  76    }
  77   }
  78  }
  79
  80  my @extra;
  81
  82  for (@supps) {
  83   if (/\bfun:(m|c|re)alloc\b/) {
  84    my $t = $1;
  85
  86    my %call; # Frames to append (if the value is 1) or to prepend (if it's 0)
  87    if ($t eq 'm') {       # malloc can also be called by calloc or realloc
  88     $call{$_} = 1 for qw<calloc realloc>;
  89    } elsif ($t eq 're') { # realloc can also call malloc or free
  90     $call{$_} = 0 for qw<malloc free>;
  91    } elsif ($t eq 'c') {  # calloc can also call malloc
  92     $call{$_} = 0 for qw<malloc>;
  93    }
  94
  95    my $c = $_;
  96    for (keys %call) {
  97     my $d = $c;
  98     $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
  99     # Remove one line for each line added or valgrind will hate us
 100     $d =~ s/\n(.+?)\s*$/\n/;
 101     push @extra, $d;
 102    }
 103   }
 104  }
 105
 106  my $num;
 107  $sess->report($self->report_class($sess)->new(
 108   id   => ++$num,
 109   kind => 'Suppression',
 110   data => $_,
 111  )) for @supps, @extra;
 112
 113  return 0;
 114 }
 115
 116 =head1 SEE ALSO
 117
 118 L<Test::Valgrind>, L<Test::Valgrind::Parser::Text>.
 119
 120 =head1 AUTHOR
 121
 122 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 123
 124 You can contact me by mail or on C<irc.perl.org> (vincent).
 125
 126 =head1 BUGS
 127
 128 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>.
 129 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 130
 131 =head1 SUPPORT
 132
 133 You can find documentation for this module with the perldoc command.
 134
 135     perldoc Test::Valgrind::Parser::Suppressions::Text
 136
 137 =head1 COPYRIGHT & LICENSE
 138
 139 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
 140
 141 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 142
 143 =cut
 144
 145 # End of Test::Valgrind::Parser::Suppressions::Text
 146
 147 package Test::Valgrind::Report::Suppressions;
 148
 149 use base qw<Test::Valgrind::Report>;
 150
 151 sub kinds { shift->SUPER::kinds(), 'Suppression' }
 152
 153 sub valid_kind {
 154  my ($self, $kind) = @_;
 155
 156  $self->SUPER::valid_kind($kind) or $kind eq 'Suppression'
 157 }
 158
 159 1; # End of Test::Valgrind::Report::Suppressions