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  bless $class->XML::Twig::new(
  26   elt_class     => __PACKAGE__ . '::Elt',
  27   stash         => $stash,
  28   twig_roots    => { map { $_ => 1             } keys %handlers },
  29   twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
  30  ), $class;
  31 }
  32
  33 sub stash { shift->{Stash} }
  34
  35 # We must store the session in ourselves because it's only possible to pass
  36 # arguments to XML::Twig objects by a global stash.
  37
  38 sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) }
  39
  40 sub start {
  41  my ($self, $sess) = @_;
  42
  43  $self->SUPER::start($sess);
  44  $self->_session($sess);
  45
  46  return;
  47 }
  48
  49 sub parse {
  50  my ($self, $sess, $fh) = @_;
  51
  52  $self->XML::Twig::parse($fh);
  53  $self->purge;
  54
  55  return;
  56 }
  57
  58 sub finish {
  59  my ($self, $sess) = @_;
  60
  61  $self->_session(undef);
  62  $self->SUPER::finish($sess);
  63
  64  return;
  65 }
  66
  67 sub handle_error {
  68  my ($twig, $node) = @_;
  69
  70  my $id   = $node->kid('unique')->text;
  71  my $kind = $node->kid('kind')->text;
  72
  73  my $data;
  74
  75  $data->{what}  = $node->kid('what')->text;
  76  $data->{stack} = [ map $_->listify_frame,
  77                                        $node->kid('stack')->children('frame') ];
  78
  79  for (qw/leakedbytes leakedblocks/) {
  80   my $kid = $node->first_child($_);
  81   next unless $kid;
  82   $data->{$_} = int $kid->text;
  83  }
  84
  85  if (my $auxwhat = $node->first_child('auxwhat')) {
  86   if (my $stack = $auxwhat->next_sibling('stack')) {
  87    $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
  88   }
  89   $data->{auxwhat} = $auxwhat->text;
  90  }
  91
  92  if (my $origin = $node->first_child('origin')) {
  93   $data->{origwhat}  = $origin->kid('what')->text;
  94   $data->{origstack} = [ map $_->listify_frame,
  95                                      $origin->kid('stack')->children('frame') ];
  96  }
  97
  98  my $sess = $twig->_session;
  99
 100  $sess->report($sess->report_class($sess)->new(
 101   kind => $kind,
 102   id   => $id,
 103   data => $data,
 104  ));
 105
 106  $twig->purge;
 107 }
 108
 109 # End of Test::Valgrind::Parser::XML::Twig
 110
 111 package Test::Valgrind::Parser::XML::Twig::Elt;
 112
 113 our $VERSION = '1.02';
 114
 115 BEGIN { require XML::Twig; }
 116
 117 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
 118
 119 sub kid {
 120  my ($self, $what) = @_;
 121  my $node = $self->first_child($what);
 122  $self->_croak("Couldn't get first $what child node") unless $node;
 123  return $node;
 124 }
 125
 126 sub listify_frame {
 127  my ($frame) = @_;
 128
 129  return unless $frame->tag eq 'frame';
 130
 131  return [
 132   map {
 133    my $x = $frame->first_child($_);
 134    $x ? $x->text : undef
 135   } qw/ip obj fn dir file line/
 136  ];
 137 }
 138
 139 1; # End of Test::Valgrind::Parser::XML::Twig::Elt