#!/usr/bin/perl -w

# Original coding: J.W. Lockhart <lockhart (at) redhat.com>

#################################
#  Usage: deja-summarize file1 [file2]
#         cat suitename.sum | deja-summarize
#  Where files are dejagnu test.sum output from one or two runs of the test suite.
#  Regression checking requires two input files.
#
#  Intent: to summarize test output from suites such as gdb and gcc,
#  and possibly spot any regressions from previous runs, if any such
#  results are available for comparison.
#
#  The scoring mechanism and weighting can be adjusted by 
#  editing the hashes below -- or you can use the rest of the summarized
#  output to come up with your own scheme.
##############################

$suiteName = '';
use vars qw($run1 $run2 $cur $res $ste $mdl $progName $fileCnt);
$passCnt = $failCnt = $xfailCnt = $kfailCnt = $unSupCnt = $errCnt = 0;
$unTestCnt = $unResCnt = $warnCnt = $kpassCnt = $xpassCnt = $suiteCnt = $fileCnt = 0;
$totalScore = 0;
$resultType = 'default';
$VERBOSE_SUM = 0;

# To get a meaningful score, make the base increase 
# or decrease sanely per type of test result.
# Note that these labels must match the %weights that follow.
%baseScores = (
	       'pass' => 1,
	       'fail' => (-2),
	       'xfail' => 0,
	       'kfail' => (-1),
	       'kpass' => (-1),
	       'xpass' => (-1),
	       'warning' => 0,
	       'brokentest' => (-10),
	       'ransuite' => 0,
	       'regression' => (-10),
 	       'unsupported' => 0,
 	       'untested' => 0,
 	       'unresolved' => 0,
	       'default' => 0,
	       );

# To make the differences between scores more noticeable
# and meaningful, define how important each type of test
# result is -- especially based on expected results,
# where you're likely to have 8,000 to 11,000 PASS results.
# Note that these labels must match the %baseScores above.
%weights = (
	    'pass' => 1,
	    'fail' => 2,
	    'xfail' => 0,
	    'kfail' => 1,
	    'kpass' => 1,
	    'xpass' => 1,
	    'warning' => 0,
	    'brokentest' => 5,
	    'ransuite' => 0,
	    'regression' => 10,
	    'unsupported' => 0,
	    'untested' => 0,
	    'unresolved' => 0,
	    'default' => 1,
	    );

# Names to print for the result summary
%lNames = (
	   pass => 'PASS',
	   fail => 'FAIL',
	   regression => 'REGRESSION',
	   ransuite => 'SUITES',
	   default =>  'default',
	   xfail => 'XFAIL',
	   kfail => 'KFAIL',
	   kpass => 'KPASS',
	   xpass => 'XPASS',
	   warning => 'WARN',
	   unsupported => 'UNSUPPORTED',
	   untested => 'UNTESTED',
	   unresolved => 'UNRESOLVED',
	   brokentest => 'ERROR',
	   );
# For later formatting use, figure out the longest of those displayed names.
$maxLen_lNames = 0;
for my $i (keys(%lNames)) {
    my $l = length($i);
    $maxLen_lNames = $l if ($l > $maxLen_lNames);
}

# Thus the actual amount that we will vary the score
# is given by (BASE * WEIGHT).
#
# TAG TYPES:
#    pass      - testcase returned PASS
#    fail      - testcase returned FAIL
#   xfail      - testcase returned an expected failure
#   kfail      - not sure; either known or kernel-caused failure, perhaps.
#   brokentest - testcase did not run correctly, generated 'ERROR' string
#   regression - testcase PASSed in first file, FAILed ('unexpected') in second
#    default   - any other result (Unsupported, or misc logfile output).

## FIXME: implement the 'regression' category.  This requires
## that we have 2 files as input rather than just one.
$fNameA = 'none';
$fNameB = 'none';

# refs/pointers to items of interest

$progName = $0;
$run1 = $run2 = $cur = $res = $ste = $mdl = '';

### [for those whose perl-fu is, well, python... ]
### One could think of the data structures this way, 
### if it adds any familiarity...
#    struct resultsFile {
#	String fileName;
#	struct suiteList *ste;
#	struct resultsCount *res;
#    }
#    struct suiteList {
#	String suiteName;
#	struct moduleList *mod;
#	struct resultsCount *res;
#    }
#    struct moduleList {
#	String moduleName;
#	String result;   // pass/fail etc
#	String moduleDetails;
#    }
#    struct resultsCount {
#        unsigned passCnt;
#        unsigned failCnt;
#        unsigned xfailCnt;
#        unsigned unSupCnt;
#        unsigned errCnt; 
#        unsigned testCnt;
#    }

