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