X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FTool%2Fmemcheck.pm;h=3600937dcdaa4cb9520f5fc99f43e0f138e6d0a0;hb=93bdd32c84466f212aded61d70219e82cb538620;hp=c93ad2dbd38fa7a6cba2c55acf2468dd073090b7;hpb=8bd140c3f1dcd8d5f9bdca0ce59b315b75d911cf;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind/Tool/memcheck.pm b/lib/Test/Valgrind/Tool/memcheck.pm index c93ad2d..3600937 100644 --- a/lib/Test/Valgrind/Tool/memcheck.pm +++ b/lib/Test/Valgrind/Tool/memcheck.pm @@ -9,23 +9,23 @@ Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool. =head1 VERSION -Version 1.02 +Version 1.10 =cut -our $VERSION = '1.02'; +our $VERSION = '1.10'; =head1 DESCRIPTION -This tool parses the XML output of a C run with L. +This class contains the information required by the session for running the C tool. =cut -use base qw/Test::Valgrind::Tool::SuppressionsParser Test::Valgrind::Tool/; +use base qw/Test::Valgrind::Tool/; =head1 METHODS -This class inherits L and L. +This class inherits L. =head2 C @@ -58,8 +58,6 @@ sub new { $self->{callers} = $callers; - $self->{twig} = Test::Valgrind::Tool::memcheck::Twig->new(tool => $self); - $self; } @@ -73,23 +71,39 @@ Read-only accessor for the C option. sub callers { $_[0]->{callers} } -=head2 C +sub suppressions_tag { 'memcheck-' . $_[1]->version } + +=head2 C -Read-only accessor for the underlying L parser. +This tool uses a L parser in analysis mode, and a L parser in suppressions mode. =cut -sub twig { $_[0]->{twig} } +sub parser_class { + my ($self, $session) = @_; -sub suppressions_tag { 'memcheck-' . $_[1]->version } + my $class = $session->do_suppressions + ? 'Test::Valgrind::Parser::Suppressions::Text' + : 'Test::Valgrind::Parser::XML::Twig'; -=head2 C + local $@; + eval "require $class"; -This tool emits C object reports in analysis mode. + return $class; +} + +=head2 C + +This tool emits C object reports in analysis mode, and C object reports in suppressions mode. =cut -sub report_class_analysis { 'Test::Valgrind::Tool::memcheck::Report' } +sub report_class { + my ($self, $session) = @_; + + $session->do_suppressions ? 'Test::Valgrind::Report::Suppressions' + : 'Test::Valgrind::Tool::memcheck::Report' +} sub args { my $self = shift; @@ -104,54 +118,17 @@ sub args { '--error-limit=yes', ); - unless ($sess->do_suppressions) { - push @args, '--track-origins=yes' if $sess->version ge '3.4.0'; - push @args, '--xml=yes'; - } + push @args, '--track-origins=yes' if $sess->version ge '3.4.0' + and not $sess->do_suppressions; push @args, $self->SUPER::args(@_); return @args; } -# We must store the session in ourselves because it's only possible to pass -# arguments to XML::Twig objects by a global stash. - -sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) } - -sub start { - my ($self, $sess) = @_; - - $self->SUPER::start($sess); - $self->_session($sess); - - return; -} - -sub parse_analysis { - my ($self, $sess, $fh) = @_; - - my $twig = $self->twig; - $twig->parse($fh); - $twig->purge; - - return; -} - -sub finish { - my ($self, $sess) = @_; - - $self->_session(undef); - $self->SUPER::finish($sess); - - return; -} - =head1 SEE ALSO -L, L, L. - -L. +L, L. =head1 AUTHOR @@ -184,7 +161,7 @@ package Test::Valgrind::Tool::memcheck::Report; use base qw/Test::Valgrind::Report/; -our $VERSION = '1.02'; +our $VERSION = '1.10'; my @kinds = qw/ InvalidFree @@ -254,113 +231,3 @@ sub dump { # End of Test::Valgrind::Tool::memcheck::Report -package Test::Valgrind::Tool::memcheck::Twig; - -our $VERSION = '1.02'; - -use Scalar::Util; - -use base qw/XML::Twig Test::Valgrind::Carp/; - -BEGIN { XML::Twig->add_options('Stash'); } - -my %handlers = ( - '/valgrindoutput/error' => \&handle_error, -); - -sub new { - my $class = shift; - $class = ref($class) || $class; - - my %args = @_; - my $stash = delete $args{stash} || { }; - - my $tool = delete $args{tool}; - $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool) - and $tool->isa('Test::Valgrind::Tool'); - $stash->{tool} = $tool; - - bless $class->XML::Twig::new( - elt_class => __PACKAGE__ . '::Elt', - stash => $stash, - twig_roots => { map { $_ => 1 } keys %handlers }, - twig_handlers => { map { $_ => $handlers{$_} } keys %handlers }, - ), $class; -} - -sub stash { shift->{Stash} } - -sub handle_error { - my ($twig, $node) = @_; - - my $id = $node->kid('unique')->text; - my $kind = $node->kid('kind')->text; - - my $data; - - $data->{what} = $node->kid('what')->text; - $data->{stack} = [ map $_->listify_frame, - $node->kid('stack')->children('frame') ]; - - for (qw/leakedbytes leakedblocks/) { - my $kid = $node->first_child($_); - next unless $kid; - $data->{$_} = int $kid->text; - } - - if (my $auxwhat = $node->first_child('auxwhat')) { - if (my $stack = $auxwhat->next_sibling('stack')) { - $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ]; - } - $data->{auxwhat} = $auxwhat->text; - } - - if (my $origin = $node->first_child('origin')) { - $data->{origwhat} = $origin->kid('what')->text; - $data->{origstack} = [ map $_->listify_frame, - $origin->kid('stack')->children('frame') ]; - } - - my $tool = $twig->stash->{tool}; - my $sess = $tool->_session; - - $sess->report($tool->report_class($sess)->new( - kind => $kind, - id => $id, - data => $data, - )); - - $twig->purge; -} - -# End of Test::Valgrind::Tool::memcheck::Twig - -package Test::Valgrind::Tool::memcheck::Twig::Elt; - -our $VERSION = '1.02'; - -BEGIN { require XML::Twig; } - -use base qw/XML::Twig::Elt Test::Valgrind::Carp/; - -sub kid { - my ($self, $what) = @_; - my $node = $self->first_child($what); - $self->_croak("Couldn't get first $what child node") unless $node; - return $node; -} - -sub listify_frame { - my ($frame) = @_; - - return unless $frame->tag eq 'frame'; - - return [ - map { - my $x = $frame->first_child($_); - $x ? $x->text : undef - } qw/ip obj fn dir file line/ - ]; -} - -1; # End of Test::Valgrind::Tool::memcheck::Twig::Elt