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

   1 package Test::Valgrind::Parser::XML::Twig;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig.
   9
  10 =head1 VERSION
  11
  12 Version 1.10
  13
  14 =cut
  15
  16 our $VERSION = '1.10';
  17
  18 =head1 DESCRIPTION
  19
  20 This subclass of L<XML::Twig> and L<Test::Valgrind::Parser::XML> encapsulates an L<XML::Twig> parser inside the L<Test::Valgrind::Parser> framework.
  21 It is able to parse the XML output from C<valgrind> up to protocol version 4 and to generate the appropriate reports accordingly.
  22
  23 =cut
  24
  25 use Scalar::Util ();
  26
  27 use base qw/Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig/;
  28
  29 BEGIN { XML::Twig->add_options('Stash'); }
  30
  31 my %handlers = (
  32  '/valgrindoutput/protocolversion' => \&handle_version,
  33  '/valgrindoutput/error'           => \&handle_error,
  34 );
  35
  36 =head1 METHODS
  37
  38 =cut
  39
  40 sub new {
  41  my $class = shift;
  42  $class = ref($class) || $class;
  43
  44  my %args = @_;
  45  my $stash = delete $args{stash} || { };
  46
  47  bless $class->XML::Twig::new(
  48   elt_class     => __PACKAGE__ . '::Elt',
  49   stash         => $stash,
  50   twig_roots    => { map { $_ => 1             } keys %handlers },
  51   twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
  52  ), $class;
  53 }
  54
  55 sub stash { shift->{Stash} }
  56
  57 =head2 C<protocol_version>
  58
  59 The version of the protocol that the current stream is conforming to.
  60 It is reset before and after the parsing phase, so it's effectively only available from inside L</parse>.
  61
  62 =cut
  63
  64 eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
  65                                               for qw/_session protocol_version/;
  66
  67 # We must store the session in ourselves because it's only possible to pass
  68 # arguments to XML::Twig objects by a global stash.
  69
  70 sub start {
  71  my ($self, $sess) = @_;
  72
  73  $self->SUPER::start($sess);
  74  $self->_session($sess);
  75
  76  return;
  77 }
  78
  79 sub parse {
  80  my ($self, $sess, $fh) = @_;
  81
  82  $self->protocol_version(undef);
  83
  84  $self->XML::Twig::parse($fh);
  85  $self->purge;
  86
  87  $self->protocol_version(undef);
  88
  89  return;
  90 }
  91
  92 sub finish {
  93  my ($self, $sess) = @_;
  94
  95  $self->_session(undef);
  96  $self->SUPER::finish($sess);
  97
  98  return;
  99 }
 100
 101 sub handle_version {
 102  my ($twig, $node) = @_;
 103
 104  $twig->protocol_version($node->text);
 105
 106  $twig->purge;
 107 }
 108
 109 sub handle_error {
 110  my ($twig, $node) = @_;
 111
 112  my $id   = $node->kid('unique')->text;
 113  my $kind = $node->kid('kind')->text;
 114
 115  my $data;
 116
 117  my ($what, $xwhat);
 118  if ($twig->protocol_version >= 4) {
 119   $xwhat = $node->first_child('xwhat');
 120   $what  = $xwhat->kid('text')->text if defined $xwhat;
 121  }
 122  $what = $node->kid('what')->text unless defined $what;
 123  $data->{what} = $what;
 124
 125  $data->{stack} = [ map $_->listify_frame,
 126                                        $node->kid('stack')->children('frame') ];
 127
 128  for (qw/leakedbytes leakedblocks/) {
 129   my $kid = ($xwhat || $node)->first_child($_);
 130   next unless $kid;
 131   $data->{$_} = int $kid->text;
 132  }
 133
 134  if (my $auxwhat = $node->first_child('auxwhat')) {
 135   if (my $stack = $auxwhat->next_sibling('stack')) {
 136    $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
 137   }
 138   $data->{auxwhat} = $auxwhat->text;
 139  }
 140
 141  if (my $origin = $node->first_child('origin')) {
 142   $data->{origwhat}  = $origin->kid('what')->text;
 143   $data->{origstack} = [ map $_->listify_frame,
 144                                      $origin->kid('stack')->children('frame') ];
 145  }
 146
 147  my $sess = $twig->_session;
 148
 149  $sess->report($sess->report_class($sess)->new(
 150   kind => $kind,
 151   id   => $id,
 152   data => $data,
 153  ));
 154
 155  $twig->purge;
 156 }
 157
 158 =head1 SEE ALSO
 159
 160 L<Test::Valgrind>, L<Test::Valgrind::Parser>, L<Test::Valgrind::Parser::XML>.
 161
 162 L<XML::Twig>.
 163
 164 =head1 AUTHOR
 165
 166 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 167
 168 You can contact me by mail or on C<irc.perl.org> (vincent).
 169
 170 =head1 BUGS
 171
 172 Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
 173 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 174
 175 =head1 SUPPORT
 176
 177 You can find documentation for this module with the perldoc command.
 178
 179     perldoc Test::Valgrind::Parser::XML::Twig
 180
 181 =head1 COPYRIGHT & LICENSE
 182
 183 Copyright 2009 Vincent Pit, all rights reserved.
 184
 185 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 186
 187 =cut
 188
 189 # End of Test::Valgrind::Parser::XML::Twig
 190
 191 package Test::Valgrind::Parser::XML::Twig::Elt;
 192
 193 our $VERSION = '1.10';
 194
 195 BEGIN { require XML::Twig; }
 196
 197 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
 198
 199 sub kid {
 200  my ($self, $what) = @_;
 201  my $node = $self->first_child($what);
 202  $self->_croak("Couldn't get first $what child node") unless $node;
 203  return $node;
 204 }
 205
 206 sub listify_frame {
 207  my ($frame) = @_;
 208
 209  return unless $frame->tag eq 'frame';
 210
 211  return [
 212   map {
 213    my $x = $frame->first_child($_);
 214    $x ? $x->text : undef
 215   } qw/ip obj fn dir file line/
 216  ];
 217 }
 218
 219 1; # End of Test::Valgrind::Parser::XML::Twig::Elt