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