Move the XML::Twig part of Tool::memcheck to a new Parser::XML::Twig

diff --git a/MANIFEST b/MANIFEST
index 56d133ba1b6ac07eb1b806d5c0293f47dd6059a6..7e8fd165b3df06960bddc25ff7abfbd047ee7b95 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -15,6 +15,7 @@ lib/Test/Valgrind/Command/Aggregate.pm
 lib/Test/Valgrind/Command/Perl.pm
 lib/Test/Valgrind/Command/PerlScript.pm
 lib/Test/Valgrind/Parser/Suppressions/Text.pm
+lib/Test/Valgrind/Parser/XML/Twig.pm
 lib/Test/Valgrind/Report.pm
 lib/Test/Valgrind/Session.pm
 lib/Test/Valgrind/Suppressions.pm

diff --git a/lib/Test/Valgrind/Parser/XML/Twig.pm b/lib/Test/Valgrind/Parser/XML/Twig.pm
new file mode 100644 (file)
index 0000000..a949e81
--- /dev/null
+++ b/lib/Test/Valgrind/Parser/XML/Twig.pm
@@ -0,0 +1,113 @@
+package Test::Valgrind::Parser::XML::Twig;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.02';
+
+use Scalar::Util ();
+
+use base qw/XML::Twig Test::Valgrind::Carp/;
+
+BEGIN { XML::Twig->add_options('Stash'); }
+
+my %handlers = (
+ '/valgrindoutput/error' => \&handle_error,
+);
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ 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,
+  twig_roots    => { map { $_ => 1             } keys %handlers },
+  twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
+ ), $class;
+}
+
+sub stash { shift->{Stash} }
+
+sub handle_error {
+ my ($twig, $node) = @_;
+
+ my $id   = $node->kid('unique')->text;
+ my $kind = $node->kid('kind')->text;
+
+ my $data;
+
+ $data->{what}  = $node->kid('what')->text;
+ $data->{stack} = [ map $_->listify_frame,
+                                       $node->kid('stack')->children('frame') ];
+
+ for (qw/leakedbytes leakedblocks/) {
+  my $kid = $node->first_child($_);
+  next unless $kid;
+  $data->{$_} = int $kid->text;
+ }
+
+ if (my $auxwhat = $node->first_child('auxwhat')) {
+  if (my $stack = $auxwhat->next_sibling('stack')) {
+   $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
+  }
+  $data->{auxwhat} = $auxwhat->text;
+ }
+
+ if (my $origin = $node->first_child('origin')) {
+  $data->{origwhat}  = $origin->kid('what')->text;
+  $data->{origstack} = [ map $_->listify_frame,
+                                     $origin->kid('stack')->children('frame') ];
+ }
+
+ my $tool = $twig->stash->{tool};
+ my $sess = $tool->_session;
+
+ $sess->report($tool->report_class($sess)->new(
+  kind => $kind,
+  id   => $id,
+  data => $data,
+ ));
+
+ $twig->purge;
+}
+
+# End of Test::Valgrind::Parser::XML::Twig
+
+package Test::Valgrind::Parser::XML::Twig::Elt;
+
+our $VERSION = '1.02';
+
+BEGIN { require XML::Twig; }
+
+use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
+
+sub kid {
+ my ($self, $what) = @_;
+ my $node = $self->first_child($what);
+ $self->_croak("Couldn't get first $what child node") unless $node;
+ return $node;
+}
+
+sub listify_frame {
+ my ($frame) = @_;
+
+ return unless $frame->tag eq 'frame';
+
+ return [
+  map {
+   my $x = $frame->first_child($_);
+   $x ? $x->text : undef
+  } qw/ip obj fn dir file line/
+ ];
+}
+
+1; # End of Test::Valgrind::Parser::XML::Twig::Elt

diff --git a/lib/Test/Valgrind/Tool/memcheck.pm b/lib/Test/Valgrind/Tool/memcheck.pm
index 05f77bdf7be145aefefb42f6bae56e1b3ec7f52d..87852cf5bed7757d23e8661cad90288f10462bc1 100644 (file)
--- a/lib/Test/Valgrind/Tool/memcheck.pm
+++ b/lib/Test/Valgrind/Tool/memcheck.pm
@@ -254,113 +254,3 @@ sub dump {
 
 # End of Test::Valgrind::Tool::memcheck::Report
 
-package Test::Valgrind::Tool::memcheck::Twig;
-
-our $VERSION = '1.02';
-
-use Scalar::Util;
-
-use base qw/XML::Twig Test::Valgrind::Carp/;
-
-BEGIN { XML::Twig->add_options('Stash'); }
-
-my %handlers = (
- '/valgrindoutput/error' => \&handle_error,
-);
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- 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,
-  twig_roots    => { map { $_ => 1             } keys %handlers },
-  twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
- ), $class;
-}
-
-sub stash { shift->{Stash} }
-
-sub handle_error {
- my ($twig, $node) = @_;
-
- my $id   = $node->kid('unique')->text;
- my $kind = $node->kid('kind')->text;
-
- my $data;
-
- $data->{what}  = $node->kid('what')->text;
- $data->{stack} = [ map $_->listify_frame,
-                                       $node->kid('stack')->children('frame') ];
-
- for (qw/leakedbytes leakedblocks/) {
-  my $kid = $node->first_child($_);
-  next unless $kid;
-  $data->{$_} = int $kid->text;
- }
-
- if (my $auxwhat = $node->first_child('auxwhat')) {
-  if (my $stack = $auxwhat->next_sibling('stack')) {
-   $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
-  }
-  $data->{auxwhat} = $auxwhat->text;
- }
-
- if (my $origin = $node->first_child('origin')) {
-  $data->{origwhat}  = $origin->kid('what')->text;
-  $data->{origstack} = [ map $_->listify_frame,
-                                     $origin->kid('stack')->children('frame') ];
- }
-
- my $tool = $twig->stash->{tool};
- my $sess = $tool->_session;
-
- $sess->report($tool->report_class($sess)->new(
-  kind => $kind,
-  id   => $id,
-  data => $data,
- ));
-
- $twig->purge;
-}
-
-# End of Test::Valgrind::Tool::memcheck::Twig
-
-package Test::Valgrind::Tool::memcheck::Twig::Elt;
-
-our $VERSION = '1.02';
-
-BEGIN { require XML::Twig; }
-
-use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
-
-sub kid {
- my ($self, $what) = @_;
- my $node = $self->first_child($what);
- $self->_croak("Couldn't get first $what child node") unless $node;
- return $node;
-}
-
-sub listify_frame {
- my ($frame) = @_;
-
- return unless $frame->tag eq 'frame';
-
- return [
-  map {
-   my $x = $frame->first_child($_);
-   $x ? $x->text : undef
-  } qw/ip obj fn dir file line/
- ];
-}
-
-1; # End of Test::Valgrind::Tool::memcheck::Twig::Elt