Cross Reference: /external/valgrind/main/auxprogs/nightly-build-summary

#!/usr/bin/env perl

#-----------------------------------------------------------------
# Quick and dirty script to summarize build information for a
# set of nightly runs.
#
# The results of the nighly regression runs are extracted from
# the GMANE mail archive. The URL for a given mail sent to the
# valgrind-developers mailing list is
#
#   http://article.gmane.org/gmane.comp.debugging.valgrind.devel/<integer>
#
# The script extracts information about the regression run from a
# block of information at the beginning of the mail. That information
# was added beginning October 4, 2011. Therefore, only regression runs
# from that date or later can be analyzed.
#
# There is unfortunately no good way of figuring out the interval
# of integers in the above URL that include all nightly regression
# runs.
#
# The function get_regtest_data does all the work. It returns a hash
# whose keys are the dates at which nightly runs took place. The value
# is in turn a hash.
#
# Each such hash has the following keys:
#   "builds"                 array of hashes
#   "num_builds"             int
#   "num_failing_builds"     int
#   "num_passing_builds"     int
#   "num_testcase_failures"  int
#   "num_failing_testcases"  int
#   "failure_frequency"      hash indexed by testcase name; value = int
#
# "builds" is an array of hashes with the following keys
#   "arch"                   string (architecture)
#   "distro"                 string (distribution, e.g. Fedora-15)
#   "failures"               array of strings (failing testcases)
#   "valgrind revision"      integer
#   "VEX revision"           integer
#   "GCC version"            string
#   "C library"              string
#   "uname -mrs"             string
#   "Vendor version"         string
#
#-----------------------------------------------------------------
use strict;
use warnings;

use LWP::Simple;
use Getopt::Long;

my $prog_name = "nightly-build-summary";

my $debug = 0;
my $keep  = 0;

my $usage=<<EOF;
USAGE

  $prog_name

     --from=INTEGER    beginning of mail interval; > 14800

    [--to=INTEGER]     end of mail interval; default = from + 100

    [--debug]          verbose mode (debugging)

    [--keep]           write individual emails to files (debugging)

    [--dump]           write results suitable for post-processing

    [--readable]       write results in human readable form (default)

EOF


#-----------------------------------------------------------------
# Search for a line indicating that this is an email containing
# the results of a valgrind regression run.
# Return 1, if found and 0 oherwise.
#-----------------------------------------------------------------
sub is_regtest_result {
    my (@lines) = @_;

    foreach my $line (@lines) {
        return 1 if ($line =~ "^valgrind revision:");
    }

    return 0;
}


#-----------------------------------------------------------------
# Extract information from the run. Don't prep the data here. This
# is done later on.
#-----------------------------------------------------------------
sub get_raw_data {
    my (@lines, $msgno) = @_;
    my ($i, $n, $line, $date);

    $n = scalar @lines;

    my %hash = ();

# 1) Locate the section with the info about the environment of this nightly run
    for ($i = 0; $i < $n; ++$i) {
        last if ($lines[$i] =~ /^valgrind revision:/);
    }
    die "no info block in message $msgno" if ($i == $n);

# 2) Read the info about the build: compiler, valgrind revision etc.
#    and put it into a hash.
    for ( ; $i < $n; ++$i) {
        $line = $lines[$i];
        last if ($line =~ /^$/);    # empty line indicates end of section
        my ($key, $value) = split(/:/, $line);
        $value =~ s/^[ ]*//;        # removing leading blanks
        $hash{$key} = $value;
    }

    if ($debug) {
        foreach my $key (keys %hash) {
            my ($val) = $hash{$key};
            print "regtest env: KEY = |$key|  VAL = |$val|\n";
        }
    }

# 3) Get the date from when the build was kicked off.
    for ( ; $i < $n; ++$i) {
        $line = $lines[$i];

        if ($line =~ /^Started at[ ]+([^ ]+)/) {
            $date = $1;
            print "DATE = $date\n";
            last;
        }
    }
    die "no date found in message $msgno" if ($i == $n);


# 4) Find out if the regression run failed or passed
    $hash{"failures"} = [];
    for ($i = $i + 1; $i < $n; ++$i) {
        $line = $lines[$i];
        if ($line =~ /Running regression tests/) {
            return %hash if ($line =~ /done$/);   # regtest succeeded; no failures
            die "cannot determine regtest outcome for message $msgno"
                if (! ($line =~ /failed$/));
            last;
        }
    }

# 5) Regtest failed; locate the section with the list of failing testcases
    for ($i = $i + 1; $i < $n; ++$i) {
        $line = $lines[$i];
# Match for end-of-line == because line might be split.
        last if ($line =~ /==$/);
    }
    die "cannot locate failing testcases in message $msgno" if ($i == $n);

# 6) Get list of failing testcases
    for ($i = $i + 1; $i < $n; ++$i) {
        $line = $lines[$i];

        last if ($line =~ /^$/);

        my ($testcase) = (split(/\s+/, $line))[0];
        print "ADD failing testcase $testcase\n" if ($debug);
        push @{$hash{"failures"}}, $testcase;
    }

    return ($date, %hash);
}


