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