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