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

[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind / Tool / memcheck.pm

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