#-----------------------------------------------------------------
# Extract architecture; get a pretty name for the distro
#-----------------------------------------------------------------
sub prep_regtest_data {
    my (%hash) = @_;
    my ($val, $arch, $distro);

    $val = $hash{"uname -mrs"};
    die "uname -mrs info is missing" if (! defined $val);
    $arch = (split(/ /, $val))[2];

    $val = $hash{"Vendor version"};
    die "Vendor version info is missing" if (! defined $val);

    if ($val =~ /Fedora release ([0-9]+)/) {
        $distro = "Fedora-$1";
    } elsif ($val =~ /openSUSE ([0-9]+)\.([0-9]+)/) {
        $distro = "openSUSE-$1.$2";
    } elsif ($val =~ /SUSE Linux Enterprise Server 11 SP1/) {
        $distro = "SLES-11-SP1";
    } elsif ($val =~ /Red Hat Enterprise Linux AS release 4/) {
        $distro = "RHEL-4";
    } else {
        $distro = "UNKNOWN";
    }

# Add architecture and distribution to hash
    $hash{"arch"}   = $arch;
    $hash{"distro"} = $distro;

    return %hash;
}


#-----------------------------------------------------------------
# Precompute some summary information and record it
#-----------------------------------------------------------------
sub precompute_summary_info
{
    my (%dates) = @_;

    foreach my $date (sort keys %dates) {
        my %failure_frequency = ();

        my %nightly = %{ $dates{$date} };
        my @builds  = @{ $nightly{"builds"} };

        $nightly{"num_builds"} = scalar (@builds);
        $nightly{"num_failing_builds"} = 0;
        $nightly{"num_testcase_failures"} = 0;

        foreach my $build (@builds) {
            my %regtest_data   = %{ $build };

            my @failures = @{ $regtest_data{"failures"} };
            my $num_fail = scalar (@failures);

            ++$nightly{"num_failing_builds"} if ($num_fail != 0);
            $nightly{"num_testcase_failures"} += $num_fail;

# Compute how often a testcase failed
            foreach my $test ( @failures ) {
                if (defined $failure_frequency{$test}) {
                    ++$failure_frequency{$test};
                } else {
                    $failure_frequency{$test} = 1;
                }
            }
        }

        $nightly{"num_passing_builds"} =
            $nightly{"num_builds"} - $nightly{"num_failing_builds"};

        $nightly{"num_failing_testcases"} = scalar (keys %failure_frequency);

        $nightly{"failure_frequency"} = { %failure_frequency };

        $dates{$date} = { %nightly };
    }

    return %dates;
}


#-----------------------------------------------------------------
# Get messages from GMANE, and build up a database of results.
#-----------------------------------------------------------------
sub get_regtest_data {
    my ($from, $to) = @_;

    my $url_base = "http://article.gmane.org/gmane.comp.debugging.valgrind.devel/";

    my %dates = ();

    my $old_date = "-1";
    my @builds = ();

    for (my $i = $from; $i <= $to; ++$i) {
        my $url = "$url_base" . "$i";

	my $page = get("$url");

        if ($keep) {
            open (EMAIL, ">$i");
            print EMAIL  $page;
            close(EMAIL);
        }

# Detect if the article does not exist. Happens for too large --to= values
        last if ($page eq "No such file.\n");

# Split the page into lines
        my @lines = split(/\n/, $page);

# Check whether it contains a regression test result
        next if (! is_regtest_result(@lines));
        print "message $i is a regression test result\n" if ($debug);

# Get the raw data
        my ($date, %regtest_data) = get_raw_data(@lines);

        %regtest_data = prep_regtest_data(%regtest_data);

        if ($date ne $old_date) {
            my %nightly = ();
            $nightly{"builds"} = [ @builds ];
            $dates{$old_date} = { %nightly } if ($old_date ne "-1");

            $old_date = $date;
            @builds = ();
        }

        push @builds, { %regtest_data };
    }
    my %nightly = ();
    $nightly{"builds"} = [ @builds ];
    $dates{$old_date} = { %nightly } if ($old_date ne "-1");

# Convenience: precompute some info we'll be interested in
    %dates = precompute_summary_info( %dates );

    return %dates;
}


