1 package Test::Valgrind::Parser::XML::Twig;
10 use base qw/XML::Twig Test::Valgrind::Carp/;
12 BEGIN { XML::Twig->add_options('Stash'); }
15 '/valgrindoutput/error' => \&handle_error,
20 $class = ref($class) || $class;
23 my $stash = delete $args{stash} || { };
25 bless $class->XML::Twig::new(
26 elt_class => __PACKAGE__ . '::Elt',
28 twig_roots => { map { $_ => 1 } keys %handlers },
29 twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
33 sub stash { shift->{Stash} }
35 # We must store the session in ourselves because it's only possible to pass
36 # arguments to XML::Twig objects by a global stash.
38 sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) }
41 my ($self, $sess) = @_;
43 $self->SUPER::start($sess);
44 $self->_session($sess);
50 my ($self, $sess, $fh) = @_;
52 $self->XML::Twig::parse($fh);
59 my ($self, $sess) = @_;
61 $self->_session(undef);
62 $self->SUPER::finish($sess);
68 my ($twig, $node) = @_;
70 my $id = $node->kid('unique')->text;
71 my $kind = $node->kid('kind')->text;
75 $data->{what} = $node->kid('what')->text;
76 $data->{stack} = [ map $_->listify_frame,
77 $node->kid('stack')->children('frame') ];
79 for (qw/leakedbytes leakedblocks/) {
80 my $kid = $node->first_child($_);
82 $data->{$_} = int $kid->text;
85 if (my $auxwhat = $node->first_child('auxwhat')) {
86 if (my $stack = $auxwhat->next_sibling('stack')) {
87 $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
89 $data->{auxwhat} = $auxwhat->text;
92 if (my $origin = $node->first_child('origin')) {
93 $data->{origwhat} = $origin->kid('what')->text;
94 $data->{origstack} = [ map $_->listify_frame,
95 $origin->kid('stack')->children('frame') ];
98 my $sess = $twig->_session;
100 $sess->report($sess->report_class($sess)->new(
109 # End of Test::Valgrind::Parser::XML::Twig
111 package Test::Valgrind::Parser::XML::Twig::Elt;
113 our $VERSION = '1.02';
115 BEGIN { require XML::Twig; }
117 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
120 my ($self, $what) = @_;
121 my $node = $self->first_child($what);
122 $self->_croak("Couldn't get first $what child node") unless $node;
129 return unless $frame->tag eq 'frame';
133 my $x = $frame->first_child($_);
134 $x ? $x->text : undef
135 } qw/ip obj fn dir file line/
139 1; # End of Test::Valgrind::Parser::XML::Twig::Elt