1 package Test::Valgrind::Parser::XML::Twig;
8 Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig.
16 our $VERSION = '1.16';
20 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.
21 It is able to parse the XML output from C<valgrind> up to protocol version 4 and to generate the appropriate reports accordingly.
27 use base qw<Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig>;
29 BEGIN { XML::Twig->add_options('Stash'); }
32 '/valgrindoutput/protocolversion' => \&handle_version,
33 '/valgrindoutput/error' => \&handle_error,
42 $class = ref($class) || $class;
45 my $stash = delete $args{stash} || { };
47 bless $class->XML::Twig::new(
48 elt_class => __PACKAGE__ . '::Elt',
50 twig_roots => { map { $_ => 1 } keys %handlers },
51 twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
55 sub stash { shift->{Stash} }
57 =head2 C<protocol_version>
59 The version of the protocol that the current stream is conforming to.
60 It is reset before and after the parsing phase, so it's effectively only available from inside C<parse>.
64 eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
65 for qw<_session protocol_version>;
67 # We must store the session in ourselves because it's only possible to pass
68 # arguments to XML::Twig objects by a global stash.
71 my ($self, $sess) = @_;
73 $self->SUPER::start($sess);
74 $self->_session($sess);
80 my ($self, $sess, $fh) = @_;
82 $self->protocol_version(undef);
84 $self->XML::Twig::parse($fh);
87 $self->protocol_version(undef);
93 my ($self, $sess) = @_;
95 $self->_session(undef);
96 $self->SUPER::finish($sess);
102 my ($twig, $node) = @_;
104 $twig->protocol_version($node->text);
110 my ($twig, $node) = @_;
112 my $id = $node->kid('unique')->text;
113 my $kind = $node->kid('kind')->text;
118 if ($twig->protocol_version >= 4) {
119 $xwhat = $node->first_child('xwhat');
120 $what = $xwhat->kid('text')->text if defined $xwhat;
122 $what = $node->kid('what')->text unless defined $what;
123 $data->{what} = $what;
125 $data->{stack} = [ map $_->listify_frame,
126 $node->kid('stack')->children('frame') ];
128 for (qw<leakedbytes leakedblocks>) {
129 my $kid = ($xwhat || $node)->first_child($_);
131 $data->{$_} = int $kid->text;
134 if (my $auxwhat = $node->first_child('auxwhat')) {
135 if (my $stack = $auxwhat->next_sibling('stack')) {
136 $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
138 $data->{auxwhat} = $auxwhat->text;
141 if (my $origin = $node->first_child('origin')) {
142 $data->{origwhat} = $origin->kid('what')->text;
143 $data->{origstack} = [ map $_->listify_frame,
144 $origin->kid('stack')->children('frame') ];
147 my $sess = $twig->_session;
149 $sess->report($sess->report_class($sess)->new(
160 L<Test::Valgrind>, L<Test::Valgrind::Parser>, L<Test::Valgrind::Parser::XML>.
166 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
168 You can contact me by mail or on C<irc.perl.org> (vincent).
172 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>.
173 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
177 You can find documentation for this module with the perldoc command.
179 perldoc Test::Valgrind::Parser::XML::Twig
181 =head1 COPYRIGHT & LICENSE
183 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
185 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
189 # End of Test::Valgrind::Parser::XML::Twig
191 package Test::Valgrind::Parser::XML::Twig::Elt;
193 our $VERSION = '1.16';
195 BEGIN { require XML::Twig; }
197 use base qw<XML::Twig::Elt Test::Valgrind::Carp>;
200 my ($self, $what) = @_;
201 my $node = $self->first_child($what);
202 $self->_croak("Couldn't get first $what child node") unless $node;
209 return unless $frame->tag eq 'frame';
213 my $x = $frame->first_child($_);
214 $x ? $x->text : undef
215 } qw<ip obj fn dir file line>
219 1; # End of Test::Valgrind::Parser::XML::Twig::Elt