]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - lib/Test/Valgrind/Parser/XML/Twig.pm
3d28b90be68db94a8f470c1398fda329fed47a2b
[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind / Parser / XML / Twig.pm
1 package Test::Valgrind::Parser::XML::Twig;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig.
9
10 =head1 VERSION
11
12 Version 1.16
13
14 =cut
15
16 our $VERSION = '1.16';
17
18 =head1 DESCRIPTION
19
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.
22
23 =cut
24
25 use Scalar::Util ();
26
27 use base qw<Test::Valgrind::Parser::XML Test::Valgrind::Carp XML::Twig>;
28
29 BEGIN { XML::Twig->add_options('Stash'); }
30
31 my %handlers = (
32  '/valgrindoutput/protocolversion' => \&handle_version,
33  '/valgrindoutput/error'           => \&handle_error,
34 );
35
36 =head1 METHODS
37
38 =cut
39
40 sub new {
41  my $class = shift;
42  $class = ref($class) || $class;
43
44  my %args = @_;
45  my $stash = delete $args{stash} || { };
46
47  bless $class->XML::Twig::new(
48   elt_class     => __PACKAGE__ . '::Elt',
49   stash         => $stash,
50   twig_roots    => { map { $_ => 1             } keys %handlers },
51   twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
52  ), $class;
53 }
54
55 sub stash { shift->{Stash} }
56
57 =head2 C<protocol_version>
58
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>.
61
62 =cut
63
64 eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"
65                                               for qw<_session protocol_version>;
66
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.
69
70 sub start {
71  my ($self, $sess) = @_;
72
73  $self->SUPER::start($sess);
74  $self->_session($sess);
75
76  return;
77 }
78
79 sub parse {
80  my ($self, $sess, $fh) = @_;
81
82  $self->protocol_version(undef);
83
84  $self->XML::Twig::parse($fh);
85  $self->purge;
86
87  $self->protocol_version(undef);
88
89  return 0;
90 }
91
92 sub finish {
93  my ($self, $sess) = @_;
94
95  $self->_session(undef);
96  $self->SUPER::finish($sess);
97
98  return;
99 }
100
101 sub handle_version {
102  my ($twig, $node) = @_;
103
104  $twig->protocol_version($node->text);
105
106  $twig->purge;
107 }
108
109 sub handle_error {
110  my ($twig, $node) = @_;
111
112  my $id   = $node->kid('unique')->text;
113  my $kind = $node->kid('kind')->text;
114
115  my $data;
116
117  my ($what, $xwhat);
118  if ($twig->protocol_version >= 4) {
119   $xwhat = $node->first_child('xwhat');
120   $what  = $xwhat->kid('text')->text if defined $xwhat;
121  }
122  $what = $node->kid('what')->text unless defined $what;
123  $data->{what} = $what;
124
125  $data->{stack} = [ map $_->listify_frame,
126                                        $node->kid('stack')->children('frame') ];
127
128  for (qw<leakedbytes leakedblocks>) {
129   my $kid = ($xwhat || $node)->first_child($_);
130   next unless $kid;
131   $data->{$_} = int $kid->text;
132  }
133
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') ];
137   }
138   $data->{auxwhat} = $auxwhat->text;
139  }
140
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') ];
145  }
146
147  my $sess = $twig->_session;
148
149  $sess->report($sess->report_class($sess)->new(
150   kind => $kind,
151   id   => $id,
152   data => $data,
153  ));
154
155  $twig->purge;
156 }
157
158 =head1 SEE ALSO
159
160 L<Test::Valgrind>, L<Test::Valgrind::Parser>, L<Test::Valgrind::Parser::XML>.
161
162 L<XML::Twig>.
163
164 =head1 AUTHOR
165
166 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
167
168 You can contact me by mail or on C<irc.perl.org> (vincent).
169
170 =head1 BUGS
171
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.
174
175 =head1 SUPPORT
176
177 You can find documentation for this module with the perldoc command.
178
179     perldoc Test::Valgrind::Parser::XML::Twig
180
181 =head1 COPYRIGHT & LICENSE
182
183 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
184
185 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
186
187 =cut
188
189 # End of Test::Valgrind::Parser::XML::Twig
190
191 package Test::Valgrind::Parser::XML::Twig::Elt;
192
193 our $VERSION = '1.16';
194
195 BEGIN { require XML::Twig; }
196
197 use base qw<XML::Twig::Elt Test::Valgrind::Carp>;
198
199 sub kid {
200  my ($self, $what) = @_;
201  my $node = $self->first_child($what);
202  $self->_croak("Couldn't get first $what child node") unless $node;
203  return $node;
204 }
205
206 sub listify_frame {
207  my ($frame) = @_;
208
209  return unless $frame->tag eq 'frame';
210
211  return [
212   map {
213    my $x = $frame->first_child($_);
214    $x ? $x->text : undef
215   } qw<ip obj fn dir file line>
216  ];
217 }
218
219 1; # End of Test::Valgrind::Parser::XML::Twig::Elt