test(harness): port case runner to Perl

Co-Authored-By: Claude Fable 5.1 <noreply@anthropic.com>

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;