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