lib/Test/Valgrind/Parser/XML/Twig.pm

   1 package Test::Valgrind::Parser::XML::Twig;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '1.02';
   7
   8 use Scalar::Util ();
   9
  10 use base qw/XML::Twig Test::Valgrind::Carp/;
  11
  12 BEGIN { XML::Twig->add_options('Stash'); }
  13
  14 my %handlers = (
  15  '/valgrindoutput/error' => \&handle_error,
  16 );
  17
  18 sub new {
  19  my $class = shift;
  20  $class = ref($class) || $class;
  21
  22  my %args = @_;
  23  my $stash = delete $args{stash} || { };
  24
  25  my $tool = delete $args{tool};
  26  $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool)
  27                                          and $tool->isa('Test::Valgrind::Tool');
  28  $stash->{tool} = $tool;
  29
  30  bless $class->XML::Twig::new(
  31   elt_class     => __PACKAGE__ . '::Elt',
  32   stash         => $stash,
  33   twig_roots    => { map { $_ => 1             } keys %handlers },
  34   twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
  35  ), $class;
  36 }
  37
  38 sub stash { shift->{Stash} }
  39
  40 sub handle_error {
  41  my ($twig, $node) = @_;
  42
  43  my $id   = $node->kid('unique')->text;
  44  my $kind = $node->kid('kind')->text;
  45
  46  my $data;
  47
  48  $data->{what}  = $node->kid('what')->text;
  49  $data->{stack} = [ map $_->listify_frame,
  50                                        $node->kid('stack')->children('frame') ];
  51
  52  for (qw/leakedbytes leakedblocks/) {
  53   my $kid = $node->first_child($_);
  54   next unless $kid;
  55   $data->{$_} = int $kid->text;
  56  }
  57
  58  if (my $auxwhat = $node->first_child('auxwhat')) {
  59   if (my $stack = $auxwhat->next_sibling('stack')) {
  60    $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
  61   }
  62   $data->{auxwhat} = $auxwhat->text;
  63  }
  64
  65  if (my $origin = $node->first_child('origin')) {
  66   $data->{origwhat}  = $origin->kid('what')->text;
  67   $data->{origstack} = [ map $_->listify_frame,
  68                                      $origin->kid('stack')->children('frame') ];
  69  }
  70
  71  my $tool = $twig->stash->{tool};
  72  my $sess = $tool->_session;
  73
  74  $sess->report($tool->report_class($sess)->new(
  75   kind => $kind,
  76   id   => $id,
  77   data => $data,
  78  ));
  79
  80  $twig->purge;
  81 }
  82
  83 # End of Test::Valgrind::Parser::XML::Twig
  84
  85 package Test::Valgrind::Parser::XML::Twig::Elt;
  86
  87 our $VERSION = '1.02';
  88
  89 BEGIN { require XML::Twig; }
  90
  91 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
  92
  93 sub kid {
  94  my ($self, $what) = @_;
  95  my $node = $self->first_child($what);
  96  $self->_croak("Couldn't get first $what child node") unless $node;
  97  return $node;
  98 }
  99
 100 sub listify_frame {
 101  my ($frame) = @_;
 102
 103  return unless $frame->tag eq 'frame';
 104
 105  return [
 106   map {
 107    my $x = $frame->first_child($_);
 108    $x ? $x->text : undef
 109   } qw/ip obj fn dir file line/
 110  ];
 111 }
 112
 113 1; # End of Test::Valgrind::Parser::XML::Twig::Elt