1 package Test::Valgrind::Parser::XML::Twig;
8 Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig.
16 our $VERSION = '1.10';
20 use base qw/Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig/;
22 BEGIN { XML::Twig->add_options('Stash'); }
25 '/valgrindoutput/protocolversion' => \&handle_version,
26 '/valgrindoutput/error' => \&handle_error,
35 $class = ref($class) || $class;
38 my $stash = delete $args{stash} || { };
40 bless $class->XML::Twig::new(
41 elt_class => __PACKAGE__ . '::Elt',
43 twig_roots => { map { $_ => 1 } keys %handlers },
44 twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
48 sub stash { shift->{Stash} }
50 =head2 C<protocol_version>
52 The version of the protocol that the stream is currently conforming to.
53 It is reset before and after the parsing phase, so it's effectively only available from inside L</parse>.
57 eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
58 for qw/_session protocol_version/;
60 # We must store the session in ourselves because it's only possible to pass
61 # arguments to XML::Twig objects by a global stash.
64 my ($self, $sess) = @_;
66 $self->SUPER::start($sess);
67 $self->_session($sess);
73 my ($self, $sess, $fh) = @_;
75 $self->protocol_version(undef);
77 $self->XML::Twig::parse($fh);
80 $self->protocol_version(undef);
86 my ($self, $sess) = @_;
88 $self->_session(undef);
89 $self->SUPER::finish($sess);
95 my ($twig, $node) = @_;
97 $twig->protocol_version($node->text);
103 my ($twig, $node) = @_;
105 my $id = $node->kid('unique')->text;
106 my $kind = $node->kid('kind')->text;
111 if ($twig->protocol_version >= 4) {
112 $xwhat = $node->first_child('xwhat');
113 $what = $xwhat->kid('text')->text if defined $xwhat;
115 $what = $node->kid('what')->text unless defined $what;
116 $data->{what} = $what;
118 $data->{stack} = [ map $_->listify_frame,
119 $node->kid('stack')->children('frame') ];
121 for (qw/leakedbytes leakedblocks/) {
122 my $kid = ($xwhat || $node)->first_child($_);
124 $data->{$_} = int $kid->text;
127 if (my $auxwhat = $node->first_child('auxwhat')) {
128 if (my $stack = $auxwhat->next_sibling('stack')) {
129 $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
131 $data->{auxwhat} = $auxwhat->text;
134 if (my $origin = $node->first_child('origin')) {
135 $data->{origwhat} = $origin->kid('what')->text;
136 $data->{origstack} = [ map $_->listify_frame,
137 $origin->kid('stack')->children('frame') ];
140 my $sess = $twig->_session;
142 $sess->report($sess->report_class($sess)->new(
153 L<Test::Valgrind>, L<Test::Valgrind::Parser>, L<Test::Valgrind::Parser::XML>.
159 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
161 You can contact me by mail or on C<irc.perl.org> (vincent).
165 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>.
166 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
170 You can find documentation for this module with the perldoc command.
172 perldoc Test::Valgrind::Parser::XML::Twig
174 =head1 COPYRIGHT & LICENSE
176 Copyright 2009 Vincent Pit, all rights reserved.
178 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
182 # End of Test::Valgrind::Parser::XML::Twig
184 package Test::Valgrind::Parser::XML::Twig::Elt;
186 our $VERSION = '1.10';
188 BEGIN { require XML::Twig; }
190 use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
193 my ($self, $what) = @_;
194 my $node = $self->first_child($what);
195 $self->_croak("Couldn't get first $what child node") unless $node;
202 return unless $frame->tag eq 'frame';
206 my $x = $frame->first_child($_);
207 $x ? $x->text : undef
208 } qw/ip obj fn dir file line/
212 1; # End of Test::Valgrind::Parser::XML::Twig::Elt