lib/Test/Valgrind/Tool/memcheck.pm

   1 package Test::Valgrind::Tool::memcheck;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool.
   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 tool parses the XML output of a C<memcheck> run with L<XML::Twig>.
  21
  22 =cut
  23
  24 use base qw/Test::Valgrind::Tool/;
  25
  26 =head1 METHODS
  27
  28 This class inherits L<Test::Valgrind::Tool>.
  29
  30 =head2 C<requires_version>
  31
  32 This tool requires C<valgrind> C<3.1.0>.
  33
  34 =cut
  35
  36 sub requires_version { '3.1.0' }
  37
  38 =head2 C<< new callers => $callers, ... >>
  39
  40 Your usual constructor.
  41
  42 C<$callers> specifies the number of stack frames to inspect for errors : the bigger you set it, the more granular the analysis is.
  43
  44 Other arguments are passed straight to C<< Test::Valgrind::Tool->new >>.
  45
  46 =cut
  47
  48 sub new {
  49  my $class = shift;
  50  $class = ref($class) || $class;
  51
  52  my %args = @_;
  53
  54  my $callers = delete $args{callers} || 12;
  55  $callers =~ s/\D//g;
  56
  57  my $self = bless $class->Test::Valgrind::Tool::new(%args), $class;
  58
  59  $self->{callers} = $callers;
  60
  61  $self;
  62 }
  63
  64 sub new_trainer { shift->new(callers => 50) }
  65
  66 =head2 C<callers>
  67
  68 Read-only accessor for the C<callers> option.
  69
  70 =cut
  71
  72 sub callers { $_[0]->{callers} }
  73
  74 sub suppressions_tag { 'memcheck-' . $_[1]->version }
  75
  76 =head2 C<parser_class $session>
  77
  78 This tool uses a C<Test::Valgrind::Parser::XML::Twig> parser in analysis mode, and a C<Test::Valgrind::Parser::Suppressions::Text> parser in suppressions mode.
  79
  80 =cut
  81
  82 sub parser_class {
  83  my ($self, $session) = @_;
  84
  85  my $class = $session->do_suppressions
  86            ? 'Test::Valgrind::Parser::Suppressions::Text'
  87            : 'Test::Valgrind::Parser::XML::Twig';
  88
  89  local $@;
  90  eval "require $class";
  91
  92  return $class;
  93 }
  94
  95 =head2 C<report_class $session>
  96
  97 This tool emits C<Test::Valgrind::Tool::memcheck::Report> object reports in analysis mode.
  98
  99 =cut
 100
 101 sub report_class {
 102  my ($self, $session) = @_;
 103
 104  $session->do_suppressions ? 'Test::Valgrind::Report::Suppressions'
 105                            : 'Test::Valgrind::Tool::memcheck::Report'
 106 }
 107
 108 sub args {
 109  my $self = shift;
 110  my ($sess) = @_;
 111
 112  my @args = (
 113   '--tool=memcheck',
 114   '--leak-check=full',
 115   '--leak-resolution=high',
 116   '--show-reachable=yes',
 117   '--num-callers=' . $self->callers,
 118   '--error-limit=yes',
 119  );
 120
 121  unless ($sess->do_suppressions) {
 122   push @args, '--track-origins=yes' if $sess->version ge '3.4.0';
 123   push @args, '--xml=yes';
 124  }
 125
 126  push @args, $self->SUPER::args(@_);
 127
 128  return @args;
 129 }
 130
 131 =head1 SEE ALSO
 132
 133 L<Test::Valgrind>, L<Test::Valgrind::Tool>.
 134
 135 L<XML::Twig>.
 136
 137 =head1 AUTHOR
 138
 139 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 140
 141 You can contact me by mail or on C<irc.perl.org> (vincent).
 142
 143 =head1 BUGS
 144
 145 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>.
 146 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 147
 148 =head1 SUPPORT
 149
 150 You can find documentation for this module with the perldoc command.
 151
 152     perldoc Test::Valgrind::Tool::memcheck
 153
 154 =head1 COPYRIGHT & LICENSE
 155
 156 Copyright 2009 Vincent Pit, all rights reserved.
 157
 158 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 159
 160 =cut
 161
 162 # End of Test::Valgrind::Tool::memcheck
 163
 164 package Test::Valgrind::Tool::memcheck::Report;
 165
 166 use base qw/Test::Valgrind::Report/;
 167
 168 our $VERSION = '1.10';
 169
 170 my @kinds = qw/
 171  InvalidFree
 172  MismatchedFree
 173  InvalidRead
 174  InvalidWrite
 175  InvalidJump
 176  Overlap
 177  InvalidMemPool
 178  UninitCondition
 179  UninitValue
 180  SyscallParam
 181  ClientCheck
 182  Leak_DefinitelyLost
 183  Leak_IndirectlyLost
 184  Leak_PossiblyLost
 185  Leak_StillReachable
 186 /;
 187 push @kinds, __PACKAGE__->SUPER::kinds();
 188
 189 my %kinds_hashed = map { $_ => 1 } @kinds;
 190
 191 sub kinds      { @kinds }
 192
 193 sub valid_kind { exists $kinds_hashed{$_[1]} }
 194
 195 sub is_leak    { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
 196
 197 my $pad;
 198 BEGIN {
 199  require Config;
 200  $pad = 2 * ($Config::Config{ptrsize} || 4);
 201 }
 202
 203 sub dump {
 204  my ($self) = @_;
 205
 206  my $data = $self->data;
 207
 208  my $desc = '';
 209
 210  for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
 211   my ($prefix, $wind, $sind) = @$_;
 212
 213   my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
 214   next unless defined $what and defined $stack;
 215
 216   $_ = ' ' x $_ for $wind, $sind;
 217
 218   $desc .= "$wind$what\n";
 219   for (@$stack) {
 220    my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
 221    my $frame;
 222    if ($fn eq '?' and $obj eq '?') {
 223     $ip =~ s/^0x//g;
 224     $ip = hex $ip;
 225     $frame = sprintf "0x%0${pad}X", $ip;
 226    } else {
 227     $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
 228    }
 229    $desc .= "$sind$frame\n";
 230   }
 231  }
 232
 233  return $desc;
 234 }
 235
 236 # End of Test::Valgrind::Tool::memcheck::Report
 237