sub newFile {
    my ($fn) = @_;
    my %r = ();
    my @tmpSuites = ();

    $r{filename} = $fn;
    $r{name} = $fn;
    $r{suites} = \@tmpSuites;
    $r{results} = &newResults;
    $r{total_score} = 0;
    $fileCnt++;

    return \%r;
}
sub newResults {
    my %tmpResCnt = ();

    for my $n (keys(%lNames)) {
	$tmpResCnt{$n} = 0;
    }

    return \%tmpResCnt;
}
################################################
# isBad - return 1 if string might indicate regression, 0 otherwise.
# These are results as found in %lNames that might indicate a regression.
# For example if the test used to pass, but now has this kind of result
# (fail or broken, or whatever).
sub isBad {
    my ($b) = @_;
    for my $bad qw(fail brokentest kfail) {
	return 1 if ($b eq $bad);
    }
    return 0;
}
#################################################
# incrResult
# increment the count of a given result type in a hashref
# result type as found in lNames; hashref must have member 'results'.
sub incrResult {
    my ($r, $rType) = @_;
    my $tmp = $r->{'results'};

    $tmp->{$rType} = $tmp->{$rType} + 1;
}

################################################
# newSuite - return hashref to an initialized Suite hash
sub newSuite {
    my ($sName) = @_;
    my %tmpSuite = ();
    my @tmpModules = ();

    $tmpSuite{name} = $sName;
    $tmpSuite{modules} = \@tmpModules;
    $tmpSuite{results} = &newResults;

    return \%tmpSuite;
}

##########################################################################
# findMod: find hashref to module 'm' in suite 's' of run 'r', or return ''.
sub findMod {
    my ($m, $s, $r) = @_;

    for my $st (@{$r->{suites}}) {
	if ($st->{name} eq $s->{name}) {
	    for my $md (@{$st->{modules}}) {
		if (($md->{name} eq $m->{name}) and ($md->{detail} eq $m->{detail})) {
		    return $md;
		}
	    }
	}
    }
    return '';
}
########################################################
# printMod: print out the result, name, and detail for a given test module.
sub printMod {
    my ($m) = @_;
    print $m->{result}, ": ", $m->{name}, ": ", $m->{detail}, "\n";
}

########################################################
# newModule - return ref to initialized new module hash
# inputs: 
#   n - module name (per %lNames)
#   r - test result 
#   d - test detail
# Example:
# FAIL: gdb.base/auxv.exp: generate native core dump
# $newM = newModule('fail', 'gdb.base/auxv.exp', 'generate native core dump');
sub newModule {
    my ($n,$r,$d) = @_;
    my %resRecord = ( 'name' => $n,
		      'result' => $r,
		      'detail' => $d,
		      );
    return \%resRecord;
}

########################################################
# doHelp - print out the usage
sub doHelp {
    print STDERR "Usage: $progName file1 ", '[file2]',"\n";
    print STDERR "       cat suitename.sum | $progName \n";
    print STDERR "Where files are dejagnu test.sum output from one or two runs of the test suite.\n";
    print STDERR "Regression checking requires two input files.\n";
}

