1 package Test::Valgrind::Tool::memcheck;
8 Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool.
16 our $VERSION = '1.00';
20 This tool parses the XML output of a C<memcheck> run with L<XML::Twig>.
24 use base qw/Test::Valgrind::Tool::SuppressionsParser Test::Valgrind::Tool/;
28 This class inherits L<Test::Valgrind::Tool> and L<Test::Valgrind::Tool::SuppressionsParser>.
30 =head2 C<requires_version>
32 This tool requires C<valgrind> C<3.1.0>.
36 sub requires_version { '3.1.0' }
38 =head2 C<< new callers => $callers, ... >>
40 Your usual constructor.
42 C<$callers> specifies the number of stack frames to inspect for errors : the bigger you set it, the more granular the analysis is.
44 Other arguments are passed straight to C<< Test::Valgrind::Tool->new >>.
50 $class = ref($class) || $class;
54 my $callers = delete $args{callers} || 12;
57 my $self = bless $class->Test::Valgrind::Tool::new(%args), $class;
59 $self->{callers} = $callers;
61 $self->{twig} = Test::Valgrind::Tool::memcheck::Twig->new(tool => $self);
66 sub new_trainer { shift->new(callers => 50) }
70 Read-only accessor for the C<callers> option.
74 sub callers { $_[0]->{callers} }
78 Read-only accessor for the underlying L<XML::Twig> parser.
82 sub twig { $_[0]->{twig} }
84 sub suppressions_tag { 'memcheck-' . $_[1]->version }
86 =head2 C<report_class_analysis $session>
88 This tool emits C<Test::Valgrind::Tool::memcheck::Report> object reports in analysis mode.
92 sub report_class_analysis { 'Test::Valgrind::Tool::memcheck::Report' }
95 my ($self, $sess) = @_;
100 '--leak-resolution=high',
101 '--show-reachable=yes',
102 '--num-callers=' . $self->callers,
106 unless ($sess->do_suppressions) {
107 push @args, '--track-origins=yes' if $sess->version ge '3.4.0';
108 push @args, '--xml=yes';
111 push @args, $self->SUPER::args();
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.
119 sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) }
122 my ($self, $sess) = @_;
124 $self->_croak('This memcheck tool can\'t be run in two sessions at once')
127 $self->SUPER::start($sess);
128 $self->_session($sess);
134 my ($self, $sess, $fh) = @_;
136 my $twig = $self->twig;
144 my ($self, $sess) = @_;
146 $self->_session(undef);
147 $self->SUPER::start($sess);
154 L<Test::Valgrind>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Tool::SuppressionsParser>.
160 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
162 You can contact me by mail or on C<irc.perl.org> (vincent).
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.
171 You can find documentation for this module with the perldoc command.
173 perldoc Test::Valgrind::Tool::memcheck
175 =head1 COPYRIGHT & LICENSE
177 Copyright 2009 Vincent Pit, all rights reserved.
179 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
183 # End of Test::Valgrind::Tool::memcheck
185 package Test::Valgrind::Tool::memcheck::Report;
187 use base qw/Test::Valgrind::Report/;
189 use Config qw/%Config/;
191 our $VERSION = '1.00';
210 push @kinds, __PACKAGE__->SUPER::kinds();
212 my %kinds_hashed = map { $_ => 1 } @kinds;
216 sub valid_kind { exists $kinds_hashed{$_[1]} }
218 sub is_leak { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
220 my $pad = 2 * ($Config{ptrsize} || 4);
225 my $data = $self->data;
229 for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
230 my ($prefix, $wind, $sind) = @$_;
232 my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
233 next unless defined $what and defined $stack;
235 $_ = ' ' x $_ for $wind, $sind;
237 $desc .= "$wind$what\n";
239 my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
241 if ($fn eq '?' and $obj eq '?') {
244 $frame = sprintf "0x%0${pad}X", $ip;
246 $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
248 $desc .= "$sind$frame\n";
255 # End of Test::Valgrind::Tool::memcheck::Report
257 package Test::Valgrind::Tool::memcheck::Twig;
259 our $VERSION = '1.00';
263 use base qw/XML::Twig Test::Valgrind::Carp/;
265 BEGIN { XML::Twig->add_options('Stash'); }
268 '/valgrindoutput/error' => \&handle_error,
273 $class = ref($class) || $class;
276 my $stash = delete $args{stash} || { };
278 my $tool = delete $args{tool};
279 $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool)
280 and $tool->isa('Test::Valgrind::Tool');
281 $stash->{tool} = $tool;
283 bless $class->XML::Twig::new(
284 elt_class => __PACKAGE__ . '::Elt',
286 twig_roots => { map { $_ => 1 } keys %handlers },
287 twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
291 sub stash { shift->{Stash} }
294 my ($twig, $node) = @_;
296 my $id = $node->kid('unique')->text;
297 my $kind = $node->kid('kind')->text;
301 $data->{what} = $node->kid('what')->text;
302 $data->{stack} = [ map $_->listify_frame,
303 $node->kid('stack')->children('frame') ];
305 for (qw/leakedbytes leakedblocks/) {
306 my $kid = $node->first_child($_);
308 $data->{$_} = int $kid->text;
311 if (my $auxwhat = $node->first_child('auxwhat')) {
312 if (my $stack = $auxwhat->next_sibling('stack')) {
313 $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
315 $data->{auxwhat} = $auxwhat->text;
318 if (my $origin = $node->first_child('origin')) {
319 $data->{origwhat} = $origin->kid('what')->text;
320 $data->{origstack} = [ map $_->listify_frame,
321 $origin->kid('stack')->children('frame') ];
324 my $report = Test::Valgrind::Tool::memcheck::Report->new(
330 $twig->stash->{tool}->_session->report($report);
335 # End of Test::Valgrind::Tool::memcheck::Twig
337 package Test::Valgrind::Tool::memcheck::Twig::Elt;
339 our $VERSION = '1.00';
341 BEGIN { require XML::Twig; }
343 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
346 my ($self, $what) = @_;
347 my $node = $self->first_child($what);
348 $self->_croak("Couldn't get first $what child node") unless $node;
355 return unless $frame->tag eq 'frame';
359 my $x = $frame->first_child($_);
360 $x ? $x->text : undef
361 } qw/ip obj fn dir file line/
365 1; # End of Test::Valgrind::Tool::memcheck::Twig::Elt