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