1 package Test::Valgrind::Tool::memcheck;
8 Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool.
16 our $VERSION = '1.10';
20 This tool parses the XML output of a C<memcheck> run with L<XML::Twig>.
24 use base qw/Test::Valgrind::Tool/;
28 This class inherits L<Test::Valgrind::Tool>.
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;
64 sub new_trainer { shift->new(callers => 50) }
68 Read-only accessor for the C<callers> option.
72 sub callers { $_[0]->{callers} }
74 sub suppressions_tag { 'memcheck-' . $_[1]->version }
76 =head2 C<parser_class $session>
78 This tool uses a C<Test::Valgrind::Parser::XML::Twig> parser in analysis mode, and a C<Test::Valgrind::Parser::Suppressions::Text> parser in suppressions mode.
83 my ($self, $session) = @_;
85 my $class = $session->do_suppressions
86 ? 'Test::Valgrind::Parser::Suppressions::Text'
87 : 'Test::Valgrind::Parser::XML::Twig';
90 eval "require $class";
95 =head2 C<report_class $session>
97 This tool emits C<Test::Valgrind::Tool::memcheck::Report> object reports in analysis mode.
102 my ($self, $session) = @_;
104 $session->do_suppressions ? 'Test::Valgrind::Report::Suppressions'
105 : 'Test::Valgrind::Tool::memcheck::Report'
115 '--leak-resolution=high',
116 '--show-reachable=yes',
117 '--num-callers=' . $self->callers,
121 unless ($sess->do_suppressions) {
122 push @args, '--track-origins=yes' if $sess->version ge '3.4.0';
123 push @args, '--xml=yes';
126 push @args, $self->SUPER::args(@_);
133 L<Test::Valgrind>, L<Test::Valgrind::Tool>.
139 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
141 You can contact me by mail or on C<irc.perl.org> (vincent).
145 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>.
146 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
150 You can find documentation for this module with the perldoc command.
152 perldoc Test::Valgrind::Tool::memcheck
154 =head1 COPYRIGHT & LICENSE
156 Copyright 2009 Vincent Pit, all rights reserved.
158 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
162 # End of Test::Valgrind::Tool::memcheck
164 package Test::Valgrind::Tool::memcheck::Report;
166 use base qw/Test::Valgrind::Report/;
168 our $VERSION = '1.10';
187 push @kinds, __PACKAGE__->SUPER::kinds();
189 my %kinds_hashed = map { $_ => 1 } @kinds;
193 sub valid_kind { exists $kinds_hashed{$_[1]} }
195 sub is_leak { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
200 $pad = 2 * ($Config::Config{ptrsize} || 4);
206 my $data = $self->data;
210 for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
211 my ($prefix, $wind, $sind) = @$_;
213 my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
214 next unless defined $what and defined $stack;
216 $_ = ' ' x $_ for $wind, $sind;
218 $desc .= "$wind$what\n";
220 my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
222 if ($fn eq '?' and $obj eq '?') {
225 $frame = sprintf "0x%0${pad}X", $ip;
227 $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
229 $desc .= "$sind$frame\n";
236 # End of Test::Valgrind::Tool::memcheck::Report