antlr-3.4/runtime/Perl5/t/lib/ANTLR/Runtime/Test.pm

package ANTLR::Runtime::Test;

use strict;
use warnings;

use base 'Test::Builder::Module';

my $CLASS = __PACKAGE__;

our @EXPORT = qw( g_test_output_is );

use Carp;
use Cwd;
use File::Spec;
use File::Temp qw( tempdir );

sub read_file {
    my ($filename) = @_;

    local $/;
    open my $in, '<', $filename or die "Can't open $filename: $!";
    my $content = <$in>;
    close $in or warn "Can't close $filename: $!";

    return $content;
}

sub write_file {
    my ($filename, $content) = @_;

    open my $out, '>', $filename or die "Can't open $filename: $!";
    print $out $content;
    close $out or warn "Can't close $filename: $!";

    return;
}

sub get_perl {
    if (defined $ENV{HARNESS_PERL}) {
        return $ENV{HARNESS_PERL};
    }

    if ($^O =~ /^(MS)?Win32$/) {
        return Win32::GetShortPathName($^X);
    }

    return $^X;
}

sub g_test_output_is {
    my ($args) = @_;
    my $grammar = $args->{grammar};
    my $test_program = $args->{test_program};
    my $expected = $args->{expected};
    my $name = $args->{name} || undef;
    my $tb = $CLASS->builder;

    my $tmpdir = tempdir( CLEANUP => 1 );

    my $grammar_name;
    if ($grammar =~ /^(?:(?:lexer|parser|tree)\s+)? grammar \s+ (\w+)/xms) {
        $grammar_name = $1;
    } else {
        croak "Can't determine grammar name";
    }

    # write grammar file
    my $grammar_file = File::Spec->catfile($tmpdir, "$grammar_name.g");
    write_file($grammar_file, $grammar);

    # write test program file
    my $test_program_file = File::Spec->catfile($tmpdir, 'test.pl');
    write_file($test_program_file, $test_program);

    my $cwd = cwd;
    my $test_result;
    eval {
        # compile grammar
        my $antlr;
        if ($^O =~ /linux/) {
            $antlr = 'antlr.sh';
        }
        elsif ($^O =~ /MSWin32/) {
            $antlr = 'antlr.bat';
        }
        else {
            $antlr = 'antlr';
        }
        my $g_result = run_program([ File::Spec->catfile($cwd, 'tools', $antlr), '-o', $tmpdir, $grammar_file ]);
        if ($g_result->{exit_code} >> 8 != 0) {
            croak $g_result->{err};
        }

        # run test program
        {
            #local $ENV{PERLCOV_DB} = File::Spec->catfile($tmpdir, 'perlcov.db');
            #local $ENV{NYTPROF} = 'file=' . File::Spec->catfile($tmpdir, 'nytprof.out');
            $test_result = run_program([ get_perl(), '-Mblib', "-I$tmpdir", $test_program_file ]);
            if ($test_result->{exit_code} >> 8 != 0) {
                croak $test_result->{err};
            }
        }
    };
    die $@ if $@;

    my $actual = $test_result->{out};

    # compare with $expected
    return $tb->is_eq($actual, $expected, $name);
}

sub run_program {
    my ($command) = @_;

    open my $old_out, '>&STDOUT' or die "Can't capture stdout: $!";
    close STDOUT or die "Can't close stdout: $!";
    open STDOUT, '>', 'out.tmp' or die "Can't redirect stdout: $!";

    open my $old_err, '>&STDERR' or die "Can't capture stderr: $!";
    close STDERR or die "Can't close stderr: $!";
    open STDERR, '>', 'err.tmp' or die "Can't redirect stderr: $!";

    system @$command;
    my $exit_code = $?;

    # restore stderr
    my $err = read_file('err.tmp');
    close STDERR or die "Can't close stderr: $!";
    open STDERR, '>&', $old_err or die "Can't restore stderr: $!";
    unlink 'err.tmp' or warn "Can't remove err.tmp: $!";

    # restore stdout
    my $out = read_file('out.tmp');
    close STDOUT or die "Can't close stdout: $!";
    open STDOUT, '>&', $old_out or die "Can't restore stdout: $!";
    unlink 'out.tmp' or warn "Can't remove out.tmp: $!";

    my $exit_value;
    if ($exit_code < 0) {
        $exit_value = $exit_code;
    } elsif ($exit_code && 0xff) {
        $exit_value = "[SIGNAL $exit_code]";
    } else {
        $exit_value = $exit_code >> 8;
    }

    return {
        exit_code => $exit_code,
        exit_value => $exit_value,
        out => $out,
        err => $err,
    };
}

1;