runtests

#!/usr/bin/env perl

use v5.16;

use warnings;
use strict;

use FindBin qw($RealBin);
use lib "$RealBin/../lib";

use Getopt::Long qw(GetOptionsFromArray);

use Plang::Constants::Instructions ':all';

STDOUT->autoflush(1);

my $usage = <<"USAGE";
usage: $0 [file...] [-n]

    -n|--name   print file names of each test file
USAGE

sub getopt_from_array {
    my ($opt_args, $result, $config, @opts) = @_;
    # emitting errors as Perl warnings instead of using die, weird.
    my $opt_error;
    local $SIG{__WARN__} = sub {
        $opt_error = shift;
        chomp $opt_error;
    };

    Getopt::Long::Configure(@$config);
    GetOptionsFromArray($opt_args, $result, @opts);
    return ($opt_args, $opt_error);
}

my %opts;

my ($opt_args, $opt_error) = getopt_from_array(
    \@ARGV,
    \%opts,
    ['bundling'],
    'names|n',
);

if (defined $opt_error) {
    print "$opt_error -- $usage\n";
    exit 1;
}

my $test_file;   # current test filename
my @passed;      # passed tests
my @failed;      # failed tests

my $output;      # stdout output from Plang program

# create our $plang object in embedded mode
use Plang::Interpreter;

my $plang = Plang::Interpreter->new(
    embedded => 1,
    debug    => $ENV{DEBUG},
    modpath  => ["$RealBin/../modules/", "$RealBin/../test/modules/"],
);

# override the Plang builtin `print` function so we can collect
# the output for testing, instead of printing it
$plang->add_builtin_function('print',
    # these are the parameters we want: `expr` and `end`.
    # `expr` has no default value; `end` has default value [String, "\n"]
    [[['TYPE', 'Any'], 'expr', undef], [['TYPE', 'String'], 'end', [INSTR_LITERAL, ['TYPE', 'String'], "\n"]]],
    # the type of value print() returns
    ['TYPE', 'Null'],
    # subref to our function that will override the `print` function
    \&print_override,
    \&print_validator);

# our overridden `print` function
sub print_override {
    my ($plang, $scope, $name, $arguments) = @_;
    my ($expr, $end) = ($plang->output_value($scope, $arguments->[0]), $arguments->[1]->[1]);
    $output .= "$expr$end"; # append the print output to our $output
    return [['TYPE', 'Null'], undef];
}

# validation of print() function (type-checking, etc)
sub print_validator {
    return [['TYPE', 'Null'], undef];
}

# add a `dprint` function so we can print debug messages during tests (since print is overridden)
$plang->add_builtin_function('dprint',
    [[['TYPE', 'Any'], 'expr', undef], [['TYPE', 'String'], 'end', [INSTR_LITERAL, ['TYPE', 'String'], "\n"]]],
    ['TYPE', 'Null'],
    \&func_dprint,
    \&func_dprint_validator);

sub func_dprint {
    my ($plang, $scope, $name, $arguments) = @_;
    my ($expr, $end) = ($plang->output_value($scope, $arguments->[0]), $arguments->[1]->[1]);
    print "$expr$end";
    return [['TYPE', 'Null'], undef];
}

sub func_dprint_validator {
    return [['TYPE', 'Null'], undef];
}

# test equality
# takes three arguments: expected:Any, got:Any, test_name:String=""
# tests if `expected` is equal to `got`
$plang->add_builtin_function('test_eq',
    [[['TYPE', 'Any'], 'expected', undef], [['TYPE', 'Any'], 'got', undef], [['TYPE', 'String'], 'test_name', [INSTR_LITERAL, ['TYPE', 'String'], '']]],
    ['TYPE', 'Boolean'],
    \&test_eq_func,
    \&test_eq_validator);

