#!/usr/bin/env perl
#
# WvTest:
#   Copyright (C) 2007-2009 Versabanq Innovations Inc. and contributors.
#   Copyright (C) 2015 Rob Browning <rlb@defaultvalue.org>
#       Licensed under the GNU Library General Public License, version 2.
#       See the included file named LICENSE for license information.
#
use strict;
use warnings;
use Getopt::Long qw(GetOptionsFromArray :config no_ignore_case bundling);
use Pod::Usage;
use Time::HiRes qw(time);

my $per_test_warn_time = 100000;  # upstream was 500
my $per_test_bad_time = 100000;  # upstream was 1000
my $overall_test_warn_time = 100000;  # upstream was 2000
my $overall_test_bad_time = 100000;  # upstream was 5000

my $pid;
my $istty = -t STDOUT;
my @log = ();

sub bigkill($)
{
    my $pid = shift;

    if (@log) {
	print "\n" . join("\n", @log) . "\n";
    }

    print STDERR "\n! Killed by signal    FAILED\n";

    ($pid > 0) || die("pid is '$pid'?!\n");

    local $SIG{CHLD} = sub { }; # this will wake us from sleep() faster
    kill 15, $pid;
    sleep(2);

    if ($pid > 1) {
	kill 9, -$pid;
    }
    kill 9, $pid;

    exit(125);
}

sub colourize($)
{
    my $result = shift;
    my $pass = ($result eq "ok");

    if ($istty) {
	my $colour = $pass ? "\e[32;1m" : "\e[31;1m";
	return "$colour$result\e[0m";
    } else {
	return $result;
    }
}

sub mstime($$$)
{
    my ($floatsec, $warntime, $badtime) = @_;
    my $ms = int($floatsec * 1000);
    my $str = sprintf("%d.%03ds", $ms/1000, $ms % 1000);

    if ($istty && $ms > $badtime) {
        return "\e[31;1m$str\e[0m";
    } elsif ($istty && $ms > $warntime) {
        return "\e[33;1m$str\e[0m";
    } else {
        return "$str";
    }
}

sub resultline($$)
{
    my ($name, $result) = @_;
    return sprintf("! %-65s %s", $name, colourize($result));
}

my ($start, $stop);

sub endsect()
{
    $stop = time();
    if ($start) {
	printf " %s %s\n",
            mstime($stop - $start, $per_test_warn_time, $per_test_bad_time),
            colourize("ok");
    }
}

sub run
{
    # dup_msgs should be true when "watching".  In that case all top
    # level wvtest protocol messages should be duplicated to stderr so
    # that they can be safely captured for report to process later.
    my ($dup_msgs) = @_;
    my $show_counts = 1;
    GetOptionsFromArray(\@ARGV, 'counts!', \$show_counts)
        or pod2usage();
    pod2usage('$0: no command specified') if (@ARGV < 1);

    # always flush
    $| = 1;

    {
        my $msg = "Testing \"all\" in @ARGV:\n";
        print $msg;
        print STDERR $msg if $dup_msgs;
    }

    $pid = open(my $fh, "-|");
    if (!$pid) {
        # child
        setpgrp();
        open STDERR, '>&STDOUT' or die("Can't dup stdout: $!\n");
        exec(@ARGV);
        exit 126; # just in case
    }

    # parent
    my $allstart = time();
    local $SIG{INT} = sub { bigkill($pid); };
    local $SIG{TERM} = sub { bigkill($pid); };
    local $SIG{ALRM} = sub {
        print STDERR resultline('Alarm timed out!  No test results for too long.\n',
                                'FAILED');
        bigkill($pid);
    };

    my ($gpasses, $gfails) = (0,0);
    while (<$fh>)
    {
        chomp;
        s/\r//g;

        if (/^\s*Testing "(.*)" in (.*):\s*$/)
        {
            alarm(300);
            my ($sect, $file) = ($1, $2);

            endsect();

            printf("! %s  %s: ", $file, $sect);
            @log = ();
            $start = $stop;
        }
        elsif (/^!\s*(.*?)\s+(\S+)\s*$/)
        {
            alarm(300);

            my ($name, $result) = ($1, $2);
            my $pass = ($result eq "ok");

            if (!$start) {
                printf("\n! Startup: ");
                $start = time();
            }

            push @log, resultline($name, $result);

            if (!$pass) {
                $gfails++;
                if (@log) {
                    print "\n" . join("\n", @log) . "\n";
                    @log = ();
                }
            } else {
                $gpasses++;
                print ".";
            }
        }
        else
        {
            push @log, $_;
        }
    }

    endsect();

    my $newpid = waitpid($pid, 0);
    if ($newpid != $pid) {
        die("waitpid returned '$newpid', expected '$pid'\n");
    }

    my $code = $?;
    my $ret = ($code >> 8);

    # return death-from-signal exits as >128.  This is what bash does if you ran
    # the program directly.
    if ($code && !$ret) { $ret = $code | 128; }

    if ($ret && @log) {
        print "\n" . join("\n", @log) . "\n";
    }

    if ($code != 0) {
        my $msg = resultline("Program returned non-zero exit code ($ret)",
                             'FAILED');
        print $msg;
        print STDERR "$msg\n" if $dup_msgs;
    }

    print "\n";
    if ($show_counts) {
        my $gtotal = $gpasses + $gfails;
        my $msg = sprintf("WvTest: %d test%s, %d failure%s\n",
                          $gtotal, $gtotal == 1 ? "" : "s", $gfails,
                          $gfails == 1 ? "" : "s");
        print $msg;
        print STDERR $msg if $dup_msgs;
    }
    {
        my $msg = sprintf("WvTest: result code $ret, total time %s\n",
                          mstime(time() - $allstart,
                                 $overall_test_warn_time,
                                 $overall_test_bad_time));
        print $msg;
        print STDERR $msg if $dup_msgs;
    }
    return ($ret ? $ret : ($gfails ? 125 : 0));
}

