]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - memcheck.pm
035b85550feb82f0fd638d292e33507dc3b532ff
[perl/modules/Test-Valgrind.git] / 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.01
13
14 =cut
15
16 our $VERSION = '1.01';
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::start($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.01';
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.01';
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.01';
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