########################################################
#      "MAIN" STARTS HERE
########################################################
if (($#ARGV >= 0) and ($ARGV[-1] =~ m|-+help|)) {
    # FIXME: should really have real option 
    # handling if we grow real options.
    doHelp();
    exit 0;
}

while (defined ($ln = <>)) {
    chomp($ln);
    if ($fNameA ne 'none') {
	if ($ARGV ne $cur->{filename}) {
	    ## RESET ALL POINTERS
	    die("cannot handle more than 2 files\n") if ($fNameB ne 'none');
	    $fNameB = $ARGV;
	    $run2 = newFile($ARGV);
	    $cur = $run2;
	    $cur->{filename} = $ARGV;
	    # print STDERR "New Input File: ", $cur->{filename}, "\n";
	}
    } else {
	$fNameA = $ARGV;
	$run1 = newFile($ARGV);
	$cur = $run1;
	$cur->{filename} = $ARGV;
	# print STDERR "New Input File: ", $cur->{filename}, "\n";
    }

    $resultType = 'default';
    # if ($ln =~ m|^PASS:\s+([^:]+):\s+(.*)|) {
    if ($ln =~ m|^PASS:\s+([^:[:space:]]+):*\s*(.*)|) {
	### Possible New Module for GDB-style output
	# PASS: gdb.base/assign.exp: continuing after dummy()
	$testName = $1;
	$testDetail = $2;
	$passCnt++;
	$resultType = 'pass';
	my $tempMod = newModule($testName,$resultType,$testDetail);
	$mdl = $tempMod;
	push @{$ste->{modules}}, $tempMod;
	print "ps: $testName with: $testDetail\n" if ($VERBOSE_SUM);
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    # } elsif ($ln =~ m|^FAIL:\s+([^:]+):\s+(.*)|) {
    } elsif ($ln =~ m|^FAIL:\s+([^:[:space:]]+):*\s*(.*)|) {
	### New Module
        # FAIL: gdb.base/auxv.exp: generate native core dump
	$failName = $1;
	$failDetail = $2;
	my ($steName, $modName) = split(m|/|, $failName, 2);
	print "fn: ste $steName / mod $modName with: $failDetail\n" if ($VERBOSE_SUM);
	$failCnt++;
	$resultType = 'fail';
	my $tempMod = newModule($failName,$resultType,$failDetail);
	push @{$ste->{modules}}, $tempMod;
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    # } elsif ($ln =~ m|^XFAIL:\s+([^:]+):\s+(.*)|) {
    } elsif ($ln =~ m|^XFAIL:\s+([^:[:space:]]+):*\s+(.*)|) {
	### New Module
	# XFAIL: gdb.base/list.exp: list line 1 with unlimited listsize
	$xfailName = $1;
	$xfailDetail = $2;
	print "xf: $xfailName with: $xfailDetail\n" if ($VERBOSE_SUM);
	$xfailCnt++;
	$resultType = 'xfail';
	my $tempMod = newModule($xfailName,$resultType,$xfailDetail);
	$mdl = $tempMod;
	push @{$ste->{modules}}, $tempMod;
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    # } elsif ($ln =~ m|^KFAIL:\s+([^:]+):\s+(.*)|) {
    } elsif ($ln =~ m|^KFAIL:\s+([^:[:space:]]+):*\s+(.*)|) {
	### New Module
	# KFAIL: gdb.threads/tls.exp: info address me (PRMS: gdb/1294)
	$kfailName = $1;
	$kfailDetail = $2;
	print "kf: $kfailName with: $kfailDetail\n" if ($VERBOSE_SUM);
	$kfailCnt++;
	$resultType = 'kfail';
	my $tempMod = newModule($kfailName,$resultType,$kfailDetail);
	$mdl = $tempMod;
	push @{$ste->{modules}}, $tempMod;
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    } elsif ($ln =~ m|^Running\s+(\.+/)*(\S+)\s+|) {
	### New Suite
	# Running ../../../gdb/testsuite/gdb.base/bitfields.exp ...
	my $foo = $2;
	$foo =~ s|gdb/testsuite/||g;
	my @tmpName = split(m|/|, $foo);
	my ($indx1, $indx2) = ($#tmpName, ($#tmpName - 1));
	$suiteName = $tmpName[$indx2];
	$moduleName = $tmpName[$indx1];
	print "suiteName: $suiteName :: moduleName: $moduleName\n" if ($VERBOSE_SUM);
	my $tempSuite = newSuite($suiteName);
	push @{$cur->{suites}}, $tempSuite;
	$ste = $tempSuite;
	$resultType = 'ransuite';
	$suiteCnt++;
	incrResult($cur, $resultType);
    } elsif ($ln =~ m|^UNSUPPORTED: (\S+)|) {
        # UNSUPPORTED: gdb.base/auxv.exp: info auxv on native core dump
	$unSupName = $1;
	print "unsup: $unSupName\n" if ($VERBOSE_SUM);
	$resultType = 'unsupported';
	$unSupCnt++;
	incrResult($cur, $resultType);
    } elsif ($ln =~ m|^UNTESTED: (\S+)|) {
        # UNSUPPORTED: gdb.base/auxv.exp: info auxv on native core dump
	$unSupName = $1;
	print "unsup: $unSupName\n" if ($VERBOSE_SUM);
	$resultType = 'untested';
	$unTestCnt++;
	incrResult($cur, $resultType);
    } elsif ($ln =~ m|^UNRESOLVED: (\S+)|) {
        # UNSUPPORTED: gdb.base/auxv.exp: info auxv on native core dump
	$unSupName = $1;
	print "unsup: $unSupName\n" if ($VERBOSE_SUM);
	$resultType = 'unresolved';
	$unResCnt++;
	incrResult($cur, $resultType);
    } elsif ($ln =~ m|^WARNING: (\S+)|) {
        # WARNING: Couldn't test self
	# e.g., fairly useless message.
	$unSupName = $1;
	print "warn: $unSupName\n" if ($VERBOSE_SUM);
	$resultType = 'warning';
	$warnCnt++;
	incrResult($cur, $resultType);
    # } elsif ($ln =~ m|^KPASS:\s+([^:]+):\s+(.*)|) {
    } elsif ($ln =~ m|^KPASS:\s+([^:[:space:]]+):*\s+(.*)|) {
	### Possible New Module
	# KPASS: gdb.base/sigstep.exp: continue on breakpoint, to handler entry; performing continue (PRMS gdb/1738)
	$testName = $1;
	$testDetail = $2;
	$kpassCnt++;
	$resultType = 'kpass';
	my $tempMod = newModule($testName,$resultType,$testDetail);
	$mdl = $tempMod;
	push @{$ste->{modules}}, $tempMod;
	print "kp: $testName with: $testDetail\n" if ($VERBOSE_SUM);
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    } elsif ($ln =~ m|^XPASS:\s+([^:[:space:]]+):*\s*(.*)|) {
	### Possible New Module
	# XPASS: gcc.dg/cpp/cmdlne-dI-M.c scan-file (^|\\n)cmdlne-dI-M.*:[^\\n]*cmdlne-dI-M.c
        # XPASS: gdb.mi/mi-var-display.exp: eval variable anone
	$testName = $1;
	$testDetail = $2;
	$xpassCnt++;
	$resultType = 'xpass';
	my $tempMod = newModule($testName,$resultType,$testDetail);
	$mdl = $tempMod;
	push @{$ste->{modules}}, $tempMod;
	print "xp: $testName with: $testDetail\n" if ($VERBOSE_SUM);
	incrResult($cur, $resultType);
	incrResult($ste, $resultType);
    } elsif (($ln =~ m|^ERROR:.*?(\S+testsuite\S+)|) || ($ln =~ m|^ERROR:\s+(.*)|)) {
        # ERROR: tcl error sourcing ../../../gdb/testsuite/gdb.base/attach-32.exp.
        # ERROR: couldn't execute "/usr/src/redhat/BUILD/gdb-6.3/build-x86_64-redhat-linux/gdb/testsuite/gdb.base/attach-32": no such file or directory
	$testError = $1;
	# $testFullError = $ln;
	print "test err: $testError\n" if ($VERBOSE_SUM);
	$errCnt++;
	$resultType = 'brokentest';
	incrResult($cur, $resultType);
    }  else {
	# miscellaneous stuff such as tcl tracebacks, blank lines, warnings, etc.
	$resultType = 'default';
	incrResult($cur, $resultType);
	# print STDERR "MISC: $ln\n" if ($VERBOSE_SUM);
    }
    $totalScore += ($baseScores{$resultType} * $weights{$resultType});
    $cur->{total_score} += ($baseScores{$resultType} * $weights{$resultType});
    $ln = '';
}

# print "SUITES: $suiteCnt\n";
# print "  PASS: $passCnt\n";
# print "  FAIL: $failCnt\n";
# print " XFAIL: $xfailCnt\n";
# print "   ERR: $errCnt\n";
# print "UNSUPP: $unSupCnt\n";
# print " SCORE: $totalScore\n";

if ($fileCnt > 1) {
    my $oldMod;
    my $banner = 0;
    for $ste (@{$run2->{suites}}) {
	for $mdl (@{$ste->{modules}}) {
	    if (isBad($mdl->{result})) {
		if ($oldMod = findMod($mdl,$ste,$run1)) {
		    if ($oldMod->{result} =~ m|pass|i) {
			$resultType = 'regression';
			incrResult($ste, $resultType);
			incrResult($run2, $resultType);
			$run2->{total_score} += ($baseScores{$resultType} * $weights{$resultType});
			print "\nREGRESSION INFO:\n" unless (++$banner > 1);
			printMod($oldMod);
			printMod($mdl);
		    }
		}
	    }
	}
    }
}

for my $run ($run1, $run2) {
    my $x = $run->{results};
    print "\nFilename: $run->{filename}\n";
    for my $y (keys(%$x)) {
	printf "%-${maxLen_lNames}s: %7d\n", $lNames{$y}, $x->{$y};
    }
    $x = $run->{suites};
    #printf STDERR "%8s: %7d\n", "SUITEDAT", $#{@$x};
    printf "%-${maxLen_lNames}s: %7d\n", "SCORE", $run->{total_score};
    last if (1 >= $fileCnt);
}