]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - lib/Test/Valgrind/Parser/Suppressions/Text.pm
Add a prototype for tv_leak()
[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind / Parser / Suppressions / Text.pm
1 package Test::Valgrind::Parser::Suppressions::Text;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 Test::Valgrind::Parser::Suppressions::Text - Parse valgrind suppressions output as text blocks.
9
10 =head1 VERSION
11
12 Version 1.14
13
14 =cut
15
16 our $VERSION = '1.14';
17
18 =head1 DESCRIPTION
19
20 This is a L<Test::Valgrind::Parser::Text> object that can extract suppressions from C<valgrind>'s text output.
21
22 =cut
23
24 use Test::Valgrind::Suppressions;
25
26 use base qw<Test::Valgrind::Parser::Text Test::Valgrind::Carp>;
27
28 =head1 METHODS
29
30 =head2 C<report_class>
31
32 Generated reports are C<Test::Valgrind::Report::Suppressions> objects.
33 Their C<data> member contains the raw text of the suppression.
34
35 =cut
36
37 sub report_class { 'Test::Valgrind::Report::Suppressions' }
38
39 sub parse {
40  my ($self, $sess, $fh) = @_;
41
42  my ($s, $in) = ('', 0);
43  my @supps;
44
45  while (<$fh>) {
46   s/^\s*#\s//;        # Strip comments
47
48   next if /^==/;      # Valgrind info line
49
50   s/^\s*//;           # Strip leading spaces
51   s/<[^>]+>//;        # Strip tags
52   s/\s*$//;           # Strip trailing spaces
53   next unless length;
54
55   if ($_ eq '{') {      # A suppression block begins
56    $in = 1;
57   } elsif ($_ eq '}') { # A suppression block ends
58    $s = Test::Valgrind::Suppressions->strip_tail($sess, $s); # Strip the tail
59    push @supps, $s;     # Add the suppression that just ended to the list
60    $s  = '';            # Reset the state
61    $in = 0;
62   } elsif ($in) {       # We're inside a suppresion block
63    if (/^fun\s*:\s*(.*)/) {
64     # Sometimes valgrind seems to forget to Z-demangle the symbol names.
65     # Make sure it's done and append the result to the state.
66     my $sym = $1;
67     $s .= 'fun:' . Test::Valgrind::Suppressions->maybe_z_demangle($sym) . "\n";
68    } else {
69     $s .= "$_\n";
70    }
71   }
72  }
73
74  my @extra;
75
76  for (@supps) {
77   if (/\bfun:(m|c|re)alloc\b/) {
78    my $t = $1;
79
80    my %call; # Frames to append (if the value is 1) or to prepend (if it's 0)
81    if ($t eq 'm') {       # malloc can also be called by calloc or realloc
82     $call{$_} = 1 for qw<calloc realloc>;
83    } elsif ($t eq 're') { # realloc can also call malloc or free
84     $call{$_} = 0 for qw<malloc free>;
85    } elsif ($t eq 'c') {  # calloc can also call malloc
86     $call{$_} = 0 for qw<malloc>;
87    }
88
89    my $c = $_;
90    for (keys %call) {
91     my $d = $c;
92     $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
93     # Remove one line for each line added or valgrind will hate us
94     $d =~ s/\n(.+?)\s*$/\n/;
95     push @extra, $d;
96    }
97   }
98  }
99
100  my $num;
101  $sess->report($self->report_class($sess)->new(
102   id   => ++$num,
103   kind => 'Suppression',
104   data => $_,
105  )) for @supps, @extra;
106 }
107
108 =head1 SEE ALSO
109
110 L<Test::Valgrind>, L<Test::Valgrind::Parser::Text>.
111
112 =head1 AUTHOR
113
114 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
115
116 You can contact me by mail or on C<irc.perl.org> (vincent).
117
118 =head1 BUGS
119
120 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>.
121 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
122
123 =head1 SUPPORT
124
125 You can find documentation for this module with the perldoc command.
126
127     perldoc Test::Valgrind::Parser::Suppressions::Text
128
129 =head1 COPYRIGHT & LICENSE
130
131 Copyright 2009,2010,2011,2013 Vincent Pit, all rights reserved.
132
133 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
134
135 =cut
136
137 # End of Test::Valgrind::Parser::Suppressions::Text
138
139 package Test::Valgrind::Report::Suppressions;
140
141 use base qw<Test::Valgrind::Report>;
142
143 sub kinds { shift->SUPER::kinds(), 'Suppression' }
144
145 sub valid_kind {
146  my ($self, $kind) = @_;
147
148  $self->SUPER::valid_kind($kind) or $kind eq 'Suppression'
149 }
150
151 1; # End of Test::Valgrind::Report::Suppressions