run-tests

#!/usr/bin/perl
# PODNAME: run-tests
# test script launcher for PrefVote preference voting system

use Modern::Perl qw(2013); # require 5.16.0 or later
use autodie;
use Carp qw(croak);
use Config;
use English;
use Cwd;
use Readonly;
use Getopt::Long;
use FindBin;
use File::Basename;
use Term::ANSIColor;
use IO::Interactive qw(is_interactive);
use IPC::Run qw(run);
use TAP::Parser qw/all/;
use TAP::Parser::Aggregator qw/all/;
use TAP::Parser::SourceHandler::RawTAP;
use Text::Table::Tiny 1.02 qw/ generate_table /;
use HTML::Escape qw(escape_html);

# configuration settings per language implementation
Readonly::Scalar my $pvroot => dirname($FindBin::RealBin);
Readonly::Array my @supported_languages => (qw(perl rust));
Readonly::Array my @supported_methods => (qw(Core STV Schulze RankedPairs));
Readonly::Hash my %config => (
    methods => {
        Core => 'PrefVote core - for testing only',
        STV => 'Single Transferable Vote (STV)',
        Schulze => 'Schulze/Beatpath',
        RankedPairs => "Ranked Pairs",
    },
    blackbox => {
        name => "black box tests",
        data => '${pvroot}/test/inputs',
        test_re => qr{\.(yaml|yml)$},
    },
    perl => {
        name => "Perl",
        build => 'dzil build',
        whitebox => {
            dirs => {
                Core => '${pvroot}/src/perl/prefvote',
                STV => '${pvroot}/src/perl/stv',
                Schulze => '${pvroot}/src/perl/schulze',
                RankedPairs => '${pvroot}/src/perl/rankedpairs',
            },
            testdir => "t",
            test_re => qr{\.t$},
            tp_args => [switches => ['-Isrc/perl/prefvote/lib', '-Ilib']],
        },
        prove_params => "--lib",
        blackbox => {
            env => {
                PERL5LIB => '${cwd}/prefvote/lib:${cwd}/stv/lib:${env/PERL5LIB}',
            },
            cmd => [ '${pvroot}/src/perl/prefvote/bin/vote-count', "--test", '--method=${var/method}'],
            tp_args => [switches => ['-Isrc/perl/prefvote/lib', '-Isrc/perl/stv/lib']],
        }
    },
    rust => {
        name => "Rust",
    },
);
Readonly::Scalar my $not_available => "\N{MATHEMATICAL SANS-SERIF BOLD DIGIT ZERO}";

# save original working directory (before any chdirs)
Readonly::Scalar my $orig_cwd => getcwd();

# test result text coloring for Test::Harness
Readonly::Hash my %callbacks => (
    test => sub {
        my $test = shift;
        if ( $test->is_ok && not $test->directive ) {
            # normal passing test
            print color 'green';
        }
        elsif ( !$test->is_ok ) {    # even if it's TODO
            print color 'red';
        }
        elsif ( $test->has_skip ) {
            print color 'white on_blue';

        }
        elsif ( $test->has_todo ) {
            print color 'white';
        }
    },
    ELSE => sub {
        # plan, comment, and so on (anything which isn't a test line)
        print color 'bright_blue';
    },
    ALL => sub {
        # now print them
        print shift->as_string;
        print color 'reset';
        print "\n";
    },
);

#
# result summary processing
#
my %results;

# create box & language headings in results
sub touch_result
{
    my ($box, $lang_set) = @_;
    if (not exists $results{$box}) {
        $results{$box} = {};
    }
    if (not exists $results{$box}{$lang_set}) {
        $results{$box}{$lang_set} = {};
    }
    return;
}

# save test result by language and method
sub save_result
{
    my ($box, $lang_set, $method, $plan, $pass, $fail) = @_;
    touch_result($box, $lang_set); # make sure the result row exists
    if (not exists $results{$box}{$lang_set}{$method}) {
        $results{$box}{$lang_set}{$method} = {plan => $plan, pass => $pass, fail => $fail};
    } else {
        $results{$box}{$lang_set}{$method}{plan} += $plan;
        $results{$box}{$lang_set}{$method}{pass} += $pass;
        $results{$box}{$lang_set}{$method}{fail} += $fail;
    }
}

# print table in Markdown
sub markdown_table
{
    my %opts = @_;
    my $rows = $opts{rows};

    # generate header from first row
    if ($opts{header_row} // 0) {
        my $header = shift @$rows;
        say "| ".join(" | ", @$header)." |";
        say "|".("---|" x scalar @$header);
    }

    # generate table from remainder of rows
    foreach my $row (@$rows) {
        say "| ".join(" | ", @$row)." |";
    }
    say;
    return;
}