#-----------------------------------------------------------------
# Write out the results in a form suitable for automatic post-processing
#-----------------------------------------------------------------
sub dump_results {
    my (%dates) = @_;

    foreach my $date (sort keys %dates) {

        my %nightly = %{ $dates{$date} };
        my @builds  = @{ $nightly{"builds"} };

        foreach my $build (@builds) {
            my %regtest_data   = %{ $build };

            my $arch     = $regtest_data{"arch"};
            my $distro   = $regtest_data{"distro"};
            my @failures = @{ $regtest_data{"failures"} };
            my $num_fail = scalar (@failures);
            my $fails    = join(":", sort @failures);

            printf("Regrun: %s  %3d  %-10s %-20s %s\n",
                   $date, $num_fail, $arch, $distro, $fails);
        }

        my %failure_frequency = %{ $nightly{"failure_frequency"} };

        foreach my $test (keys %failure_frequency) {
            printf("Test:   %s  %3d  %s\n",
                   $date, $failure_frequency{$test}, $test);
        }

        printf("Total:  %s  builds: %d  %d fail  %d pass  tests: %d fail  %d unique\n",
               $date, $nightly{"num_builds"}, $nightly{"num_failing_builds"},
               $nightly{"num_passing_builds"}, $nightly{"num_testcase_failures"},
               $nightly{"num_failing_testcases"});
    }
}


sub write_readable_results {
    my (%dates) = @_;

    foreach my $date (sort keys %dates) {
        my %nightly = %{ $dates{$date} };

        print "$date\n----------\n";

        printf("%3d builds\n", $nightly{"num_builds"});
        printf("%3d builds fail\n", $nightly{"num_failing_builds"});
        printf("%3d builds pass\n", $nightly{"num_passing_builds"});
        print "\n";
        printf("%3d testcase failures (across all runs)\n",
               $nightly{"num_testcase_failures"});
        printf("%3d failing testcases (unique)\n",
               $nightly{"num_failing_testcases"});
        print "\n";

        my @builds  = @{ $nightly{"builds"} };

        if ($nightly{"num_passing_builds"} != 0) {
            print "Passing builds\n";
            print "--------------\n";
            foreach my $build (@builds) {
                my %regtest_data = %{ $build };
                my @failures     = @{ $regtest_data{"failures"} };
                my $num_fail     = scalar (@failures);

                if ($num_fail == 0) {
                    my $arch   = $regtest_data{"arch"};
                    my $distro = $regtest_data{"distro"};

                    printf("%-8s %-15s\n", $arch, $distro);
                }
                print "\n";
            }
            print "\n";
        }

        if ($nightly{"num_failing_builds"} != 0) {
            print "Failing builds\n";
            print "--------------\n";
            foreach my $build (@builds) {
                my %regtest_data = %{ $build };
                my @failures     = @{ $regtest_data{"failures"} };
                my $num_fail     = scalar (@failures);

                if ($num_fail != 0) {
                    my $arch     = $regtest_data{"arch"};
                    my $distro   = $regtest_data{"distro"};

                    printf("%-8s %-15s %d failures\n", $arch, $distro, $num_fail);
                    foreach my $test (@failures) {
                        print "         $test\n";
                    }
                    print "\n";
                }
            }
            print "\n";
        }

        print "Failing testcases and their frequency\n";
        print "-------------------------------------\n";
        my %failure_frequency = %{ $nightly{"failure_frequency"} };

# Sorted in decreasing frequency
        foreach my $test (sort {$failure_frequency{$b} cmp $failure_frequency{$a} }
                          keys %failure_frequency) {
            printf("%3d  %s\n", $failure_frequency{$test}, $test);
        }
        print "\n";
    }
}


sub main
{
    my ($from, $to, $dump, $readable);

    $from = $to = 0;
    $dump = $readable = 0;

    GetOptions( "from=i"   => \$from,
                "to=i"     => \$to,
                "debug"    => \$debug,
                "dump"     => \$dump,
                "keep"     => \$keep,
                "readable" => \$readable
        ) || die $usage;

# 14800 is about Oct 4, 2011 which is when we began including information
# about the environment

    die $usage if ($from < 14800);

    $to = $from + 100 if ($to == 0);

    if ($from > $to) {
        print STDERR "*** invalid [from,to] interval. Try again\n";
        die $usage;
    }

    $readable = 1 if ($dump == 0 && $readable == 0);

    print "check message interval [$from...$to]\n" if ($debug);

# Get mails from GMANE mail archive

    my %dates = get_regtest_data($from, $to);

    dump_results(%dates) if ($dump);

    write_readable_results(%dates) if ($readable);
}

main();

exit 0;