#! perl
# Copyright (C) 2001-2005, The Perl Foundation.
# $Id: parrot_coverage.pl 22887 2007-11-18 18:22:41Z bernhard $

=head1 NAME

tools/dev/parrot_coverage.pl - Run coverage tests and report

=head1 SYNOPSIS

    % mkdir parrot_coverage
    % perl tools/dev/parrot_coverage.pl recompile
    % perl tools/dev/parrot_coverage.pl

=head1 DESCRIPTION

This script runs a coverage test and then generates HTML reports. It requires
C<gcc> and C<gcov> to be installed.

The reports start at F<parrot_coverage/index.html>.

=cut

use strict;
use warnings;

use Data::Dumper;
use File::Basename;
use File::Find;
use POSIX qw(strftime);

my $SRCDIR  = "./";                # with trailing /
my $HTMLDIR = "parrot_coverage";
my $DEBUG   = 1;

if ( $ARGV[0] && $ARGV[0] =~ /recompile/ ) {

    # clean up remnants of prior biulds
    File::Find::find(
        {
            wanted => sub {
                /\.(bb|bba|bbf|da|gcov)$/
                    && unlink($File::Find::name);
                }
        },
        $SRCDIR
    );

    # build parrot with coverage support
    system("perl Configure.pl --ccflags=\"-fprofile-arcs -ftest-coverage\"");
    system("make");

    # Now run the tests
    system("make fulltest");
}

# And generate the reports.

my @dafiles;
File::Find::find(
    {
        wanted => sub {
            /\.da$/ && push @dafiles, $File::Find::name;
            }
    },
    $SRCDIR
);

my ( %file_line_coverage,     %file_branch_coverage,     %file_call_coverage );
my ( %function_line_coverage, %function_branch_coverage, %function_call_coverage );
my (%real_filename);
my %totals = (
    lines            => 0,
    covered_lines    => 0,
    branches         => 0,
    covered_branches => 0,
    calls            => 0,
    covered_calls    => 0
);

# We parse the output of the 'gcov' command, so we do not want german output
$ENV{LANG} = 'C';

foreach my $da_file (@dafiles) {
    my $dirname      = dirname($da_file) || '.';
    my $filename     = basename($da_file);
    my $src_filename = $da_file;
    $src_filename =~ s/\.da$/.c/;

    # gcov must be run from the directory that the compiler was
    # invoked from.  Currently, this is the parrot root directory.
    # However, it also leaves it output file in this directory, which
    # we need to move to the appropriate place, alongside the
    # sourcefile that produced it.  Hence, as soon as we know the true
    # name of the object file being profiled, we rename the gcov log
    # file.  The -o flag is necessary to help gcov locate it's basic
    # block (.bb) files.
    my $cmd = "gcov -f -b -o $dirname $src_filename";
    print "Running $cmd\n" if $DEBUG;
    open( my $GCOVSUMMARY, '<', "$cmd |" ) or die "Error invoking '$cmd': $!";
    my $tmp;
    my %generated_files;
    while (<$GCOVSUMMARY>) {
        if (/^Creating (.*)\./) {
            my $path = "$dirname/$1";
            rename( $1, "$dirname/$1" )
                or die("Couldn't rename $1 to $dirname/$1.");
            $path =~ s/\Q$SRCDIR\E//g;
            $generated_files{$path} = $tmp;
            $tmp = '';
        }
        else {
            $tmp .= $_;
        }
    }
    close($GCOVSUMMARY);

    foreach my $gcov_file ( keys %generated_files ) {
        my $source_file = $gcov_file;
        $source_file =~ s/\.gcov$//g;

        # avoid collisions where multiple files are generated from the
        # same back-end file (core.ops, for example)
        if ( exists( $file_line_coverage{$source_file} ) ) {
            $source_file = "$source_file (from $da_file)";
        }

        print "Processing $gcov_file ($source_file)\n";

        foreach ( split m/\n/, $generated_files{$gcov_file} ) {
            my ( $percent, $total_lines, $real_filename ) =
                /\s*([^%]+)% of (\d+)(?: source)? lines executed in file (.*)/;
            if ($total_lines) {
                my $covered_lines = int( ( $percent / 100 ) * $total_lines );
                $totals{lines}         += $total_lines;
                $totals{covered_lines} += $covered_lines;
                $file_line_coverage{$source_file} = $percent;
                $real_filename{$source_file}      = $real_filename;
                next;
            }

            ( $percent, $total_lines, my $function ) =
                /\s*([^%]+)% of (\d+)(?: source)? lines executed in function (.*)/;
            if ($total_lines) {
                $function_line_coverage{$source_file}{$function} = $percent;
                next;
            }

            ( $percent, my $total_branches ) =
                /\s*([^%]+)% of (\d+) branches taken at least once in file/;
            if ($total_branches) {
                my $covered_branches = int( ( $percent / 100 ) * $total_branches );
                $totals{branches}         += $total_branches;
                $totals{covered_branches} += $covered_branches;
                $file_branch_coverage{$source_file} = $percent;
                next;
            }

            ( $percent, $total_branches, $function ) =
                /\s*([^%]+)% of (\d+) branches taken at least once in function (.*)/;
            if ($total_branches) {
                $function_branch_coverage{$source_file}{$function} = $percent;
                next;
            }

            ( $percent, my $total_calls, $function ) =
                /\s*([^%]+)% of (\d+) calls executed in function (.*)/;
            if ($total_calls) {
                $function_call_coverage{$source_file}{$function} = $percent;
                next;
            }

            ( $percent, $total_calls ) = /\s*([^%]+)% of (\d+) calls executed in file/;
            if ($total_calls) {
                my $covered_calls = int( ( $percent / 100 ) * $total_calls );
                $totals{calls}         += $total_calls;
                $totals{covered_calls} += $covered_calls;
                $file_call_coverage{$source_file} = $percent;
                next;
            }
        }

        filter_gcov($gcov_file);
    }
}

