1 package Test::Valgrind::Tool::memcheck;
8 Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool.
16 our $VERSION = '1.18';
20 This class contains the information required by the session for running the C<memcheck> tool.
26 use base qw<Test::Valgrind::Tool>;
30 This class inherits L<Test::Valgrind::Tool>.
32 =head2 C<requires_version>
34 my $required_version = $tvt->requires_version;
36 This tool requires C<valgrind> C<3.1.0>.
40 sub requires_version { '3.1.0' }
44 my $tvtm = Test::Valgrind::Tool::memcheck->new(
49 Your usual constructor.
51 C<$callers> specifies the number of stack frames to inspect for errors : the bigger you set it, the more granular the analysis is.
53 Other arguments are passed straight to C<< Test::Valgrind::Tool->new >>.
59 $class = ref($class) || $class;
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
69 my $self = bless $class->Test::Valgrind::Tool::new(%args), $class;
71 $self->{callers} = $callers;
76 sub new_trainer { shift->new(callers => 24) }
80 my $callers = $tvtm->callers;
82 Read-only accessor for the C<callers> option.
86 sub callers { $_[0]->{callers} }
88 sub suppressions_tag { 'memcheck-' . $_[1]->version }
90 =head2 C<parser_class>
92 my $parser_class = $tvtm->parser_class($session);
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.
99 my ($self, $session) = @_;
101 my $class = $session->do_suppressions
102 ? 'Test::Valgrind::Parser::Suppressions::Text'
103 : 'Test::Valgrind::Parser::XML::Twig';
107 eval "require $class; 1" or die $@;
113 =head2 C<report_class>
115 my $report_class = $tvtm->report_class($session);
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.
122 my ($self, $session) = @_;
124 if ($session->do_suppressions) {
125 require Test::Valgrind::Parser::Suppressions::Text;
126 return 'Test::Valgrind::Report::Suppressions';
128 return 'Test::Valgrind::Tool::memcheck::Report';
139 '--leak-resolution=high',
140 '--show-reachable=yes',
141 '--num-callers=' . $self->callers,
145 push @args, '--track-origins=yes' if $sess->version >= '3.4.0'
146 and not $sess->do_suppressions;
148 push @args, $self->SUPER::args(@_);
155 L<Test::Valgrind>, L<Test::Valgrind::Tool>.
159 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
161 You can contact me by mail or on C<irc.perl.org> (vincent).
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.
170 You can find documentation for this module with the perldoc command.
172 perldoc Test::Valgrind::Tool::memcheck
174 =head1 COPYRIGHT & LICENSE
176 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
178 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
182 # End of Test::Valgrind::Tool::memcheck
184 package Test::Valgrind::Tool::memcheck::Report;
186 use base qw<Test::Valgrind::Report>;
188 our $VERSION = '1.18';
207 push @kinds, __PACKAGE__->SUPER::kinds();
209 my %kinds_hashed = map { $_ => 1 } @kinds;
213 sub valid_kind { exists $kinds_hashed{$_[1]} }
215 sub is_leak { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
220 $pad = 2 * ($Config::Config{ptrsize} || 4);
226 my $data = $self->data;
230 for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
231 my ($prefix, $wind, $sind) = @$_;
233 my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
234 next unless defined $what and defined $stack;
236 $_ = ' ' x $_ for $wind, $sind;
238 $desc .= "$wind$what\n";
240 my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
242 if ($fn eq '?' and $obj eq '?') {
245 $frame = '0x' . ($l < $pad ? ('0' x ($pad - $l)) : '') . uc($ip);
247 $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
249 $desc .= "$sind$frame\n";
256 # End of Test::Valgrind::Tool::memcheck::Report