sub report()
{
    my ($gpasses, $gfails) = (0,0);
    for my $f (@ARGV)
    {
        my $fh;
        open($fh, '<:crlf', $f) or die "Unable to open $f: $!";
        while (<$fh>)
        {
            chomp;
            s/\r//g;

            if (/^\s*Testing "(.*)" in (.*):\s*$/) {
                @log = ();
            }
            elsif (/^!\s*(.*?)\s+(\S+)\s*$/) {
                my ($name, $result) = ($1, $2);
                my $pass = ($result eq "ok");
                push @log, resultline($name, $result);
                if (!$pass) {
                    $gfails++;
                    if (@log) {
                        print "\n" . join("\n", @log) . "\n";
                        @log = ();
                    }
                } else {
                    $gpasses++;
                }
            }
            else
            {
                push @log, $_;
            }
        }
    }
    my $gtotal = $gpasses + $gfails;
    printf("\nWvTest: %d test%s, %d failure%s\n",
           $gtotal, $gtotal == 1 ? "" : "s",
           $gfails, $gfails == 1 ? "" : "s");
    return ($gfails ? 125 : 0);
}

my ($show_help, $show_manual);
Getopt::Long::Configure('no_permute');
GetOptionsFromArray(\@ARGV,
                    'help|?' => \$show_help,
                    'man' => \$show_manual) or pod2usage();
Getopt::Long::Configure('permute');
pod2usage(-verbose => 1, -exitval => 0) if $show_help;
pod2usage(-verbose => 2, -exitval => 0) if $show_manual;
pod2usage(-msg => "$0: no action specified", -verbose => 1) if (@ARGV < 1);

my $action = $ARGV[0];
shift @ARGV;
if ($action eq 'run') { exit run(0); }
elsif ($action  eq 'watch') { run(1); }
elsif ($action  eq 'report') { exit report(); }
else { pod2usage(-msg => "$0: invalid action $action", -verbose => 1); }

__END__

=head1 NAME

wvtest - the dumbest cross-platform test framework that could possibly work

=head1 SYNOPSIS

  wvtest [GLOBAL...] run [RUN_OPT...] [--] command [arg...]
  wvtest [GLOBAL...] watch [RUN_OPT...] [--] command [arg...]
  wvtest [GLOBAL...] report [logfile...]

  GLOBAL:
    --help, -?       display brief help message and exit
    --man            display full documentation
  RUN_OPT:
    --[no-]counts    [don't] show success/failure counts

=head1 DESCRIPTION

B<wvtest run some-tests> will run some-tests and report on the result.
This should work fine as long as some-tests doesn't run any sub-tests
in parallel.

If you'd like to run your tests in parallel, use B<watch> and
B<report> as described in the EXAMPLES below.

=head1 EXAMPLES

  # Fine if ./tests doesn't produce any output in parallel.
  wvtest run ./tests

  # Use watch and report for parallel tests.  Note that watch's stderr will
  # include copies of any top level messages - reporting non-zero
  # test command exits, etc., and so must be included in the report arguments.
  wvtest watch --no-counts \
    "sh -c '(test-1 2>&1 | tee test-1.log)& (test-2 2>&1 | tee test-2.log)&'" \
    2>test-3.log \
  wvtest report test-1.log test-2.log test-3.log

=cut