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