tools/dev/parrot_coverage.pl

   1 #! perl
   2 # Copyright (C) 2001-2005, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 tools/dev/parrot_coverage.pl - Run coverage tests and report
   8
   9 =head1 SYNOPSIS
  10
  11     % mkdir parrot_coverage
  12     % perl tools/dev/parrot_coverage.pl recompile
  13     % perl tools/dev/parrot_coverage.pl
  14
  15 =head1 DESCRIPTION
  16
  17 This script runs a coverage test and then generates HTML reports. It requires
  18 C<gcc> and C<gcov> to be installed.
  19
  20 The reports start at F<parrot_coverage/index.html>.
  21
  22 =cut
  23
  24 use strict;
  25 use warnings;
  26
  27 use Data::Dumper;
  28 use File::Basename;
  29 use File::Find;
  30 use POSIX qw(strftime);
  31
  32 my $SRCDIR  = "./";                # with trailing /
  33 my $HTMLDIR = "parrot_coverage";
  34 my $DEBUG   = 1;
  35
  36 if ( $ARGV[0] && $ARGV[0] =~ /recompile/ ) {
  37
  38     # clean up remnants of prior builds
  39     File::Find::find(
  40         {
  41             wanted => sub {
  42                 /\.(bb|bba|bbf|da|gcov)$/
  43                     && unlink($File::Find::name);
  44                 }
  45         },
  46         $SRCDIR
  47     );
  48
  49     # build parrot with coverage support
  50     system("perl Configure.pl --ccflags=\"-fprofile-arcs -ftest-coverage\"");
  51     system("make");
  52
  53     # Now run the tests
  54     system("make fulltest");
  55 }
  56
  57 # And generate the reports.
  58
  59 my @dafiles;
  60 File::Find::find(
  61     {
  62         wanted => sub {
  63             /\.da$/ && push @dafiles, $File::Find::name;
  64             }
  65     },
  66     $SRCDIR
  67 );
  68
  69 my ( %file_line_coverage,     %file_branch_coverage,     %file_call_coverage );
  70 my ( %function_line_coverage, %function_branch_coverage, %function_call_coverage );
  71 my (%real_filename);
  72 my %totals = (
  73     lines            => 0,
  74     covered_lines    => 0,
  75     branches         => 0,
  76     covered_branches => 0,
  77     calls            => 0,
  78     covered_calls    => 0
  79 );
  80
  81 # We parse the output of the 'gcov' command, so we do not want german output
  82 $ENV{LANG} = 'C';
  83
  84 foreach my $da_file (@dafiles) {
  85     my $dirname      = dirname($da_file) || '.';
  86     my $filename     = basename($da_file);
  87     my $src_filename = $da_file;
  88     $src_filename =~ s/\.da$/.c/;
  89
  90     # gcov must be run from the directory that the compiler was
  91     # invoked from.  Currently, this is the parrot root directory.
  92     # However, it also leaves it output file in this directory, which
  93     # we need to move to the appropriate place, alongside the
  94     # sourcefile that produced it.  Hence, as soon as we know the true
  95     # name of the object file being profiled, we rename the gcov log
  96     # file.  The -o flag is necessary to help gcov locate it's basic
  97     # block (.bb) files.
  98     my $cmd = "gcov -f -b -o $dirname $src_filename";
  99     print "Running $cmd\n" if $DEBUG;
 100     open( my $GCOVSUMMARY, '<', "$cmd |" ) or die "Error invoking '$cmd': $!";
 101     my $tmp;
 102     my %generated_files;
 103     while (<$GCOVSUMMARY>) {
 104         if (/^Creating (.*)\./) {
 105             my $path = "$dirname/$1";
 106             rename( $1, "$dirname/$1" )
 107                 or die("Couldn't rename $1 to $dirname/$1.");
 108             $path =~ s/\Q$SRCDIR\E//g;
 109             $generated_files{$path} = $tmp;
 110             $tmp = '';
 111         }
 112         else {
 113             $tmp .= $_;
 114         }
 115     }
 116     close($GCOVSUMMARY);
 117
 118     foreach my $gcov_file ( keys %generated_files ) {
 119         my $source_file = $gcov_file;
 120         $source_file =~ s/\.gcov$//g;
 121
 122         # avoid collisions where multiple files are generated from the
 123         # same back-end file (core.ops, for example)
 124         if ( exists( $file_line_coverage{$source_file} ) ) {
 125             $source_file = "$source_file (from $da_file)";
 126         }
 127
 128         print "Processing $gcov_file ($source_file)\n";
 129
 130         foreach ( split m/\n/, $generated_files{$gcov_file} ) {
 131             my ( $percent, $total_lines, $real_filename ) =
 132                 /\s*([^%]+)% of (\d+)(?: source)? lines executed in file (.*)/;
 133             if ($total_lines) {
 134                 my $covered_lines = int( ( $percent / 100 ) * $total_lines );
 135                 $totals{lines}         += $total_lines;
 136                 $totals{covered_lines} += $covered_lines;
 137                 $file_line_coverage{$source_file} = $percent;
 138                 $real_filename{$source_file}      = $real_filename;
 139                 next;
 140             }
 141
 142             ( $percent, $total_lines, my $function ) =
 143                 /\s*([^%]+)% of (\d+)(?: source)? lines executed in function (.*)/;
 144             if ($total_lines) {
 145                 $function_line_coverage{$source_file}{$function} = $percent;
 146                 next;
 147             }
 148
 149             ( $percent, my $total_branches ) =
 150                 /\s*([^%]+)% of (\d+) branches taken at least once in file/;
 151             if ($total_branches) {
 152                 my $covered_branches = int( ( $percent / 100 ) * $total_branches );
 153                 $totals{branches}         += $total_branches;
 154                 $totals{covered_branches} += $covered_branches;
 155                 $file_branch_coverage{$source_file} = $percent;
 156                 next;
 157             }
 158
 159             ( $percent, $total_branches, $function ) =
 160                 /\s*([^%]+)% of (\d+) branches taken at least once in function (.*)/;
 161             if ($total_branches) {
 162                 $function_branch_coverage{$source_file}{$function} = $percent;
 163                 next;
 164             }
 165
 166             ( $percent, my $total_calls, $function ) =
 167                 /\s*([^%]+)% of (\d+) calls executed in function (.*)/;
 168             if ($total_calls) {
 169                 $function_call_coverage{$source_file}{$function} = $percent;
 170                 next;
 171             }
 172
 173             ( $percent, $total_calls ) = /\s*([^%]+)% of (\d+) calls executed in file/;
 174             if ($total_calls) {
 175                 my $covered_calls = int( ( $percent / 100 ) * $total_calls );
 176                 $totals{calls}         += $total_calls;
 177                 $totals{covered_calls} += $covered_calls;
 178                 $file_call_coverage{$source_file} = $percent;
 179                 next;
 180             }
 181         }
 182
 183         filter_gcov($gcov_file);
 184     }
 185 }
 186
 187 write_file_coverage_summary();
 188 write_function_coverage_summary();
 189 write_index();
 190
 191 exit(0);
 192
 193 sub write_index {
 194     print "Writing $HTMLDIR/index.html..\n" if $DEBUG;
 195     open( my $OUT, ">", "$HTMLDIR/index.html" )
 196         or die "Can't open $HTMLDIR/index.html for writing: $!\n";
 197
 198     $totals{line_coverage} = sprintf( "%.2f",
 199         ( $totals{lines} ? ( $totals{covered_lines} / $totals{lines} * 100 ) : 0 ) );
 200     $totals{branch_coverage} = sprintf( "%.2f",
 201         ( $totals{branches} ? ( $totals{covered_branches} / $totals{branches} * 100 ) : 0 ) );
 202     $totals{call_coverage} = sprintf( "%.2f",
 203         ( $totals{calls} ? ( $totals{covered_calls} / $totals{calls} * 100 ) : 0 ) );
 204
 205     print $OUT page_header("Parrot Test Coverage");
 206     print $OUT qq(
 207             <ul>
 208               <li><a href="file_summary.html">File Summary</a>
 209               <li><a href="function_summary.html">Function Summary</a>
 210               <li>Overall Summary:<br>
 211
 212             <table border="1">
 213               <tbody>
 214                  <tr>
 215                  <th></th><th>Lines</th><th>Branches</th><th>Calls</th>
 216                  </tr>
 217                  <tr>
 218                  <td>Totals:</td>
 219                  <td>$totals{covered_lines} of $totals{lines} ($totals{line_coverage} %)</td>
 220                  <td>$totals{covered_branches} of $totals{branches} ($totals{branch_coverage} %)</td>
 221                  <td>$totals{covered_calls} of $totals{calls} ($totals{call_coverage} %)</td>
 222                  </tr>
 223               </tbody>
 224             </table>
 225             </ul>
 226     );
 227     print $OUT page_footer();
 228 }
 229
 230 sub write_file_coverage_summary {
 231
 232     print "Writing $HTMLDIR/file_summary.html..\n" if $DEBUG;
 233     open( my $OUT, ">", "$HTMLDIR/file_summary.html" )
 234         or die "Can't open $HTMLDIR/file_summary.html for writing: $!\n";
 235
 236     print $OUT page_header("File Coverage Summary");
 237     print $OUT qq(
 238             <i>You may click on a percentage to see line-by-line detail</i>
 239             <table border="1">
 240               <tbody>
 241                 <tr>
 242                   <th>File</th>
 243                   <th>Line Coverage</th>
 244                   <th>Branch Coverage</th>
 245                   <th>Call Coverage</th>
 246                 </tr>
 247     );
 248
 249     foreach my $source_file ( sort keys %file_line_coverage ) {
 250         my $outfile_base = $source_file;
 251         $outfile_base =~ s/\//_/g;
 252
 253         print $OUT qq(
 254            <tr>
 255              <td>$source_file</td>
 256              <td><a href="$outfile_base.lines.html">@{[$file_line_coverage{$source_file} ? "$file_line_coverage{$source_file} %" : "n/a" ]}</a></td>
 257              <td><a href="$outfile_base.branches.html">@{[$file_branch_coverage{$source_file} ? "$file_branch_coverage{$source_file} %" : "n/a" ]}</a></td>
 258              <td><a href="$outfile_base.calls.html">@{[$file_call_coverage{$source_file} ? "$file_call_coverage{$source_file} %" : "n/a" ]}</a></td>
 259              <td>[<a href="function_summary.html#$source_file">function detail</a>]</td>
 260           </tr>
 261        );
 262     }
 263
 264     print $OUT qq(
 265             </tbody>
 266           </table>
 267     );
 268     print $OUT page_footer();
 269
 270     close($OUT);
 271 }
 272
 273 sub write_function_coverage_summary {
 274
 275     print "Writing $HTMLDIR/function_summary.html..\n" if $DEBUG;
 276     open( my $OUT, ">", "$HTMLDIR/function_summary.html" )
 277         or die "Can't open $HTMLDIR/function_summary.html for writing: $!\n";
 278
 279     print $OUT page_header("Function Coverage Summary");
 280     print $OUT qq(
 281             <i>You may click on a percentage to see line-by-line detail</i>
 282     );
 283
 284     foreach my $source_file ( sort keys %file_line_coverage ) {
 285
 286         print $OUT qq(
 287             <hr noshade>
 288             <a name="$source_file"></a>
 289             <b>File: $source_file</b><br>
 290             <table border="1">
 291               <tbody>
 292                 <tr>
 293                   <th>Function</th>
 294                   <th>Line Coverage</th>
 295                   <th>Branch Coverage</th>
 296                   <th>Call Coverage</th>
 297     );
 298
 299         my $outfile_base = $source_file;
 300         $outfile_base =~ s/\//_/g;
 301
 302         foreach my $function ( sort keys %{ $function_line_coverage{$source_file} } ) {
 303
 304             print $OUT qq(
 305            <tr>
 306              <td>$function</td>
 307              <td><a href="$outfile_base.lines.html#$function">@{[$function_line_coverage{$source_file}{$function} ? "$function_line_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
 308              <td><a href="$outfile_base.branches.html#$function">@{[$function_branch_coverage{$source_file}{$function} ? "$function_branch_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
 309              <td><a href="$outfile_base.calls.html#$function">@{[$function_call_coverage{$source_file}{$function} ? "$function_call_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
 310            </tr>
 311             );
 312         }
 313         print $OUT qq(
 314             </tbody>
 315             </table>
 316         );
 317     }
 318
 319     print $OUT page_footer();
 320
 321     close($OUT);
 322 }
 323
 324 sub filter_gcov {
 325     my ($infile) = @_;
 326
 327     my $source_file = $infile;
 328     $source_file =~ s/\.gcov$//g;
 329
 330     my $outfile_base = $source_file;
 331     $outfile_base =~ s/\//_/g;
 332     $outfile_base = "$HTMLDIR/$outfile_base";
 333
 334     my $outfile = "$outfile_base.lines.html";
 335     print "Writing $outfile..\n" if $DEBUG;
 336     our ( $IN, $OUT );
 337     open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
 338     open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";
 339
 340     print $OUT page_header("Line Coverage for $source_file");
 341     print $OUT "<pre>";
 342
 343     # filter out any branch or call coverage lines.
 344     do_filter( sub { /^(call|branch)/ } );
 345
 346     print $OUT "</pre>";
 347     print $OUT page_footer();
 348
 349     close($OUT);
 350     close($IN);
 351
 352     $outfile = "$outfile_base.branches.html";
 353     print "Writing $outfile..\n" if $DEBUG;
 354     open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
 355     open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";
 356
 357     print $OUT page_header("Branch Coverage for $source_file");
 358     print $OUT "<pre>";
 359
 360     # filter out any call coverage lines.
 361     do_filter( sub { /^call/ } );
 362
 363     print $OUT "</pre>";
 364     print $OUT page_footer();
 365
 366     close($OUT);
 367     close($IN);
 368
 369     $outfile = "$outfile_base.calls.html";
 370     print "Writing $outfile..\n" if $DEBUG;
 371     open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
 372     open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";
 373
 374     print $OUT page_header("Call Coverage for $source_file");
 375     print $OUT "<pre>";
 376
 377     # filter out any branch coverage lines.
 378     do_filter( sub { /^branch/ } );
 379
 380     print $OUT "</pre>";
 381     print $OUT page_footer();
 382
 383     close($OUT);
 384     close($IN);
 385
 386     return;
 387
 388     sub do_filter {
 389         my ($skip_func) = @_;
 390
 391         while (<$IN>) {
 392             s/&/&amp;/g;
 393             s/</&lt;/g;
 394             s/>/&gt;/g;
 395
 396             next if ( &{$skip_func}($_) );
 397
 398             my $atag = "";
 399             if (/^\s*([^\(\s]+)\(/) {
 400                 $atag = "<a name=\"$1\"></a>";
 401             }
 402
 403             my ($initial) = substr( $_, 0, 16 );
 404             if ( $initial =~ /^\s*\d+\s*$/ ) {
 405                 print $OUT qq($atag<font color="green">$_</font>);
 406             }
 407             elsif ( $_ =~ /branch \d+ taken = 0%/ ) {
 408                 print $OUT qq($atag<font color="red">$_</font>);
 409             }
 410             elsif ( $_ =~ /call \d+ returns = 0%/ ) {
 411                 print $OUT qq($atag<font color="red">$_</font>);
 412             }
 413             elsif ( $_ =~ /^call \d+ never executed/ ) {
 414                 print $OUT qq($atag<font color="red">$_</font>);
 415             }
 416             elsif ( $_ =~ /^branch \d+ never executed/ ) {
 417                 print $OUT qq($atag<font color="red">$_</font>);
 418             }
 419             elsif ( $initial =~ /\#\#\#/ ) {
 420                 print $OUT qq($atag<font color="red">$_</font>);
 421             }
 422             else {
 423                 print $OUT $_;
 424             }
 425         }
 426     }
 427 }
 428
 429 sub page_header {
 430     my ($title) = @_;
 431
 432     qq(
 433         <html>
 434           <head>
 435              <title>$title</title>
 436           </head>
 437           <body bgcolor="white">
 438             <h1>$title</h1>
 439             <hr noshade>
 440     );
 441 }
 442
 443 sub page_footer {
 444     "<hr noshade><i>Last Updated: @{[ scalar(localtime) . strftime(' (%Z)', localtime(time)) ]} </i>
 445      </body></html>";
 446 }
 447
 448 # Local Variables:
 449 #   mode: cperl
 450 #   cperl-indent-level: 4
 451 #   fill-column: 100
 452 # End:
 453 # vim: expandtab shiftwidth=4: