X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FParser%2FXML%2FTwig.pm;h=119553a9f183e5fbf346c5ba070f19e996a3f649;hb=cc42998614d386a86ed90c9c9dd3ce9df68140f5;hp=a949e81b4856ff9b51513f845c5f4bc9f624e4be;hpb=76e13d7ca56782de6f9fb8d6597856ad91c15ffb;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind/Parser/XML/Twig.pm b/lib/Test/Valgrind/Parser/XML/Twig.pm
index a949e81..119553a 100644
--- a/lib/Test/Valgrind/Parser/XML/Twig.pm
+++ b/lib/Test/Valgrind/Parser/XML/Twig.pm
@@ -3,18 +3,40 @@ package Test::Valgrind::Parser::XML::Twig;
 use strict;
 use warnings;
 
-our $VERSION = '1.02';
+=head1 NAME
+
+Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig.
+
+=head1 VERSION
+
+Version 1.14
+
+=cut
+
+our $VERSION = '1.14';
+
+=head1 DESCRIPTION
+
+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.
+It is able to parse the XML output from C<valgrind> up to protocol version 4 and to generate the appropriate reports accordingly.
+
+=cut
 
 use Scalar::Util ();
 
-use base qw/XML::Twig Test::Valgrind::Carp/;
+use base qw<Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig>;
 
 BEGIN { XML::Twig->add_options('Stash'); }
 
 my %handlers = (
- '/valgrindoutput/error' => \&handle_error,
+ '/valgrindoutput/protocolversion' => \&handle_version,
+ '/valgrindoutput/error'           => \&handle_error,
 );
 
+=head1 METHODS
+
+=cut
+
 sub new {
  my $class = shift;
  $class = ref($class) || $class;
@@ -22,11 +44,6 @@ sub new {
  my %args = @_;
  my $stash = delete $args{stash} || { };
 
- my $tool = delete $args{tool};
- $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool)
-                                         and $tool->isa('Test::Valgrind::Tool');
- $stash->{tool} = $tool;
-
  bless $class->XML::Twig::new(
   elt_class     => __PACKAGE__ . '::Elt',
   stash         => $stash,
@@ -37,6 +54,58 @@ sub new {
 
 sub stash { shift->{Stash} }
 
+=head2 C<protocol_version>
+
+The version of the protocol that the current stream is conforming to.
+It is reset before and after the parsing phase, so it's effectively only available from inside C<parse>.
+
+=cut
+
+eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
+                                              for qw<_session protocol_version>;
+
+# We must store the session in ourselves because it's only possible to pass
+# arguments to XML::Twig objects by a global stash.
+
+sub start {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::start($sess);
+ $self->_session($sess);
+
+ return;
+}
+
+sub parse {
+ my ($self, $sess, $fh) = @_;
+
+ $self->protocol_version(undef);
+
+ $self->XML::Twig::parse($fh);
+ $self->purge;
+
+ $self->protocol_version(undef);
+
+ return;
+}
+
+sub finish {
+ my ($self, $sess) = @_;
+
+ $self->_session(undef);
+ $self->SUPER::finish($sess);
+
+ return;
+}
+
+sub handle_version {
+ my ($twig, $node) = @_;
+
+ $twig->protocol_version($node->text);
+
+ $twig->purge;
+}
+
 sub handle_error {
  my ($twig, $node) = @_;
 
@@ -45,12 +114,19 @@ sub handle_error {
 
  my $data;
 
- $data->{what}  = $node->kid('what')->text;
+ my ($what, $xwhat);
+ if ($twig->protocol_version >= 4) {
+  $xwhat = $node->first_child('xwhat');
+  $what  = $xwhat->kid('text')->text if defined $xwhat;
+ }
+ $what = $node->kid('what')->text unless defined $what;
+ $data->{what} = $what;
+
  $data->{stack} = [ map $_->listify_frame,
                                        $node->kid('stack')->children('frame') ];
 
- for (qw/leakedbytes leakedblocks/) {
-  my $kid = $node->first_child($_);
+ for (qw<leakedbytes leakedblocks>) {
+  my $kid = ($xwhat || $node)->first_child($_);
   next unless $kid;
   $data->{$_} = int $kid->text;
  }
@@ -68,10 +144,9 @@ sub handle_error {
                                      $origin->kid('stack')->children('frame') ];
  }
 
- my $tool = $twig->stash->{tool};
- my $sess = $tool->_session;
+ my $sess = $twig->_session;
 
- $sess->report($tool->report_class($sess)->new(
+ $sess->report($sess->report_class($sess)->new(
   kind => $kind,
   id   => $id,
   data => $data,
@@ -80,15 +155,46 @@ sub handle_error {
  $twig->purge;
 }
 
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Parser>, L<Test::Valgrind::Parser::XML>.
+
+L<XML::Twig>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+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>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc Test::Valgrind::Parser::XML::Twig
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009,2010,2011,2013 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
 # End of Test::Valgrind::Parser::XML::Twig
 
 package Test::Valgrind::Parser::XML::Twig::Elt;
 
-our $VERSION = '1.02';
+our $VERSION = '1.14';
 
 BEGIN { require XML::Twig; }
 
-use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
+use base qw<XML::Twig::Elt Test::Valgrind::Carp>;
 
 sub kid {
  my ($self, $what) = @_;
@@ -106,7 +212,7 @@ sub listify_frame {
   map {
    my $x = $frame->first_child($_);
    $x ? $x->text : undef
-  } qw/ip obj fn dir file line/
+  } qw<ip obj fn dir file line>
  ];
 }