-package Test::Valgrind::Tool::memcheck::Twig;
-
-our $VERSION = '1.00';
-
-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 $report = Test::Valgrind::Tool::memcheck::Report->new(
- kind => $kind,
- id => $id,
- data => $data,
- );
-
- $twig->stash->{tool}->_session->report($report);
-
- $twig->purge;
-}
-
-# End of Test::Valgrind::Tool::memcheck::Twig
-
-package Test::Valgrind::Tool::memcheck::Twig::Elt;
-
-our $VERSION = '1.00';
-
-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