# print table in HTML
sub html_table
{
    my %opts = @_;
    my $rows = $opts{rows};

    # table heading
    say "<table>";

    # generate header from first row
    if ($opts{header_row} // 0) {
        my $header = shift @$rows;
        say "<thead>";
        say "<tr>";
        foreach my $col_item (@$header) {
            say "<th>".escape_html($col_item)."</th>";
        }
        say "</tr>";
        say "</thead>";
    }

    # generate table from remainder of rows
    say "<tbody>";
    foreach my $row (@$rows) {
        say "<tr>";
        foreach my $col_item (@$row) {
            say "<td>".escape_html($col_item)."</td>";
        }
        say "</tr>";
    }
    say "</tbody>";
    say "</table>";
    return;
}

# print table of results by set/language and method
sub print_result_table
{
    my $format = shift;
    my @out_table = (["language/set", @supported_methods, "total"]);
    my %column_totals;

    # set up for table generation
    binmode(STDOUT, ':encoding(UTF-8)');

    # zero out column totals
    foreach my $method (@supported_methods) {
        $column_totals{$method}{plan} = 0;
        $column_totals{$method}{pass} = 0;
        $column_totals{$method}{fail} = 0;
    }

    # loop through white/black box, language and method filling results table and totals
    foreach my $box (qw(whitebox blackbox)) {
        foreach my $lang_set (@supported_languages) {
            if (exists $results{$box}{$lang_set}) {
                my $name = $config{$lang_set}{name}." ".$box;
                my @row_data = ($name);
                my ($row_plan, $row_pass, $row_fail) = (0, 0, 0);
                foreach my $method (@supported_methods) {
                    if (not exists $results{$box}{$lang_set}{$method}) {
                        push @row_data, $not_available;
                        next;
                    }
                    push @row_data, sprintf( "%d/%d/%d",
                        $results{$box}{$lang_set}{$method}{plan} // 0,
                        $results{$box}{$lang_set}{$method}{pass} // 0,
                        $results{$box}{$lang_set}{$method}{fail} // 0);
                    $row_plan += $results{$box}{$lang_set}{$method}{plan} // 0;
                    $row_pass += $results{$box}{$lang_set}{$method}{pass} // 0;
                    $row_fail += $results{$box}{$lang_set}{$method}{fail} // 0;
                    $column_totals{$method}{plan} += $results{$box}{$lang_set}{$method}{plan} // 0;
                    $column_totals{$method}{pass} += $results{$box}{$lang_set}{$method}{pass} // 0;
                    $column_totals{$method}{fail} += $results{$box}{$lang_set}{$method}{fail} // 0;
                }
                push @row_data, sprintf( "%s/%s/%s", $row_plan, $row_pass, $row_fail);
                push @out_table, \@row_data;
            }
        }
    }

    # generate totals line at bottom
    my @totals_row = ('total');
    my $total_plan = 0;
    my $total_pass = 0;
    my $total_fail = 0;
    foreach my $method (@supported_methods) {
        push @totals_row, sprintf( "%d/%d/%d",
            $column_totals{$method}{plan} // 0,
            $column_totals{$method}{pass} // 0,
            $column_totals{$method}{fail} // 0);
        $total_plan += $column_totals{$method}{plan};
        $total_pass += $column_totals{$method}{pass};
        $total_fail += $column_totals{$method}{fail};

    }
    push @totals_row, sprintf( "%s/%s/%s", $total_plan, $total_pass, $total_fail);
    push @out_table, \@totals_row;

    # format output table
    if (lc $format eq "text") {
        say generate_table(rows => \@out_table, header_row => 1, style => 'boxrule');
        return;
    }
    if (lc $format eq "markdown") {
        say markdown_table(rows => \@out_table, header_row => 1);
        return;
    }
    if (lc $format eq "html") {
        say html_table(rows => \@out_table, header_row => 1);
        return;
    }
    croak "unrecognized format type $format";
}

# string substitution query (used by str_expand)
sub str_subst
{
    my $query = shift;
    my $vars = shift;
    my @query_parts = split '/', $query;

    # environment variable lookup
    if ($query_parts[0] eq 'env') {
        return $ENV{$query_parts[1]} // "";
    }

    # perl configuration lookup
    if ($query_parts[0] eq 'perl') {
        return Config($query_parts[1]);
    }

    # program configuration lookup
    if ($query_parts[0] eq 'prog') {
        shift @query_parts;
        my $configref = \%config;
        while (ref $configref eq "HASH") {
            my $key = shift @query_parts;
            if (not exists $configref->{$key}) {
                return "";
            }
            $configref = $configref->{$key};
        }
        return $configref;
    }

    # program configuration lookup
    if ($query_parts[0] eq 'var') {
        if (ref $vars eq "HASH") {
            return $vars->{$query_parts[1]} // "";
        }
        return "";
    }

    # current working directory (as of program start)
    if ($query_parts[0] eq 'cwd') {
        return $orig_cwd;
    }

    # PrefVote root directory
    if ($query_parts[0] eq 'pvroot') {
        return $pvroot;
    }

    # default to blank
    return "";
}

# simple string expansion utility
sub str_expand
{
    my $in_str = shift;
    my $vars = shift;
    my $out_str = "";
    my $pos = 0;

    # scan through string looking for escapes '\' or expansions '$'
    while ($pos < length $in_str) {
        my $slash = index($in_str, '\\', $pos);
        my $dollar = index($in_str, '$', $pos);

        # if next backslash occurs before dollar sign, process the escape
        if ($slash>=0 and ($dollar==-1 or $slash<$dollar)) {
            $out_str .= substr($in_str, $pos, $slash-$pos);
            $pos = $slash+1;
            if ($pos > length $in_str) {
                $out_str .= '\\';
                last;
            }
            $out_str .= substr($in_str, $pos-1, 1);
            next;
        }

        # check first occurrence of a dollar sign in the remainder of the string for a variable expansion
        if ($dollar>=0) {
            $out_str .= substr($in_str, $pos, $dollar-$pos);
            if (substr($in_str, $dollar) =~ m/^\$\{([^}]+)\}/x) {
                my $query = $1;
                my $len = length $query;
                my $subst = str_subst($query, $vars);
                $pos = $dollar + $len + 3;
                $out_str .= $subst;
            } else {
                $pos++;
            }
            next;
        }

        # no slash or dollar - consume the rest of the string
        $out_str .= substr($in_str, $pos);
        last;
    }
    return $out_str;
}

# search directory for test files
sub find_test_files
{
    my ($dir, $test_re) = @_;

    # find test scripts in subdirectories
    #say STDERR "find_test_file ($dir, $test_re)";
    opendir(my $dh, "$dir")
        or croak "Can't open $dir: $! (cwd=".getcwd().")";
    my @all = grep { $_ !~ /^\./ } readdir($dh);
    closedir $dh;
    my @files;
    foreach my $name (sort @all) {
        my $path = $dir."/".$name;
        if (-f $path and $path =~ $test_re) {
            push @files, $path;
        } elsif (-d $path) {
            push @files, find_test_files($path, $test_re);
        }
    }
    #say STDERR "find_test_file $dir -> : ".join(" ", @files);

    return @files;
}

# run whitebox (unit) tests
sub run_whitebox_tests
{
    my %opts = @_;
    my $lang = $opts{lang};
    my $agg = $opts{agg};
    my $method = $opts{method};

    # loop through whitebox test scripts for this method
    if (not exists $config{$lang}{whitebox}) {
        touch_result("whitebox", $lang); # make sure the result row exists
        warn "whitebox tests not configured for language $lang";
        return;
    }
    my $dir = str_expand($config{$lang}{whitebox}{dirs}{$method}, \%opts);
    defined $dir or next;
    ( -d "$dir" ) or croak "configure whitebox testing directory $dir is not a directory";
    chdir $dir;
    my $testdir = str_expand($config{$lang}{whitebox}{testdir}, \%opts);
    my $test_re = $config{$lang}{whitebox}{test_re};
    if ( -d $testdir ) {
        # enter whitebox test directory and find test scripts
        my @files = find_test_files($testdir, $test_re);

        # run tests
        foreach my $file (@files) {
            (-f $file) or next;
            say "running whitebox tests: $dir/$file";
            my $parser = TAP::Parser->new({
                source => $file,
                @{$config{$lang}{whitebox}{tp_args}},
                (is_interactive() ? (callbacks => \%callbacks) : ()),
            });
            while ( my $result = $parser->next ) {
                if (not is_interactive()) {
                    say $result->as_string;
                }
            }
            printf "Planned: %s\nPassed: %s\nFailed: %s\n\n",
                $parser->tests_planned, scalar $parser->passed, scalar $parser->failed;
            save_result("whitebox", $lang, $method, $parser->tests_planned, scalar $parser->passed,
                scalar $parser->failed);
            $agg->add($file, $parser);
        }
    } else {
        croak("test (t) directory not found in configured directory $dir");
    }
    chdir $orig_cwd;
    return;
}

# run blackbox tests (applicable across languages, can't use knowledge of implementation)
sub run_blackbox_tests
{
    my %opts = @_;
    my $lang = $opts{lang};
    my $agg = $opts{agg};
    my $method = $opts{method};

    # collect blackbox test parameters for selected language
    if (not exists $config{$lang}{blackbox}) {
        touch_result("blackbox", $lang); # make sure the result row exists
        warn "blackbox tests not configured for language $lang";
        return;
    }
    if (not exists $config{$lang}{blackbox}{cmd}) {
        croak "blackbox test command not configured for language $lang";
    }
    if (ref $config{$lang}{blackbox}{cmd} ne "ARRAY") {
        croak "blackbox test command improperly configured for language $lang - not an ARRAY ref";
    }
    my @blackbox_cmd = @{$config{$lang}{blackbox}{cmd}};
    my $blackbox_env = $config{$lang}{blackbox}{env} // {};
    # TODO add language-specific blackbox test build parameters here

    # enter blackbox test directory and find test data files
    my $testdir = str_expand($config{blackbox}{data}, \%opts);
    my $test_re = $config{blackbox}{test_re};
    my @test_files = find_test_files($testdir, $test_re);

    # run blackbox tests for the selected language on the test data
    foreach my $test_file (@test_files) {
        (-f $test_file) or next;
        say "running blackbox tests: $method on $test_file";

        # run the blackbox tests in the selected language
        my $bbt_out;
        run [map {str_expand($_, \%opts)} @blackbox_cmd, $test_file],
            \undef, \$bbt_out,
            init => sub { foreach my $key (keys %$blackbox_env)
                {$ENV{$key} = str_expand($blackbox_env->{$key}, \%opts)}
            };

        # skip files with no tests
        if (length $bbt_out == 0) {
            is_interactive() and print color 'bright_blue';
            say "No tests";
            is_interactive() and print color 'reset';
            say "";
            next;
        }

        # parse the TAP output
        my $parser = TAP::Parser->new({
            source => $bbt_out,
            @{$config{$lang}{blackbox}{tp_args}},
            (is_interactive() ? (callbacks => \%callbacks) : ()),
        });
        while ( my $result = $parser->next ) {
            if (not is_interactive()) {
                say $result->as_string;
            }
        }
        printf "Planned: %s\nPassed: %s\nFailed: %s\n\n",
            $parser->tests_planned, scalar $parser->passed, scalar $parser->failed;
        save_result("blackbox", $lang, $method, $parser->tests_planned, scalar $parser->passed,
            scalar $parser->failed);
        $agg->add("$method: $test_file", $parser);
    }
    chdir $orig_cwd;
}

# process command-line
my (@language, @method, $whitebox, $blackbox, $all, $format);
GetOptions("language:s" => \@language, "method:s" =>\@method, "whitebox|white|w" => \$whitebox,
    "blackbox|black|b" => \$blackbox, "all" => \$all, "format:s" => \$format);

#
# run tests as selected
#

# aggregator collects results from all tests
my $aggregate = TAP::Parser::Aggregator->new(
);

# process --all
if ($all) {
    $whitebox = 1;
    $blackbox = 1;
    @language = @supported_languages;
    @method = @supported_methods;
}

# whitebox and blackbox tests within each language implementation's sources
{
    local $ENV{PREFVOTE_ROOT} = $orig_cwd; # unit tests must look for this and run relative to the project root

    # loop through selected languages for whitebox tests
    foreach my $lang (@language) {
        # do whitebox tests first
        if ($whitebox) {
            foreach my $method (@method) {
                run_whitebox_tests(lang => $lang, agg => $aggregate, method => $method);
            }
        }

        # do blackbox tests last
        if ($blackbox) {
            foreach my $method (@method) {
                run_blackbox_tests(lang => $lang, agg => $aggregate, method => $method);
            }
        }
    }
}

# print results
if (defined $format) {
    print_result_table($format);
} else {
    printf "Total: %s\nPlanned: %s\nPassed: %s\nFailed: %s\n",
        $aggregate->total, scalar $aggregate->planned, scalar $aggregate->passed, scalar $aggregate->failed;
}