write_file_coverage_summary();
write_function_coverage_summary();
write_index();

exit(0);

sub write_index {
    print "Writing $HTMLDIR/index.html..\n" if $DEBUG;
    open( my $OUT, ">", "$HTMLDIR/index.html" )
        or die "Can't open $HTMLDIR/index.html for writing: $!\n";

    $totals{line_coverage} = sprintf( "%.2f",
        ( $totals{lines} ? ( $totals{covered_lines} / $totals{lines} * 100 ) : 0 ) );
    $totals{branch_coverage} = sprintf( "%.2f",
        ( $totals{branches} ? ( $totals{covered_branches} / $totals{branches} * 100 ) : 0 ) );
    $totals{call_coverage} = sprintf( "%.2f",
        ( $totals{calls} ? ( $totals{covered_calls} / $totals{calls} * 100 ) : 0 ) );

    print $OUT page_header("Parrot Test Coverage");
    print $OUT qq(
            <ul>
              <li><a href="file_summary.html">File Summary</a>
              <li><a href="function_summary.html">Function Summary</a>
              <li>Overall Summary:<br>

            <table border="1">
              <tbody>
                 <tr>
                 <th></th><th>Lines</th><th>Branches</th><th>Calls</th>
                 </tr>
                 <tr>
                 <td>Totals:</td>
                 <td>$totals{covered_lines} of $totals{lines} ($totals{line_coverage} %)</td>
                 <td>$totals{covered_branches} of $totals{branches} ($totals{branch_coverage} %)</td>
                 <td>$totals{covered_calls} of $totals{calls} ($totals{call_coverage} %)</td>
                 </tr>
              </tbody>
            </table>
            </ul>
    );
    print $OUT page_footer();
}

sub write_file_coverage_summary {

    print "Writing $HTMLDIR/file_summary.html..\n" if $DEBUG;
    open( my $OUT, ">", "$HTMLDIR/file_summary.html" )
        or die "Can't open $HTMLDIR/file_summary.html for writing: $!\n";

    print $OUT page_header("File Coverage Summary");
    print $OUT qq(
            <i>You may click on a percentage to see line-by-line detail</i>
            <table border="1">
              <tbody>
                <tr>
                  <th>File</th>
                  <th>Line Coverage</th>
                  <th>Branch Coverage</th>
                  <th>Call Coverage</th>
                </tr>
    );

    foreach my $source_file ( sort keys %file_line_coverage ) {
        my $outfile_base = $source_file;
        $outfile_base =~ s/\//_/g;

        print $OUT qq(
           <tr>
             <td>$source_file</td>
             <td><a href="$outfile_base.lines.html">@{[$file_line_coverage{$source_file} ? "$file_line_coverage{$source_file} %" : "n/a" ]}</a></td>
             <td><a href="$outfile_base.branches.html">@{[$file_branch_coverage{$source_file} ? "$file_branch_coverage{$source_file} %" : "n/a" ]}</a></td>
             <td><a href="$outfile_base.calls.html">@{[$file_call_coverage{$source_file} ? "$file_call_coverage{$source_file} %" : "n/a" ]}</a></td>
             <td>[<a href="function_summary.html#$source_file">function detail</a>]</td>
          </tr>
       );
    }

    print $OUT qq(
            </tbody>
          </table>
    );
    print $OUT page_footer();

    close($OUT);
}

