1 package Test::Valgrind::Parser::XML::Twig;
10 use base qw/Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig/;
12 BEGIN { XML::Twig->add_options('Stash'); }
15 '/valgrindoutput/protocolversion' => \&handle_version,
16 '/valgrindoutput/error' => \&handle_error,
21 $class = ref($class) || $class;
24 my $stash = delete $args{stash} || { };
26 bless $class->XML::Twig::new(
27 elt_class => __PACKAGE__ . '::Elt',
29 twig_roots => { map { $_ => 1 } keys %handlers },
30 twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
34 sub stash { shift->{Stash} }
36 eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
37 for qw/_session protocol_version/;
39 # We must store the session in ourselves because it's only possible to pass
40 # arguments to XML::Twig objects by a global stash.
43 my ($self, $sess) = @_;
45 $self->SUPER::start($sess);
46 $self->_session($sess);
52 my ($self, $sess, $fh) = @_;
54 $self->XML::Twig::parse($fh);
61 my ($self, $sess) = @_;
63 $self->_session(undef);
64 $self->SUPER::finish($sess);
70 my ($twig, $node) = @_;
72 $twig->protocol_version($node->text);
78 my ($twig, $node) = @_;
80 my $id = $node->kid('unique')->text;
81 my $kind = $node->kid('kind')->text;
86 if ($twig->protocol_version >= 4) {
87 $xwhat = $node->first_child('xwhat');
88 $what = $xwhat->kid('text')->text if defined $xwhat;
90 $what = $node->kid('what')->text unless defined $what;
91 $data->{what} = $what;
93 $data->{stack} = [ map $_->listify_frame,
94 $node->kid('stack')->children('frame') ];
96 for (qw/leakedbytes leakedblocks/) {
97 my $kid = $node->first_child($_);
99 $data->{$_} = int $kid->text;
102 if (my $auxwhat = $node->first_child('auxwhat')) {
103 if (my $stack = $auxwhat->next_sibling('stack')) {
104 $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
106 $data->{auxwhat} = $auxwhat->text;
109 if (my $origin = $node->first_child('origin')) {
110 $data->{origwhat} = $origin->kid('what')->text;
111 $data->{origstack} = [ map $_->listify_frame,
112 $origin->kid('stack')->children('frame') ];
115 my $sess = $twig->_session;
117 $sess->report($sess->report_class($sess)->new(
126 # End of Test::Valgrind::Parser::XML::Twig
128 package Test::Valgrind::Parser::XML::Twig::Elt;
130 our $VERSION = '1.02';
132 BEGIN { require XML::Twig; }
134 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
137 my ($self, $what) = @_;
138 my $node = $self->first_child($what);
139 $self->_croak("Couldn't get first $what child node") unless $node;
146 return unless $frame->tag eq 'frame';
150 my $x = $frame->first_child($_);
151 $x ? $x->text : undef
152 } qw/ip obj fn dir file line/
156 1; # End of Test::Valgrind::Parser::XML::Twig::Elt