1package ANTLR::Runtime::Test;
2
3use strict;
4use warnings;
5
6use base 'Test::Builder::Module';
7
8my $CLASS = __PACKAGE__;
9
10our @EXPORT = qw( g_test_output_is );
11
12use Carp;
13use Cwd;
14use File::Spec;
15use File::Temp qw( tempdir );
16
17sub read_file {
18    my ($filename) = @_;
19
20    local $/;
21    open my $in, '<', $filename or die "Can't open $filename: $!";
22    my $content = <$in>;
23    close $in or warn "Can't close $filename: $!";
24
25    return $content;
26}
27
28sub write_file {
29    my ($filename, $content) = @_;
30
31    open my $out, '>', $filename or die "Can't open $filename: $!";
32    print $out $content;
33    close $out or warn "Can't close $filename: $!";
34
35    return;
36}
37
38sub get_perl {
39    if (defined $ENV{HARNESS_PERL}) {
40        return $ENV{HARNESS_PERL};
41    }
42
43    if ($^O =~ /^(MS)?Win32$/) {
44        return Win32::GetShortPathName($^X);
45    }
46
47    return $^X;
48}
49
50sub g_test_output_is {
51    my ($args) = @_;
52    my $grammar = $args->{grammar};
53    my $test_program = $args->{test_program};
54    my $expected = $args->{expected};
55    my $name = $args->{name} || undef;
56    my $tb = $CLASS->builder;
57
58    my $tmpdir = tempdir( CLEANUP => 1 );
59
60    my $grammar_name;
61    if ($grammar =~ /^(?:(?:lexer|parser|tree)\s+)? grammar \s+ (\w+)/xms) {
62        $grammar_name = $1;
63    } else {
64        croak "Can't determine grammar name";
65    }
66
67    # write grammar file
68    my $grammar_file = File::Spec->catfile($tmpdir, "$grammar_name.g");
69    write_file($grammar_file, $grammar);
70
71    # write test program file
72    my $test_program_file = File::Spec->catfile($tmpdir, 'test.pl');
73    write_file($test_program_file, $test_program);
74
75    my $cwd = cwd;
76    my $test_result;
77    eval {
78        # compile grammar
79        my $antlr;
80        if ($^O =~ /linux/) {
81            $antlr = 'antlr.sh';
82        }
83        elsif ($^O =~ /MSWin32/) {
84            $antlr = 'antlr.bat';
85        }
86        else {
87            $antlr = 'antlr';
88        }
89        my $g_result = run_program([ File::Spec->catfile($cwd, 'tools', $antlr), '-o', $tmpdir, $grammar_file ]);
90        if ($g_result->{exit_code} >> 8 != 0) {
91            croak $g_result->{err};
92        }
93
94        # run test program
95        {
96            #local $ENV{PERLCOV_DB} = File::Spec->catfile($tmpdir, 'perlcov.db');
97            #local $ENV{NYTPROF} = 'file=' . File::Spec->catfile($tmpdir, 'nytprof.out');
98            $test_result = run_program([ get_perl(), '-Mblib', "-I$tmpdir", $test_program_file ]);
99            if ($test_result->{exit_code} >> 8 != 0) {
100                croak $test_result->{err};
101            }
102        }
103    };
104    die $@ if $@;
105
106    my $actual = $test_result->{out};
107
108    # compare with $expected
109    return $tb->is_eq($actual, $expected, $name);
110}
111
112sub run_program {
113    my ($command) = @_;
114
115    open my $old_out, '>&STDOUT' or die "Can't capture stdout: $!";
116    close STDOUT or die "Can't close stdout: $!";
117    open STDOUT, '>', 'out.tmp' or die "Can't redirect stdout: $!";
118
119    open my $old_err, '>&STDERR' or die "Can't capture stderr: $!";
120    close STDERR or die "Can't close stderr: $!";
121    open STDERR, '>', 'err.tmp' or die "Can't redirect stderr: $!";
122
123    system @$command;
124    my $exit_code = $?;
125
126    # restore stderr
127    my $err = read_file('err.tmp');
128    close STDERR or die "Can't close stderr: $!";
129    open STDERR, '>&', $old_err or die "Can't restore stderr: $!";
130    unlink 'err.tmp' or warn "Can't remove err.tmp: $!";
131
132    # restore stdout
133    my $out = read_file('out.tmp');
134    close STDOUT or die "Can't close stdout: $!";
135    open STDOUT, '>&', $old_out or die "Can't restore stdout: $!";
136    unlink 'out.tmp' or warn "Can't remove out.tmp: $!";
137
138    my $exit_value;
139    if ($exit_code < 0) {
140        $exit_value = $exit_code;
141    } elsif ($exit_code && 0xff) {
142        $exit_value = "[SIGNAL $exit_code]";
143    } else {
144        $exit_value = $exit_code >> 8;
145    }
146
147    return {
148        exit_code => $exit_code,
149        exit_value => $exit_value,
150        out => $out,
151        err => $err,
152    };
153}
154
1551;
156