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.02
  13
  14 =cut
  15
  16 our $VERSION = '1.02';
  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::SuppressionsParser Test::Valgrind::Tool/;
  25
  26 =head1 METHODS
  27
  28 This class inherits L<Test::Valgrind::Tool> and L<Test::Valgrind::Tool::SuppressionsParser>.
  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->{twig} = Test::Valgrind::Tool::memcheck::Twig->new(tool => $self);
  62
  63  $self;
  64 }
  65
  66 sub new_trainer { shift->new(callers => 50) }
  67
  68 =head2 C<callers>
  69
  70 Read-only accessor for the C<callers> option.
  71
  72 =cut
  73
  74 sub callers { $_[0]->{callers} }
  75
  76 =head2 C<twig>
  77
  78 Read-only accessor for the underlying L<XML::Twig> parser.
  79
  80 =cut
  81
  82 sub twig { $_[0]->{twig} }
  83
  84 sub suppressions_tag { 'memcheck-' . $_[1]->version }
  85
  86 =head2 C<report_class_analysis $session>
  87
  88 This tool emits C<Test::Valgrind::Tool::memcheck::Report> object reports in analysis mode.
  89
  90 =cut
  91
  92 sub report_class_analysis { 'Test::Valgrind::Tool::memcheck::Report' }
  93
  94 sub args {
  95  my ($self, $sess) = @_;
  96
  97  my @args = (
  98   '--tool=memcheck',
  99   '--leak-check=full',
 100   '--leak-resolution=high',
 101   '--show-reachable=yes',
 102   '--num-callers=' . $self->callers,
 103   '--error-limit=yes',
 104  );
 105
 106  unless ($sess->do_suppressions) {
 107   push @args, '--track-origins=yes' if $sess->version ge '3.4.0';
 108   push @args, '--xml=yes';
 109  }
 110
 111  push @args, $self->SUPER::args();
 112
 113  return @args;
 114 }
 115
 116 # We must store the session in ourselves because it's only possible to pass
 117 # arguments to XML::Twig objects by a global stash.
 118
 119 sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) }
 120
 121 sub start {
 122  my ($self, $sess) = @_;
 123
 124  $self->_croak('This memcheck tool can\'t be run in two sessions at once')
 125                                                              if $self->_session;
 126
 127  $self->SUPER::start($sess);
 128  $self->_session($sess);
 129
 130  return;
 131 }
 132
 133 sub parse_analysis {
 134  my ($self, $sess, $fh) = @_;
 135
 136  my $twig = $self->twig;
 137  $twig->parse($fh);
 138  $twig->purge;
 139
 140  return;
 141 }
 142
 143 sub finish {
 144  my ($self, $sess) = @_;
 145
 146  $self->_session(undef);
 147  $self->SUPER::finish($sess);
 148
 149  return;
 150 }
 151
 152 =head1 SEE ALSO
 153
 154 L<Test::Valgrind>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Tool::SuppressionsParser>.
 155
 156 L<XML::Twig>.
 157
 158 =head1 AUTHOR
 159
 160 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 161
 162 You can contact me by mail or on C<irc.perl.org> (vincent).
 163
 164 =head1 BUGS
 165
 166 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>.
 167 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 168
 169 =head1 SUPPORT
 170
 171 You can find documentation for this module with the perldoc command.
 172
 173     perldoc Test::Valgrind::Tool::memcheck
 174
 175 =head1 COPYRIGHT & LICENSE
 176
 177 Copyright 2009 Vincent Pit, all rights reserved.
 178
 179 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 180
 181 =cut
 182
 183 # End of Test::Valgrind::Tool::memcheck
 184
 185 package Test::Valgrind::Tool::memcheck::Report;
 186
 187 use base qw/Test::Valgrind::Report/;
 188
 189 our $VERSION = '1.02';
 190
 191 my @kinds = qw/
 192  InvalidFree
 193  MismatchedFree
 194  InvalidRead
 195  InvalidWrite
 196  InvalidJump
 197  Overlap
 198  InvalidMemPool
 199  UninitCondition
 200  UninitValue
 201  SyscallParam
 202  ClientCheck
 203  Leak_DefinitelyLost
 204  Leak_IndirectlyLost
 205  Leak_PossiblyLost
 206  Leak_StillReachable
 207 /;
 208 push @kinds, __PACKAGE__->SUPER::kinds();
 209
 210 my %kinds_hashed = map { $_ => 1 } @kinds;
 211
 212 sub kinds      { @kinds }
 213
 214 sub valid_kind { exists $kinds_hashed{$_[1]} }
 215
 216 sub is_leak    { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
 217
 218 my $pad;
 219 BEGIN {
 220  require Config;
 221  $pad = 2 * ($Config::Config{ptrsize} || 4);
 222 }
 223
 224 sub dump {
 225  my ($self) = @_;
 226
 227  my $data = $self->data;
 228
 229  my $desc = '';
 230
 231  for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
 232   my ($prefix, $wind, $sind) = @$_;
 233
 234   my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
 235   next unless defined $what and defined $stack;
 236
 237   $_ = ' ' x $_ for $wind, $sind;
 238
 239   $desc .= "$wind$what\n";
 240   for (@$stack) {
 241    my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
 242    my $frame;
 243    if ($fn eq '?' and $obj eq '?') {
 244     $ip =~ s/^0x//g;
 245     $ip = hex $ip;
 246     $frame = sprintf "0x%0${pad}X", $ip;
 247    } else {
 248     $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
 249    }
 250    $desc .= "$sind$frame\n";
 251   }
 252  }
 253
 254  return $desc;
 255 }
 256
 257 # End of Test::Valgrind::Tool::memcheck::Report
 258
 259 package Test::Valgrind::Tool::memcheck::Twig;
 260
 261 our $VERSION = '1.02';
 262
 263 use Scalar::Util;
 264
 265 use base qw/XML::Twig Test::Valgrind::Carp/;
 266
 267 BEGIN { XML::Twig->add_options('Stash'); }
 268
 269 my %handlers = (
 270  '/valgrindoutput/error' => \&handle_error,
 271 );
 272
 273 sub new {
 274  my $class = shift;
 275  $class = ref($class) || $class;
 276
 277  my %args = @_;
 278  my $stash = delete $args{stash} || { };
 279
 280  my $tool = delete $args{tool};
 281  $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool)
 282                                          and $tool->isa('Test::Valgrind::Tool');
 283  $stash->{tool} = $tool;
 284
 285  bless $class->XML::Twig::new(
 286   elt_class     => __PACKAGE__ . '::Elt',
 287   stash         => $stash,
 288   twig_roots    => { map { $_ => 1             } keys %handlers },
 289   twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
 290  ), $class;
 291 }
 292
 293 sub stash { shift->{Stash} }
 294
 295 sub handle_error {
 296  my ($twig, $node) = @_;
 297
 298  my $id   = $node->kid('unique')->text;
 299  my $kind = $node->kid('kind')->text;
 300
 301  my $data;
 302
 303  $data->{what}  = $node->kid('what')->text;
 304  $data->{stack} = [ map $_->listify_frame,
 305                                        $node->kid('stack')->children('frame') ];
 306
 307  for (qw/leakedbytes leakedblocks/) {
 308   my $kid = $node->first_child($_);
 309   next unless $kid;
 310   $data->{$_} = int $kid->text;
 311  }
 312
 313  if (my $auxwhat = $node->first_child('auxwhat')) {
 314   if (my $stack = $auxwhat->next_sibling('stack')) {
 315    $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
 316   }
 317   $data->{auxwhat} = $auxwhat->text;
 318  }
 319
 320  if (my $origin = $node->first_child('origin')) {
 321   $data->{origwhat}  = $origin->kid('what')->text;
 322   $data->{origstack} = [ map $_->listify_frame,
 323                                      $origin->kid('stack')->children('frame') ];
 324  }
 325
 326  my $report = Test::Valgrind::Tool::memcheck::Report->new(
 327   kind => $kind,
 328   id   => $id,
 329   data => $data,
 330  );
 331
 332  $twig->stash->{tool}->_session->report($report);
 333
 334  $twig->purge;
 335 }
 336
 337 # End of Test::Valgrind::Tool::memcheck::Twig
 338
 339 package Test::Valgrind::Tool::memcheck::Twig::Elt;
 340
 341 our $VERSION = '1.02';
 342
 343 BEGIN { require XML::Twig; }
 344
 345 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
 346
 347 sub kid {
 348  my ($self, $what) = @_;
 349  my $node = $self->first_child($what);
 350  $self->_croak("Couldn't get first $what child node") unless $node;
 351  return $node;
 352 }
 353
 354 sub listify_frame {
 355  my ($frame) = @_;
 356
 357  return unless $frame->tag eq 'frame';
 358
 359  return [
 360   map {
 361    my $x = $frame->first_child($_);
 362    $x ? $x->text : undef
 363   } qw/ip obj fn dir file line/
 364  ];
 365 }
 366
 367 1; # End of Test::Valgrind::Tool::memcheck::Twig::Elt