File Coverage

blib/lib/Test/Valgrind/Suppressions.pm
Criterion Covered Total %
statement 21 54 38.8
branch 11 28 39.2
condition 0 3 0.0
subroutine 4 6 66.6
pod 3 3 100.0
total 39 94 41.4


line stmt bran cond sub pod time code
1             package Test::Valgrind::Suppressions;
2              
3 6     6   42570 use strict;
  6         13  
  6         157  
4 6     6   30 use warnings;
  6         12  
  6         370  
5              
6             =head1 NAME
7              
8             Test::Valgrind::Suppressions - Generate suppressions for given tool and command.
9              
10             =head1 VERSION
11              
12             Version 1.17
13              
14             =cut
15              
16             our $VERSION = '1.17';
17              
18             =head1 DESCRIPTION
19              
20             This module is an helper for generating suppressions.
21              
22             =cut
23              
24 6     6   29 use base qw;
  6         16  
  6         4227  
25              
26             =head1 METHODS
27              
28             =head2 C
29              
30             Test::Valgrind::Suppressions->generate(
31             tool => $tool,
32             command => $command,
33             target => $target,
34             );
35              
36             Generates suppressions for the command C<< $command->new_trainer >> and the tool C<< $tool->new_trainer >>, and writes them in the file specified by C<$target>.
37             The action used behind the scenes is L.
38              
39             Returns the status code.
40              
41             =cut
42              
43             sub generate {
44 0     0 1 0 my $self = shift;
45              
46 0         0 my %args = @_;
47              
48 0         0 my $cmd = delete $args{command};
49 0 0       0 unless (ref $cmd) {
50 0         0 require Test::Valgrind::Command;
51 0         0 $cmd = Test::Valgrind::Command->new(
52             command => $cmd,
53             args => [ ],
54             );
55             }
56 0         0 $cmd = $cmd->new_trainer;
57 0 0       0 return unless defined $cmd;
58              
59 0         0 my $tool = delete $args{tool};
60 0 0       0 unless (ref $tool) {
61 0         0 require Test::Valgrind::Tool;
62 0         0 $tool = Test::Valgrind::Tool->new(tool => $tool);
63             }
64 0         0 $tool = $tool->new_trainer;
65 0 0       0 return unless defined $tool;
66              
67 0         0 my $target = delete $args{target};
68 0 0 0     0 $self->_croak('Invalid target') unless $target and not ref $target;
69              
70 0         0 require Test::Valgrind::Action;
71 0         0 my $action = Test::Valgrind::Action->new(
72             action => 'Suppressions',
73             target => $target,
74             name => 'PerlSuppression',
75             );
76              
77 0         0 require Test::Valgrind::Session;
78 0         0 my $sess = Test::Valgrind::Session->new(
79             min_version => $tool->requires_version,
80             );
81              
82 0         0 eval {
83 0         0 $sess->run(
84             command => $cmd,
85             tool => $tool,
86             action => $action,
87             );
88             };
89 0 0       0 $self->_croak($@) if $@;
90              
91 0         0 my $status = $sess->status;
92 0 0       0 $status = 255 unless defined $status;
93              
94 0         0 return $status;
95             }
96              
97             =head2 C
98              
99             my $mangled_suppression = Test::Valgrind::Suppressions->maybe_generalize(
100             $session,
101             $suppression,
102             );
103              
104             Removes all wildcard frames at the end of the suppression.
105             It also replaces sequences of wildcard frames by C<'...'> when C C<3.4.0> or higher is used.
106             Returns the mangled suppression.
107              
108             =cut
109              
110             sub maybe_generalize {
111 0     0 1 0 shift;
112              
113 0         0 my ($sess, $supp) = @_;
114              
115 0         0 1 while $supp =~ s/[^\r\n]*:\s*\*\s*$//;
116              
117             # With valgrind 3.4.0, we can replace unknown series of frames by '...'
118 0 0       0 if ($sess->version ge '3.4.0') {
119 0         0 $supp .= "...\n";
120 0         0 $supp =~ s/(?:^\s*(?:\.{3}|\*:\S*|obj:\*)\s*\n)+/...\n/mg;
121             }
122              
123 0         0 $supp;
124             }
125              
126             =head2 C
127              
128             my $demangled_symbol = Test::Valgrind::Suppressions->maybe_z_demangle(
129             $symbol,
130             );
131              
132             If C<$symbol> is Z-encoded as described in C's F, extract and decode its function name part.
133             Otherwise, C<$symbol> is returned as is.
134              
135             This routine follows C's F.
136              
137             =cut
138              
139             my %z_escapes = (
140             a => '*',
141             c => ':',
142             d => '.',
143             h => '-',
144             p => '+',
145             s => ' ',
146             u => '_',
147             A => '@',
148             D => '$',
149             L => '(',
150             R => ')',
151             Z => 'Z',
152             );
153              
154             sub maybe_z_demangle {
155 7     7 1 6749 my ($self, $sym) = @_;
156              
157 7 100       46 $sym =~ s/^_vg[rwn]Z([ZU])_// or return $sym;
158              
159 6         17 my $fn_is_encoded = $1 eq 'Z';
160              
161 6 100       30 $sym =~ /^VG_Z_/ and $self->_croak('Symbol with a "VG_Z_" prefix is invalid');
162 5 100       29 $sym =~ s/^[^_]*_//
163             or $self->_croak('Symbol doesn\'t contain a function name');
164              
165 4 100       13 if ($fn_is_encoded) {
166 2         10 $sym =~ s/Z(.)/
167 4         11 my $c = $z_escapes{$1};
168 4 100       13 $self->_croak('Invalid escape sequence') unless defined $c;
169 3         10 $c;
170             /ge;
171             }
172              
173 3 50       11 $self->_croak('Empty symbol') unless length $sym;
174              
175 3         12 return $sym;
176             }
177              
178             =head1 SEE ALSO
179              
180             L, L, L, L.
181              
182             =head1 AUTHOR
183              
184             Vincent Pit, C<< >>, L.
185              
186             You can contact me by mail or on C (vincent).
187              
188             =head1 BUGS
189              
190             Please report any bugs or feature requests to C, or through the web interface at L.
191             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
192              
193             =head1 SUPPORT
194              
195             You can find documentation for this module with the perldoc command.
196              
197             perldoc Test::Valgrind::Suppressions
198              
199             =head1 COPYRIGHT & LICENSE
200              
201             Copyright 2008,2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
202              
203             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
204              
205             =cut
206              
207             1; # End of Test::Valgrind::Suppressions