sub test_eq_func {
    my ($plang, $scope, $name, $arguments) = @_;

    my ($got, $expected) = ($arguments->[0], $arguments->[1]);
    my $test = $arguments->[2]->[1];

    if ($plang->identical_objects($got, $expected)) {
        push @passed, [$test_file, $test, $got, $expected];
        print '.';
        return [['TYPE', 'Boolean'], 1];
    } else {
        push @failed, [$test_file, $test, $got, $expected];
        print 'X';
        return [['TYPE', 'Boolean'], 0];
    }
}

sub test_eq_validator {
    return [['TYPE', 'Boolean'], 0];
}

# test stdout
# takes two arguments: expected:String, test_name:String=""
# tests if expected stdout output matches expected output
$plang->add_builtin_function('test_stdout',
    [[['TYPE', 'String'], 'expected', undef], [['TYPE', 'String'], 'test_name', [INSTR_LITERAL, ['TYPE', 'String'], '']]],
    ['TYPE', 'Boolean'],
    \&test_stdout_func,
    \&test_stdout_validator);

sub test_stdout_func {
    my ($plang, $scope, $name, $arguments) = @_;

    my $expected = $plang->output_value($scope, $arguments->[0]);
    my $got      = $output;
    my $test     = $arguments->[1]->[1];

    $output = ''; # reset output for next test

    if ($expected eq $got) {
        push @passed, [$test_file, $test, $got, $expected];
        print '.';
        return [['TYPE', 'Boolean'], 1];
    } else {
        push @failed, [$test_file, $test, $got, $expected];
        print 'X';
        return [['TYPE', 'Boolean'], 0];
    }
}

sub test_stdout_validator {
    return [['TYPE', 'Boolean'], 0];
}

my @selected_tests;

if (@$opt_args) {
    # select specific tests
    @selected_tests = @$opt_args;
} else {
    # select all tests
    @selected_tests = glob "$RealBin/../test/*.pt";
}

print "Running ", scalar @selected_tests, " test file", @selected_tests == 1 ? '' : 's',  ": ";

use Encode;

foreach my $test (@selected_tests) {
    if (-d $test) {
        die "Failed to open $test; expected file but got directory.";
    }

    if ($opts{names}) {
        print "\n$test\n";
    }

    open my $fh, '<', $test or die "Failed to open $test: $!";
    my $code = do { local $/; <$fh> };
    close $fh;

    $code = decode('UTF-8', $code);

    $output = '';
    $test_file = $test;

    my $expected_error;

    if ($test_file =~ /_err/) {
        if ($code =~ /^\s*#\s*(.*error.*)$/ism) {
            $expected_error = $1;
        } else {
            $expected_error = "Unspecified error";
        }
    }

    eval { $plang->interpret_string($code) };

    if (my $exception = $@) {
        if (defined $expected_error) {
            if ($exception eq $expected_error) {
                push @passed, [$test_file, 'EXCEPTION', $exception, $expected_error];
                print '.';
            } else {
                push @failed, [$test_file, 'EXCEPTION', $exception, $expected_error];
                print 'X';
            }
        } else {
            push @failed, [$test_file, 'EXCEPTION', $exception, 'No exception'];
            print 'X';
        }
    } elsif (defined $expected_error) {
        push @failed, [$test_file, 'EXPECTED EXCEPTION', 'No exception', $expected_error];
        print 'X';
    }

}

print "\nPass: ", scalar @passed, "; Fail: ", scalar @failed, "\n";

unless ($ENV{QUIET}) {
    use Data::Dumper;
    $Data::Dumper::Indent = 0;
    $Data::Dumper::Terse  = 1;
    $Data::Dumper::Useqq  = 1;

    foreach my $failure (@failed) {
        print '-' x 70, "\n";
        print "FAIL $failure->[0]: $failure->[1]\n";
        print "       Expected: ", Dumper($failure->[3]), "\n";
        print "            Got: ", Dumper($failure->[2]), "\n";
    }
}

exit 1 if @failed;
exit 0;