1324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruverpackage ANTLR::Runtime::Test; 2324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 3324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse strict; 4324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse warnings; 5324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 6324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse base 'Test::Builder::Module'; 7324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 8324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruvermy $CLASS = __PACKAGE__; 9324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 10324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruverour @EXPORT = qw( g_test_output_is ); 11324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 12324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse Carp; 13324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse Cwd; 14324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse File::Spec; 15324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruveruse File::Temp qw( tempdir ); 16324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 17324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruversub read_file { 18324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my ($filename) = @_; 19324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 20324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver local $/; 21324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open my $in, '<', $filename or die "Can't open $filename: $!"; 22324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $content = <$in>; 23324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close $in or warn "Can't close $filename: $!"; 24324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 25324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return $content; 26324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver} 27324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 28324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruversub write_file { 29324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my ($filename, $content) = @_; 30324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 31324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open my $out, '>', $filename or die "Can't open $filename: $!"; 32324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver print $out $content; 33324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close $out or warn "Can't close $filename: $!"; 34324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 35324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return; 36324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver} 37324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 38324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruversub get_perl { 39324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if (defined $ENV{HARNESS_PERL}) { 40324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return $ENV{HARNESS_PERL}; 41324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 42324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 43324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($^O =~ /^(MS)?Win32$/) { 44324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return Win32::GetShortPathName($^X); 45324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 46324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 47324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return $^X; 48324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver} 49324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 50324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruversub g_test_output_is { 51324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my ($args) = @_; 52324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $grammar = $args->{grammar}; 53324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $test_program = $args->{test_program}; 54324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $expected = $args->{expected}; 55324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $name = $args->{name} || undef; 56324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $tb = $CLASS->builder; 57324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 58324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $tmpdir = tempdir( CLEANUP => 1 ); 59324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 60324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $grammar_name; 61324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($grammar =~ /^(?:(?:lexer|parser|tree)\s+)? grammar \s+ (\w+)/xms) { 62324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $grammar_name = $1; 63324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } else { 64324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver croak "Can't determine grammar name"; 65324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 66324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 67324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # write grammar file 68324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $grammar_file = File::Spec->catfile($tmpdir, "$grammar_name.g"); 69324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver write_file($grammar_file, $grammar); 70324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 71324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # write test program file 72324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $test_program_file = File::Spec->catfile($tmpdir, 'test.pl'); 73324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver write_file($test_program_file, $test_program); 74324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 75324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $cwd = cwd; 76324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $test_result; 77324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver eval { 78324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # compile grammar 79324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $antlr; 80324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($^O =~ /linux/) { 81324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $antlr = 'antlr.sh'; 82324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 83324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver elsif ($^O =~ /MSWin32/) { 84324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $antlr = 'antlr.bat'; 85324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 86324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver else { 87324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $antlr = 'antlr'; 88324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 89324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $g_result = run_program([ File::Spec->catfile($cwd, 'tools', $antlr), '-o', $tmpdir, $grammar_file ]); 90324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($g_result->{exit_code} >> 8 != 0) { 91324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver croak $g_result->{err}; 92324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 93324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 94324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # run test program 95324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver { 96324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver #local $ENV{PERLCOV_DB} = File::Spec->catfile($tmpdir, 'perlcov.db'); 97324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver #local $ENV{NYTPROF} = 'file=' . File::Spec->catfile($tmpdir, 'nytprof.out'); 98324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $test_result = run_program([ get_perl(), '-Mblib', "-I$tmpdir", $test_program_file ]); 99324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($test_result->{exit_code} >> 8 != 0) { 100324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver croak $test_result->{err}; 101324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 102324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 103324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver }; 104324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver die $@ if $@; 105324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 106324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $actual = $test_result->{out}; 107324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 108324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # compare with $expected 109324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return $tb->is_eq($actual, $expected, $name); 110324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver} 111324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 112324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruversub run_program { 113324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my ($command) = @_; 114324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 115324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open my $old_out, '>&STDOUT' or die "Can't capture stdout: $!"; 116324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close STDOUT or die "Can't close stdout: $!"; 117324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open STDOUT, '>', 'out.tmp' or die "Can't redirect stdout: $!"; 118324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 119324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open my $old_err, '>&STDERR' or die "Can't capture stderr: $!"; 120324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close STDERR or die "Can't close stderr: $!"; 121324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open STDERR, '>', 'err.tmp' or die "Can't redirect stderr: $!"; 122324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 123324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver system @$command; 124324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $exit_code = $?; 125324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 126324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # restore stderr 127324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $err = read_file('err.tmp'); 128324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close STDERR or die "Can't close stderr: $!"; 129324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open STDERR, '>&', $old_err or die "Can't restore stderr: $!"; 130324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver unlink 'err.tmp' or warn "Can't remove err.tmp: $!"; 131324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 132324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver # restore stdout 133324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $out = read_file('out.tmp'); 134324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver close STDOUT or die "Can't close stdout: $!"; 135324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver open STDOUT, '>&', $old_out or die "Can't restore stdout: $!"; 136324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver unlink 'out.tmp' or warn "Can't remove out.tmp: $!"; 137324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 138324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver my $exit_value; 139324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver if ($exit_code < 0) { 140324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $exit_value = $exit_code; 141324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } elsif ($exit_code && 0xff) { 142324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $exit_value = "[SIGNAL $exit_code]"; 143324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } else { 144324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver $exit_value = $exit_code >> 8; 145324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver } 146324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 147324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver return { 148324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver exit_code => $exit_code, 149324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver exit_value => $exit_value, 150324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver out => $out, 151324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver err => $err, 152324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver }; 153324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver} 154324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver 155324c4644fee44b9898524c09511bd33c3f12e2dfBen Gruver1; 156