]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - SuppressionsParser.pm
471025ac62c60ea5e4c9676b047ce43a9ad9d139
[perl/modules/Test-Valgrind.git] / SuppressionsParser.pm
1 package Test::Valgrind::Tool::SuppressionsParser;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 Test::Valgrind::Tool::SuppressionsParser - Mock Test::Valgrind::Tool for parsing valgrind suppressions.
9
10 =head1 VERSION
11
12 Version 1.01
13
14 =cut
15
16 our $VERSION = '1.01';
17
18 =head1 DESCRIPTION
19
20 This class provides a default C<parse_suppressions> method, so that real tools for which suppressions are meaningful can exploit it by inheriting.
21
22 It's not meant to be used directly as a tool.
23
24 =cut
25
26 use base qw/Test::Valgrind::Carp/;
27
28 =head1 METHODS
29
30 =head2 C<new>
31
32 Just a croaking stub to remind you not to use this class as a real tool.
33
34 If your tool both inherit from this class and from C<Test::Valgrind::Tool>, and that you want to dispatch the call to your C<new> to its ancestors', be careful with C<SUPER> which may end up calling this dieing version of C<new>.
35 The solution is to either put C<Test::Valgrind::Tool> first in the C<@ISA> list or to explicitely call C<Test::Valgrind::Tool::new> instead of C<SUPER::new>.
36
37 =cut
38
39 sub new { shift->_croak('This mock tool isn\'t meant to be used directly') }
40
41 =head2 C<report_class_suppressions $session>
42
43 Generated reports are L<Test::Valgrind::Report::Suppressions> objects.
44 Their C<data> member contains the raw text of the suppression.
45
46 =cut
47
48 sub report_class_suppressions { 'Test::Valgrind::Report::Suppressions' }
49
50 =head2 C<parse_suppressions $session, $fh>
51
52 Parses the filehandle C<$fh> fed with the output of F<valgrind --gen-suppressions=all> and sends a report to the session C<$session> for each suppression.
53
54 =cut
55
56 sub parse_suppressions {
57  my ($self, $sess, $fh) = @_;
58
59  my ($s, $in) = ('', 0);
60  my @supps;
61
62  while (<$fh>) {
63   s/^\s*#\s//;
64   next if /^==/;
65   next if /valgrind/; # and /\Q$file\E/;
66   s/^\s*//;
67   s/<[^>]+>//;
68   s/\s*$//;
69   next unless length;
70   if ($_ eq '{') {
71    $in = 1;
72   } elsif ($_ eq '}') {
73    my $unknown_tail;
74    ++$unknown_tail while $s =~ s/(\n)\s*obj:\*\s*$/$1/;
75    $s .= "...\n" if $unknown_tail and $sess->version ge '3.4.0';
76    push @supps, $s;
77    $s  = '';
78    $in = 0;
79   } elsif ($in) {
80    $s .= "$_\n";
81   }
82  }
83
84  my @extra;
85  for (@supps) {
86   if (/\bfun:(m|c|re)alloc\b/) {
87    my $t = $1;
88    my %call;
89    if ($t eq 'm') { # malloc can also be called by calloc or realloc
90     $call{$_} = 1 for qw/calloc realloc/;
91    } elsif ($t eq 're') { # realloc can also call malloc or free
92     $call{$_} = 0 for qw/malloc free/;
93    } elsif ($t eq 'c') { # calloc can also call malloc
94     $call{$_} = 0 for qw/malloc/;
95    }
96    my $c = $_;
97    for (keys %call) {
98     my $d = $c;
99     $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
100     # Remove one line for each line added or valgrind will hate us
101     $d =~ s/\n(.+?)\s*$/\n/;
102     push @extra, $d;
103    }
104   }
105  }
106
107  my %dupes;
108  @dupes{@supps, @extra} = ();
109  @supps = keys %dupes;
110
111  my $num;
112  $sess->report($self->report_class($sess)->new(
113   id   => ++$num,
114   kind => 'Suppression',
115   data => $_,
116  )) for @supps;
117 }
118
119 =head1 SEE ALSO
120
121 L<Test::Valgrind>, L<Test::Valgrind::Tool>.
122
123 =head1 AUTHOR
124
125 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
126
127 You can contact me by mail or on C<irc.perl.org> (vincent).
128
129 =head1 BUGS
130
131 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>.
132 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
133
134 =head1 SUPPORT
135
136 You can find documentation for this module with the perldoc command.
137
138     perldoc Test::Valgrind::Tool::SuppressionsParser
139
140 =head1 COPYRIGHT & LICENSE
141
142 Copyright 2009 Vincent Pit, all rights reserved.
143
144 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
145
146 =cut
147
148 # End of Test::Valgrind::Tool::SuppressionsParser
149
150 package Test::Valgrind::Report::Suppressions;
151
152 use base qw/Test::Valgrind::Report/;
153
154 sub kinds { shift->SUPER::kinds(), 'Suppression' }
155
156 sub valid_kind {
157  my ($self, $kind) = @_;
158
159  $self->SUPER::valid_kind($kind) or $kind eq 'Suppression'
160 }
161
162 1; # End of Test::Valgrind::Report::Suppressions