ReleaseScripts/scripts/valgrindMemcheckParser.pl

0001 #!/usr/bin/env perl
0002 # Created: June 2007
0003 # Author: Giovanni Petrucciani, INFN Pisa
0004 #
0005 use strict;
0006 use warnings;
0007 use Data::Dumper;
0008 use Date::Format;
0009 use Getopt::Long;
0010
0011 my $mstart = qr/^==\d+== (\S.*? bytes) in \S+ blocks are (.*?) in loss (record \S+ of \S+)/;
0012 my $mstartuni = qr/^==\d+== ()(\S.*uninitiali[sz]ed.*|Invalid (?:read|write).*)()/;
0013 my $mstartfree = qr/^==\d+== ()(\S.*free\(\).*)()/;
0014 my $mtrace = qr/^==\d+== \s+(?:at|by)\s.*?:\s+(.*?)\s\((.*)\)/;
0015 my $version = undef; #"CMSSW_1_5_0_pre3";
0016 my @showstoppers = qq();
0017
0018 my %presets = (
0019     'trash' => [ '__static_initialization_and_destruction_0', 'G__exec_statement', 'dlopen\@\@GLIBC_2', '_dl_lookup_symbol_x' ],
0020     'fwk' => [ qw(EventSetup  ESProd  castor  ROOT  Pool  Reflex  PluginManager  RFIO  xerces  G_) ],
0021     'tom'  =>  [ qw(EventSetup ESProd castor ROOT Pool Reflex PluginManager RFIO xerces G_ libGraf createES),
0022                  qw(Streamer python static MessageLogger ServiceRegistry) ],
0023     'prod' => [ '::(produce|filter)\(\s*edm::Event\s*&' , '::analyze\(\s*(?:const\s+)?edm::Event(?:\s+const)?\s*&' ],
0024     'prod1' => [ '::produce\(\s*\w+(?:\s+const)?\s*&\w*\s*\)' ],
0025     'prod1+' => [ '::produce\(\s*\w+(?:\s+const)?\s*&\w*\s*\)', 'edm::eventsetup::DataProxyTemplate<' ],
0026 );
0027 my $preset_names = join(', ', sort(keys(%presets)));
0028
0029 my @trace = (); my @libs = (); my @presets = (); my @dump_presets = ();
0030 my $help = '';  my $all = ''; my $onecolumn = ''; my $uninitialized = undef; my $free = undef;
0031
0032 GetOptions(
0033         'rel|release|r=s' => \$version,
0034         'libs|l=s' => \@libs,
0035         'trace|t=s' => \@trace,
0036         'stopper|showstopper=s'=> \@showstoppers,
0037         'onecolumn|1' => \$onecolumn,
0038         'all|a' => \$all,
0039         'preset=s'   => \@presets,
0040         'dump-preset=s'   => \@dump_presets,
0041         'uninitialized|u' => \$uninitialized,
0042         'free|f' => \$free,
0043         'help|h|?' => \$help);
0044 if ($uninitialized) { $mstart = $mstartuni; print STDERR "Hunting for uninitialized stuff\n"; }
0045 if ($free) { $mstart = $mstartfree; print STDERR "Hunting for free stuff\n"; }
0046 if ($help) {
0047         print <<_END;
0048    Usage: valgrindMemcheckParser.pl [ --rel RELEASE ]
0049                  [ --libs lib1,lib2,-lib3 ]
0050                  [ --trace match1,match2,-match3 ]
0051                  [ --stopper lib1,lib2 ]
0052                  [ --preset name,name,-name,+name,... ]
0053                  [ --all ]
0054                  [ --onecolumn ]
0055                  [ --uninitialized | --free ]
0056                  logfile [ logfile2 logfile3 ... ]
0057
0058   It will output a XHTML file to standard output.
0059
0060   If no input file is specified, reads from standard input.
0061
0062   FILTERS
0063     --libs: coma-separated list of libs to require in the library stack trace
0064             (or to exclude, if prefixed by a "-").
0065             Can be used multiple times.
0066             Abbreviation is "-l"
0067     --trace: coma-separated list of regexps to match in the stack trace
0068              (or to exclude, if prefixed by a "-").
0069              Can be used multiple times.
0070              Abbreviation is "-t"
0071     --stopper: coma-separated list of libs to cut the stack trace at;
0072                libFWCoreFramework.so is in by default.
0073                set it to "none" to never break stack trace.
0074                use full library name.
0075     --preset: use a specified preset filter for exclusion or inclusion.
0076         filter names are $preset_names
0077         --preset name : require at least one of the regexps in "name" to match
0078                         in the stack trace
0079         --preset +name: requires all the regexp to match the in each stack trace
0080                         (not all on the same stack trace element, of course)
0081         --preset -name: exclude the event if at least one regexp in name matches
0082                         in the stack trace
0083         to get the contents of a preset use "--dump-preset name"
0084
0085     --all: show all leaks, skipping any filter
0086              Abbreviation is "-a"
0087
0088     --uninitialized (-u): look for uses of uninitialized memory instead of leaks
0089     --free (-f): look for bad calls to free() instead of memory leaks
0090
0091     Note: you can use PERL regexps in "libs", "trace"
0092
0093   HTML & LINKING OPTIONS
0094     --onecolunm: output things in one column, avoiding the column with the library name,
0095                  for easier cut-n-paste in savannah
0096                  an alias is "-1"
0097     --rel: CMSSW_*, or "nightly" (default: $version) to set LXR links
0098            aliases are "--release" and "-r"
0099     --link-files: if set to true (default is false), links to Uppercase identifiers are
0100                   made using filename search instead of identifier search)
0101       [NOT IMPLEMENTED]
0102
0103   HELP
0104     --help : prints this stuff (also -h, -?)
0105     --dump-preset name: dumps the content of a preset and exit
0106
0107 _END
0108     exit;
0109 }
0110 if (@dump_presets) {
0111     foreach my $ps (@dump_presets) {
0112         print "Preset $ps: \n";
0113         print map("\t * '$_'\n", @{$presets{$ps}});
0114         print "\n";
0115     }
0116     exit;
0117 }
0118
0119 #if ($version eq 'nightly') { $version = time2str('%Y-%m-%d',time()); }
0120 @libs = split(/,/, join(',',@libs));
0121 @trace = split(/,/, join(',',@trace));
0122 @presets = split(/,/, join(',',@presets));
0123 @showstoppers= split(/,/, join(',',@showstoppers,'libFWCoreFramework'));
0124 if (grep($_ eq 'none', @showstoppers)) { @showstoppers = (); }
0125 my @trace_in  = map (qr($_), grep ( $_ !~ m/^-/, @trace ));
0126 my @trace_out = map (qr($_), grep ( s/^-//g, @trace ));
0127 my @libs_in   = map (qr($_), grep ( $_ !~ m/^-/, @libs ));
0128 my @libs_out  = map (qr($_), grep ( s/^-//g, @libs ));
0129 my %stopmap = (); foreach (@showstoppers) { $stopmap{$_} = 1; }
0130 my %presets_c = ();
0131 foreach my $ps (keys(%presets)) { $presets_c{$ps} = [ map(qr($_), @{$presets{$ps}}) ] ; }
0132 my @leaks = ();
0133
0134 sub cfilter {
0135     my @trace = @{$_->{'trace'}};
0136     my $rx;
0137     foreach $rx (@trace_in ) { return 0 unless ( grep( $_->[0] =~ $rx, @trace) ); }
0138     foreach $rx (@trace_out) { return 0 if     ( grep( $_->[0] =~ $rx, @trace) ); }
0139     foreach $rx (@libs_in )  { return 0 unless ( grep( $_->[1] =~ $rx, @trace) ); }
0140     foreach $rx (@libs_out)  { return 0 if     ( grep( $_->[1] =~ $rx, @trace) ); }
0141     foreach my $ps (@presets) {
0142         my ($op, $name) = ($ps =~ m/^([+\-]?)(\S+)/);
0143         if ($op eq '') {
0144             my $ok = 0;
0145             foreach $rx (@{$presets_c{$name}}) {
0146                 if ( grep( $_->[0] =~ $rx, @trace) ) { $ok = 1; last; }
0147             }
0148             return 0 unless $ok;
0149         } elsif ($op eq '-') {
0150             foreach $rx (@{$presets_c{$name}}) {
0151                 return 0 if     ( grep( $_->[0] =~ $rx, @trace) );
0152             }
0153         } elsif ($op eq '+') {
0154             foreach $rx (@{$presets_c{$name}}) {
0155                 return 0 unless ( grep( $_->[0] =~ $rx, @trace) );
0156             }
0157         }
0158     }
0159     return 1;
0160 }
0161
0162 sub realsize {
0163         my ($num) = ($_[0] =~ m/^([0-9,]+)/) or return 0;
0164         $num =~ s/,//g;
0165         return eval($num);
0166 }
0167 sub fformat {
0168         my $vstring = (defined($version) ? "v=$version;" : "");
0169         my $func = &escapeHTML($_[0]);
0170         $func =~ s!(\b[A-Z]\w\w\w\w+)!<a class='obj' href='http://cmssdt.cern.ch/SDT/lxr/ident?${vstring}i=$1'>$1</a>!g;
0171         $func =~ s!::(\w+)\(!::<a class='func' href='http://cmssdt.cern.ch/SDT/lxr/ident?${vstring}i=$1'>$1</a>(!g;
0172         return $func;
0173 }
0174 sub escapeHTML {
0175         my $data=$_[0];
0176         $data =~ s!&!&amp;!g;
0177         $data =~ s!<!&lt;!g;
0178         $data =~ s!>!&gt;!g;
0179         $data =~ s!"!&quot;!g;
0180         return $data;
0181 }
0182
0183 while (<>) {
0184   if (/$mstart/) {
0185         my ($size, $status, $record) = ($1, $2, $3);
0186         #print STDERR "\nLoss size=$size, status=$status\n" if $#leaks < 20;
0187
0188         my %libs = (); my @trace = ();
0189         while (<>) {
0190                 my ($func, $lib) = /$mtrace/ or last;
0191                 #$lib =~ s/^in \S+\/((?:lib|plugin)\w+)\.so/$1/ or next;
0192                 $lib =~ s/^in \S+\/((?:lib|plugin)\w+)\.so/$1/; # or $lib = "";
0193                 last if $stopmap{$lib};
0194                 $libs{$lib} = 1; push @trace, [$func, $lib];
0195                 die "I'm not defined" unless (defined($func) and defined($lib));
0196                 #print STDERR "   lib=$lib, func=$func\n"  if $#leaks < 20;
0197         }
0198
0199         push @leaks, { 'size'=>$size, 'realsize' => realsize($size), 'status'=>$status, 'record'=>$record, 'libs'=>[keys(%libs)], 'trace'=>\@trace};
0200   }
0201 }
0202
0203
0204 #print STDERR Dumper(\@leaks);
0205 my @gleaks = ($all ? @leaks : grep ( cfilter($_), @leaks));
0206 my @sleaks = sort {$b->{'realsize'} <=> $a->{'realsize'}} @gleaks ;
0207 my $count = scalar(@sleaks);
0208 print STDERR "Selected $count leaks of " , scalar(@leaks) , ".\n";
0209 print <<EOF;
0210 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
0211    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
0212 <html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
0213 <head>
0214         <title>Valgrind MemCheck output</title>
0215         <link rel='stylesheet' type='text/css' href='valgrindMemcheckParser.css' />
0216 </head>
0217 <body>
0218         <h1>Valgrind MemCheck output ($count leaks)</h1>
0219
0220 <table width="100\%">
0221 EOF
0222 my $idx = 0;
0223 foreach my $l (@sleaks) {
0224         my %L = %{$l}; $idx++;
0225         my $colspan = ($onecolumn ? 1 : 2);
0226         my $aname = sprintf("L%04d", $idx);
0227         print "<tr class='header'><th class='header' colspan='$colspan'><a name=\"$aname\">Leak $idx</a>: $L{size} $L{status} ($L{record}) <a href=\"#$aname\">[href]</a></th></tr>\n";
0228         foreach my $sf (@{$L{'trace'}}) {
0229                 print "<tr class='trace'><td class='func'>"  . fformat($sf->[0]) . "</td>";
0230                 print "<td class='lib'>" . $sf->[1]. "</td>" unless $onecolumn;
0231                 print "</tr>\n";
0232         }
0233 }
0234
0235 my $footer = "Done at " . scalar(localtime());
0236 print <<EOF;
0237 </table>
0238 <p class='footer'>$footer</p>
0239 </body>
0240 </html>
0241 EOF