sub write_function_coverage_summary {

    print "Writing $HTMLDIR/function_summary.html..\n" if $DEBUG;
    open( my $OUT, ">", "$HTMLDIR/function_summary.html" )
        or die "Can't open $HTMLDIR/function_summary.html for writing: $!\n";

    print $OUT page_header("Function Coverage Summary");
    print $OUT qq(
            <i>You may click on a percentage to see line-by-line detail</i>
    );

    foreach my $source_file ( sort keys %file_line_coverage ) {

        print $OUT qq(
            <hr noshade>
            <a name="$source_file"></a>
            <b>File: $source_file</b><br>
            <table border="1">
              <tbody>
                <tr>
                  <th>Function</th>
                  <th>Line Coverage</th>
                  <th>Branch Coverage</th>
                  <th>Call Coverage</th>
    );

        my $outfile_base = $source_file;
        $outfile_base =~ s/\//_/g;

        foreach my $function ( sort keys %{ $function_line_coverage{$source_file} } ) {

            print $OUT qq(
           <tr>
             <td>$function</td>
             <td><a href="$outfile_base.lines.html#$function">@{[$function_line_coverage{$source_file}{$function} ? "$function_line_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
             <td><a href="$outfile_base.branches.html#$function">@{[$function_branch_coverage{$source_file}{$function} ? "$function_branch_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
             <td><a href="$outfile_base.calls.html#$function">@{[$function_call_coverage{$source_file}{$function} ? "$function_call_coverage{$source_file}{$function} %" : "n/a" ]}</a></td>
           </tr>
            );
        }
        print $OUT qq(
            </tbody>
            </table>
        );
    }

    print $OUT page_footer();

    close($OUT);
}

sub filter_gcov {
    my ($infile) = @_;

    my $source_file = $infile;
    $source_file =~ s/\.gcov$//g;

    my $outfile_base = $source_file;
    $outfile_base =~ s/\//_/g;
    $outfile_base = "$HTMLDIR/$outfile_base";

    my $outfile = "$outfile_base.lines.html";
    print "Writing $outfile..\n" if $DEBUG;
    our ( $IN, $OUT );
    open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
    open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";

    print $OUT page_header("Line Coverage for $source_file");
    print $OUT "<pre>";

    # filter out any branch or call coverage lines.
    do_filter( sub { /^(call|branch)/ } );

    print $OUT "</pre>";
    print $OUT page_footer();

    close($OUT);
    close($IN);

    $outfile = "$outfile_base.branches.html";
    print "Writing $outfile..\n" if $DEBUG;
    open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
    open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";

    print $OUT page_header("Branch Coverage for $source_file");
    print $OUT "<pre>";

    # filter out any call coverage lines.
    do_filter( sub { /^call/ } );

    print $OUT "</pre>";
    print $OUT page_footer();

    close($OUT);
    close($IN);

    $outfile = "$outfile_base.calls.html";
    print "Writing $outfile..\n" if $DEBUG;
    open( $IN,  "<", "$infile" )  or die "Can't read $infile: $!\n";
    open( $OUT, ">", "$outfile" ) or die "Can't write $outfile: $!\n";

    print $OUT page_header("Call Coverage for $source_file");
    print $OUT "<pre>";

    # filter out any branch coverage lines.
    do_filter( sub { /^branch/ } );

    print $OUT "</pre>";
    print $OUT page_footer();

    close($OUT);
    close($IN);

    return;

    sub do_filter {
        my ($skip_func) = @_;

        while (<$IN>) {
            s/&/&amp;/g;
            s/</&lt;/g;
            s/>/&gt;/g;

            next if ( &{$skip_func}($_) );

            my $atag = "";
            if (/^\s*([^\(\s]+)\(/) {
                $atag = "<a name=\"$1\"></a>";
            }

            my ($initial) = substr( $_, 0, 16 );
            if ( $initial =~ /^\s*\d+\s*$/ ) {
                print $OUT qq($atag<font color="green">$_</font>);
            }
            elsif ( $_ =~ /branch \d+ taken = 0%/ ) {
                print $OUT qq($atag<font color="red">$_</font>);
            }
            elsif ( $_ =~ /call \d+ returns = 0%/ ) {
                print $OUT qq($atag<font color="red">$_</font>);
            }
            elsif ( $_ =~ /^call \d+ never executed/ ) {
                print $OUT qq($atag<font color="red">$_</font>);
            }
            elsif ( $_ =~ /^branch \d+ never executed/ ) {
                print $OUT qq($atag<font color="red">$_</font>);
            }
            elsif ( $initial =~ /\#\#\#/ ) {
                print $OUT qq($atag<font color="red">$_</font>);
            }
            else {
                print $OUT $_;
            }
        }
    }
}

sub page_header {
    my ($title) = @_;

    qq(
        <html>
          <head>
             <title>$title</title>
          </head>
          <body bgcolor="white">
            <h1>$title</h1>
            <hr noshade>
    );
}

sub page_footer {
    "<hr noshade><i>Last Updated: @{[ scalar(localtime) . strftime(' (%Z)', localtime(time)) ]} </i>
     </body></html>";
}

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: