diff options
Diffstat (limited to 'tests/run.pl')
| -rw-r--r-- | tests/run.pl | 508 |
1 files changed, 508 insertions, 0 deletions
diff --git a/tests/run.pl b/tests/run.pl new file mode 100644 index 0000000..41437de --- /dev/null +++ b/tests/run.pl @@ -0,0 +1,508 @@ +#!/usr/bin/env perl +# Run one compiler fixture. Only CRLF is normalized; failures are never waived. +use strict; +use warnings; +use Cwd qw(abs_path); +use File::Copy (); +use File::Find (); +use File::Path qw(make_path remove_tree); +use File::Spec; +use FindBin; +use Getopt::Long qw(GetOptions); +use JSON::PP (); + +$| = 1; + +my $ROOT = abs_path(File::Spec->catdir($FindBin::Bin, File::Spec->updir())); +my $IS_WINDOWS = ($^O =~ /^(?:MSWin32|msys|cygwin)$/i) ? 1 : 0; + +sub normalized { + my ($data) = @_; + $data = '' unless defined $data; + my $copy = $data; + $copy =~ s/\r\n/\n/g; + return $copy; +} + +# Single-quoted escaping: keeps trailing spaces, missing newlines and +# non-UTF-8 bytes visible without any non-core module. +sub show_bytes { + my ($data) = @_; + $data = '' unless defined $data; + $data =~ s/\\/\\\\/g; + $data =~ s/\n/\\n/g; + $data =~ s/\r/\\r/g; + $data =~ s/\t/\\t/g; + $data =~ s/([^ -~])/sprintf('\\x{%02x}', ord($1))/ge; + return "'$data'"; +} + +sub split_keeplines { + my ($data) = @_; + return () if !defined($data) || $data eq ''; + return ($data =~ /(?:[^\n]*\n|[^\n]+\z)/g); +} + +# Like Python's bytes.splitlines(): exactly one trailing empty is dropped. +sub split_records { + my ($data) = @_; + return () if !defined($data) || $data eq ''; + my @records = split(/\n/, $data, -1); + pop(@records) if $data =~ /\n\z/; + return @records; +} + +sub compare { + my ($expected, $actual, $label) = @_; + my $want = normalized($expected); + my $got = normalized($actual); + return if $want eq $got; + my @left = split_keeplines($want); + my @right = split_keeplines($got); + my $count = @left < @right ? @left : @right; + my $index = $count; + for my $i (0 .. $count - 1) { + if ($left[$i] ne $right[$i]) { + $index = $i; + last; + } + } + my $line = $index + 1; + my $want_show = $index < @left ? show_bytes($left[$index]) : '<missing>'; + my $got_show = $index < @right ? show_bytes($right[$index]) : '<missing>'; + die "$label differs at line $line: expected $want_show, actual $got_show\n"; +} + +sub check_result { + my ($result, $expected, $exit_code) = @_; + $exit_code = 0 unless defined $exit_code; + my @errors; + if ($result->{returncode} != $exit_code) { + push @errors, "exit code: expected $exit_code, got $result->{returncode}"; + } + if (length($result->{stderr})) { + my $shown = show_bytes(substr($result->{stderr}, 0, 2000)); + push @errors, "unexpected stderr: $shown"; + } + my $ok = eval { compare($expected, $result->{stdout}, 'stdout'); 1; }; + if (!$ok) { + my $err = $@; + chomp($err); + push @errors, $err; + } + if (@errors) { + die join("\n", @errors) . "\n"; + } +} + +sub check_diagnostics { + my ($result, $expectations) = @_; + my @errors; + if ($result->{returncode} != 1) { + push @errors, "compiler exit code: expected 1, got $result->{returncode}"; + } + if (length($result->{stdout})) { + push @errors, 'unexpected stdout: ' . show_bytes(substr($result->{stdout}, 0, 1000)); + } + # ASCII markers (error:, line N) are matched on raw bytes; the compiler + # emits UTF-8 and ASCII patterns are unaffected by decoding. + my @lines = split_records(normalized($result->{stderr})); + for my $expectation (@{$expectations}) { + my $reason = $expectation->{reason}; + my $line_no = $expectation->{line}; + my @matching = grep { /error:/ && /$reason/ } @lines; + my $found = 0; + for my $line (@matching) { + if ($line =~ /\bline $line_no\b/) { + $found = 1; + last; + } + } + if (!$found) { + push @errors, 'missing error /' . $reason . '/ at line ' . $line_no + . '; matching diagnostics: [' . join(', ', map { show_bytes($_) } @matching) . ']'; + } + } + my $terminated = grep { $_ eq 'compilation terminated.' } @lines; + if ($terminated != 1) { + push @errors, "expected exactly one 'compilation terminated.' line"; + } + if (@errors) { + die join("\n", @errors) . "\n"; + } +} + +sub read_file { + my ($path) = @_; + open my $fh, '<:raw', $path or die "cannot read $path: $!\n"; + my $data = do { local $/; <$fh> }; + close $fh; + return defined($data) ? $data : ''; +} + +sub write_file { + my ($path, $data) = @_; + $data = '' unless defined $data; + open my $fh, '>:raw', $path or die "cannot write $path: $!\n"; + print {$fh} $data; + close $fh; +} + +sub commands_new { + my ($directory) = @_; + return {dir => $directory, index => 0}; +} + +sub write_metadata { + my ($stem, $metadata) = @_; + my $json = JSON::PP->new->canonical(1)->pretty(1)->encode($metadata); + write_file($stem . '.json', $json); +} + +# Run one command without a shell, retaining argv, cwd, input, status and +# output under the case result directory. Dies on timeout or launch failure. +sub run_command { + my ($state, $command, $cwd, $data, $timeout) = @_; + $data = '' unless defined $data; + $timeout = 30 unless defined $timeout; + $state->{index}++; + my $stem = File::Spec->catfile($state->{dir}, sprintf('%02d', $state->{index})); + my %metadata = (command => [@{$command}], cwd => "$cwd", timeout => $timeout + 0); + write_file($stem . '.stdin', $data); + my $pid = fork(); + if (!defined($pid)) { + $metadata{launch_error} = "fork failed: $!"; + write_metadata($stem, \%metadata); + die "cannot launch @{$command}: fork failed: $!\n"; + } + if ($pid == 0) { + open STDIN, '<:raw', $stem . '.stdin' or exit 126; + open STDOUT, '>:raw', $stem . '.stdout' or exit 126; + open STDERR, '>:raw', $stem . '.stderr' or exit 126; + if (!chdir($cwd)) { + print STDERR "CPSC_LAUNCH_ERROR: cannot chdir to $cwd: $!"; + exit 126; + } + { exec {$command->[0]} @{$command}; } + print STDERR "CPSC_LAUNCH_ERROR: cannot exec @{$command}: $!"; + exit 126; + } + my $alarm_secs = int($timeout); + $alarm_secs = 1 if $alarm_secs < 1; + my $timed_out = 0; + local $SIG{ALRM} = sub { $timed_out = 1; kill('KILL', $pid); }; + alarm($alarm_secs); + waitpid($pid, 0); + alarm(0); + my $status = $?; + if ($timed_out) { + waitpid($pid, 0); + for my $suffix ('.stdout', '.stderr') { + if (!-f ($stem . $suffix)) { + write_file($stem . $suffix, ''); + } + } + $metadata{timeout_expired} = JSON::PP::true; + write_metadata($stem, \%metadata); + die "command timed out after ${timeout}s: @{$command}\n"; + } + my $exit_code = $status >> 8; + my $out = -f ($stem . '.stdout') ? read_file($stem . '.stdout') : ''; + my $err = -f ($stem . '.stderr') ? read_file($stem . '.stderr') : ''; + if ($exit_code == 126 && $err =~ s/^CPSC_LAUNCH_ERROR: //) { + chomp($err); + $metadata{launch_error} = $err; + write_metadata($stem, \%metadata); + write_file($stem . '.stdout', $out); + write_file($stem . '.stderr', $err); + die "cannot launch @{$command}: $err\n"; + } + $metadata{exit_code} = $exit_code + 0; + write_metadata($stem, \%metadata); + write_file($stem . '.stdout', $out); + write_file($stem . '.stderr', $err); + return {returncode => $exit_code + 0, stdout => $out, stderr => $err}; +} + +sub copy_tree { + my ($src, $dst) = @_; + opendir(my $dh, $src) or die "cannot read $src: $!\n"; + my @entries = sort grep { $_ ne '.' && $_ ne '..' } readdir($dh); + closedir($dh); + for my $entry (@entries) { + my $from = File::Spec->catfile($src, $entry); + my $to = File::Spec->catfile($dst, $entry); + if (-d $from && !-l $from) { + make_path($to); + copy_tree($from, $to); + } + elsif (-f $from || -l $from) { + File::Copy::copy($from, $to) or die "cannot copy $from: $!\n"; + } + } +} + +sub workspace { + my ($case_dir, $directory, $name) = @_; + my $work = File::Spec->catdir($directory, $name); + make_path($work); + my $files = File::Spec->catdir($case_dir, 'files'); + if (-d $files) { + copy_tree($files, $work); + } + return $work; +} + +sub check_files { + my ($case_dir, $work) = @_; + my $expected_dir = File::Spec->catdir($case_dir, 'expected-files'); + return unless -d $expected_dir; + my @found; + File::Find::find( + {wanted => sub { push(@found, $File::Find::name) if -f $_; }, no_chdir => 1}, + $expected_dir, + ); + for my $expected (sort @found) { + my $relative = File::Spec->abs2rel($expected, $expected_dir); + my $actual = File::Spec->catfile($work, File::Spec->splitdir($relative)); + if (!-f $actual) { + die "missing output file: $relative\n"; + } + compare(read_file($expected), read_file($actual), $relative); + } +} + +sub main { + my @args = @_; + local @ARGV = @args; + my ($opt_case, $opt_cpsc, $opt_run_mode, $opt_reference, $opt_perl, $opt_seed, + $opt_count, $opt_results); + $opt_perl = 'perl'; + $opt_seed = ''; + $opt_count = 10000; + $opt_results = File::Spec->catdir($ROOT, 'build', 'test-results'); + my $parsed = GetOptions( + 'case=s' => \$opt_case, + 'cpsc=s' => \$opt_cpsc, + 'run-mode=s' => \$opt_run_mode, + 'reference=s' => \$opt_reference, + 'perl=s' => \$opt_perl, + 'seed=s' => \$opt_seed, + 'count=i' => \$opt_count, + 'results=s' => \$opt_results, + ); + if (!$parsed || !defined($opt_case) || !defined($opt_cpsc) || !defined($opt_run_mode)) { + warn "usage: $0 --case MANIFEST --cpsc CPSC --run-mode MODE [options]\n"; + return 2; + } + if ($opt_run_mode !~ /^(?:EMBEDDED|PATH|NONE)$/) { + warn "invalid --run-mode: $opt_run_mode\n"; + return 2; + } + if ($opt_count < 1) { + warn "--count must be positive\n"; + return 2; + } + my $case_abs = abs_path($opt_case); + my $cpsc_abs = abs_path($opt_cpsc); + my $reference_abs = defined($opt_reference) ? abs_path($opt_reference) : undef; + my $case_dir = File::Spec->catdir((File::Spec->splitpath($case_abs))[0, 1]); + $case_dir =~ s{[\\/]$}{}; + my @parts = File::Spec->splitdir($case_dir); + my $suite = $parts[-2]; + my $name = $parts[-1]; + open my $cfg_fh, '<:raw', $case_abs or die "cannot read $case_abs: $!\n"; + my $config_text = do { local $/; <$cfg_fh> }; + close $cfg_fh; + my $config = JSON::PP->new->decode($config_text); + open my $git_fh, '-|', 'git', '-C', $ROOT, 'rev-parse', 'HEAD' + or die "cannot run git: $!\n"; + my $commit = <$git_fh>; + close $git_fh; + if ($? != 0 || !defined($commit)) { + die "cannot determine HEAD commit\n"; + } + chomp($commit); + my $seed = length($opt_seed) ? $opt_seed : $commit; + my $directory = File::Spec->catdir(abs_path($opt_results), $suite, $name); + if (-e $directory) { + remove_tree($directory); + } + make_path($directory); + my $commands = commands_new($directory); + my $report = { + case => "$suite/$name", + commit => $commit, + seed => $seed, + random_count => $opt_count + 0, + platform => "$^O", + run_mode => $opt_run_mode, + failures => [], + }; + my $source = File::Spec->catfile($case_dir, 'program.cps'); + + my $attempt = sub { + my ($label, $code) = @_; + my $ok = eval { $code->(); 1; }; + if (!$ok) { + my $err = "$@"; + chomp($err); + push(@{$report->{failures}}, {stage => $label, message => $err}); + print "FAIL $suite/$name [$label]: $err\n"; + } + else { + print "PASS $suite/$name [$label]\n"; + } + }; + + my $diagnostics = sub { + for my $output_format ('native', 'ir') { + my $work = workspace($case_dir, $directory, $output_format); + my $target = File::Spec->catfile($work, + $IS_WINDOWS ? 'program.exe' : 'program.bin'); + my @flags = $output_format eq 'ir' ? ('-S') : (); + for my $existing (0, 1) { + my $sentinel = 'existing output must survive' . "\n"; + if ($existing) { + write_file($target, $sentinel); + } + my $result = run_command($commands, + [$cpsc_abs, $source, @flags, '-o', $target], $work, '', 120); + my $preservation_error; + if ($existing && (!-f $target || read_file($target) ne $sentinel)) { + $preservation_error = 'compilation failure overwrote existing output'; + } + if (!$existing && -f $target) { + $preservation_error = 'compilation failure created output'; + unlink($target); + } + my $captured_result = $result; + my $captured_error = $preservation_error; + $attempt->( + "$output_format/" . ($existing ? 'existing' : 'absent'), + sub { + if (defined($captured_error)) { + die "$captured_error\n"; + } + check_diagnostics($captured_result, $config->{errors}); + }, + ); + } + } + }; + + my $setup_ok = eval { + if ($suite eq 'iii') { + $diagnostics->(); + } + else { + my $input_path = File::Spec->catfile($case_dir, 'input.txt'); + my $data = -f $input_path ? read_file($input_path) : ''; + my @records; + my $expected; + if ($suite eq 'ii') { + if (!defined($reference_abs)) { + die "differential tests require --reference\n"; + } + my $generated = run_command($commands, + [$opt_perl, File::Spec->catfile($case_dir, 'generate.pl'), $seed, "$opt_count"], + $directory, '', 30); + if ($generated->{returncode} != 0 || length($generated->{stderr})) { + die 'generator failed: ' . show_bytes($generated->{stderr}) . "\n"; + } + $data = $generated->{stdout}; + @records = split_records(normalized($data)); + if (!@records || $records[0] !~ /^\d+$/ || $records[0] + 0 != @records - 1) { + die "generator must emit record count followed by one record per line\n"; + } + my $work = workspace($case_dir, $directory, 'reference'); + my $exec_timeout = exists($config->{timeout}) ? $config->{timeout} + 0 : 30; + my $reference = run_command($commands, [$reference_abs], $work, $data, + $exec_timeout); + if ($reference->{returncode} != 0 || length($reference->{stderr})) { + die "reference failed ($reference->{returncode}): " + . show_bytes($reference->{stderr}) . "\n"; + } + $expected = $reference->{stdout}; + my @expected_lines = split_records(normalized($expected)); + if (@expected_lines != @records - 1) { + die "reference must emit exactly one output line per input record\n"; + } + } + else { + $expected = read_file(File::Spec->catfile($case_dir, 'expected.txt')); + } + write_file(File::Spec->catfile($directory, 'input.txt'), $data); + write_file(File::Spec->catfile($directory, 'expected.txt'), $expected); + + my $execute = sub { + my ($mode) = @_; + my $work = workspace($case_dir, $directory, $mode); + my $command; + if ($mode eq 'native') { + my $target = File::Spec->catfile($work, + $IS_WINDOWS ? 'program.exe' : 'program.bin'); + my $compiled = run_command($commands, + [$cpsc_abs, $source, '-o', $target], $work, '', 120); + check_result($compiled, ''); + $command = [$target]; + } + else { + $command = [$cpsc_abs, $source, '-r']; + } + my $exec_timeout = exists($config->{timeout}) ? $config->{timeout} + 0 : 30; + my $result = run_command($commands, $command, $work, $data, $exec_timeout); + if ($suite eq 'ii' && normalized($result->{stdout}) ne normalized($expected)) { + my @wanted = split_keeplines(normalized($expected)); + my @got = split_keeplines(normalized($result->{stdout})); + my $count = @wanted < @got ? @wanted : @got; + my $index = $count; + for my $i (0 .. $count - 1) { + if ($wanted[$i] ne $got[$i]) { + $index = $i; + last; + } + } + my $record = ($index + 1 < @records) ? $records[$index + 1] : '<extra output>'; + print 'First differing record ' . ($index + 1) . ': ' . show_bytes($record) . "\n"; + my $difference = { + record => $index + 1, + input => $record, + expected => $index < @wanted ? show_bytes($wanted[$index]) : '<missing>', + actual => $index < @got ? show_bytes($got[$index]) : '<missing>', + }; + my $diff_json = JSON::PP->new->canonical(1)->pretty(1)->encode($difference); + write_file(File::Spec->catfile($directory, "$mode-first-difference.json"), + $diff_json); + } + my $exit_code = exists($config->{exit_code}) ? $config->{exit_code} + 0 : 0; + check_result($result, $expected, $exit_code); + check_files($case_dir, $work); + }; + my @modes = ('native'); + if ($opt_run_mode ne 'NONE') { + push(@modes, 'runner'); + } + for my $mode (@modes) { + my $captured = $mode; + $attempt->($captured, sub { $execute->($captured); }); + } + } + 1; + }; + if (!$setup_ok) { + my $err = "$@"; + chomp($err); + push(@{$report->{failures}}, {stage => 'setup', message => $err}); + print "FAIL $suite/$name [setup]: $err\n"; + } + $report->{passed} = @{$report->{failures}} ? JSON::PP::false : JSON::PP::true; + my $report_json = JSON::PP->new->canonical(1)->pretty(1)->encode($report); + write_file(File::Spec->catfile($directory, 'result.json'), $report_json); + print "Seed: $seed; results: $directory\n"; + return $report->{passed} ? 0 : 1; +} + +exit(main(@ARGV)) unless caller; + +1; |