#!/usr/bin/env perl
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
# SPDX-License-Identifier: MIT

# Checks for system-optimise.pl: the version comparison against rpm's own
# implementation, the pure helpers and the JSON decoder.
#
# Run from anywhere: perl tests/system-optimise.pl

use strict;
use warnings;

my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
$root = "./$root" if $root !~ m{^/};
require "$root/system-optimise.pl";

my ($passed, $failed) = (0, 0);

sub is {
    my ($got, $want, $label) = @_;
    $got = 'undef' unless defined $got;
    $want = 'undef' unless defined $want;
    if ($got eq $want) {
        $passed++;
        print "ok   $label\n";
        return 1;
    }
    $failed++;
    print "FAIL $label\n     got:  $got\n     want: $want\n";
    return 0;
}

sub check {
    my ($cond, $label) = @_;
    return is($cond ? 1 : 0, 1, $label);
}

sub like {
    my ($got, $re, $label) = @_;
    my $matched = (defined $got && $got =~ $re) ? 1 : 0;
    if ($matched) {
        $passed++;
        print "ok   $label\n";
        return 1;
    }
    $failed++;
    print "FAIL $label\n     got:  " . (defined $got ? $got : 'undef') . "\n     want: $re\n";
    return 0;
}

# ---------------------------------------------------------------------------
# Version comparison, against rpm itself
# ---------------------------------------------------------------------------
#
# rpm carries the definition of its own ordering, so the comparison is checked
# against rpm's implementation rather than against an expectation written here
# by hand.  The corpus is fixed: the same pairs every run.  No pair may carry
# a dash or a colon: the oracle below parses its arguments as
# [epoch:]version[-release] and would split on them, so those shapes belong to
# the EVR corpus further down.

my @VERSION_PAIRS = (
    ['1.0', '1.1'],
    ['1.1', '1.0'],
    ['1.0', '1.0'],
    ['1.09', '1.9'],
    ['1.0', '1.0.0'],
    ['1.0a', '1.0'],
    ['1.0a', '1.0b'],
    ['1.0', '1.0~rc1'],
    ['1.0~rc1', '1.0~rc2'],
    ['1.0~rc1', '1.0~rc1'],
    ['1.0^post1', '1.0'],
    ['1.0^post1', '1.0^post2'],
    ['2.0', '10.0'],
    ['1.2.3', '1.2.3'],
    ['1.2.3.4', '1.2.3'],
    ['5.14.0', '5.14.0.1'],
    ['0.9', '1.0'],
    ['1.0', '1.0b'],
    ['2024.1', '2024.10'],
    ['1.0.rc1', '1.0'],
    ['1.0^post1', '1.0b'],
    ['1.0', '1.0^'],
    ['1.0.~rc1', '1.0~rc1'],
    ['1.0^x', '1.0~x'],
    ['1.0.1', '1.0^post1'],
);

sub rpm_vercmp_oracle {
    my ($pairs) = @_;
    # rpm's macro parser counts braces, so the lua body below carries none: the corpus
    # travels as one flat string, and the pattern splits it back into pairs.
    my $spec = join(';', map { "$_->[0],$_->[1]" } @$pairs) . ';';
    # a comma or a semicolon would silently shift the pairing, so both travel
    # with the characters that break the lua literal
    return undef if grep { m{["\\{};,]} } map { @$_ } @$pairs;
    my $lua = '%{lua: local s="' . $spec . '";'
        . q{ for l,r in s:gmatch("([^,]+),([^;]+);") do io.write(rpm.vercmp(l,r), "\n") end};
    $lua .= '}';
    my $fh;
    open($fh, '-|', 'rpm', '--eval', $lua) or return undef;
    my @out = <$fh>;
    close($fh);
    return undef unless $? == 0;
    chomp @out;
    return \@out;
}

my $oracle = rpm_vercmp_oracle(\@VERSION_PAIRS);
if (!defined $oracle) {
    print "skip version comparison: rpm is not installed (the oracle)\n";
}
else {
    my $i = 0;
    for my $pair (@VERSION_PAIRS) {
        $i++;
        my ($left, $right) = @$pair;
        my $mine = rpmvercmp($left, $right);
        my $sign = $mine <=> 0;
        is($sign, $oracle->[$i - 1], "rpmvercmp($left, $right) matches rpm");
    }
}

is(rpmvercmp('1.0', '1.0'), 0, 'rpmvercmp: equal versions');
check(rpmvercmp('1.0~rc1', '1.0') < 0, 'rpmvercmp: a tilde sorts before the release');
check(rpmvercmp('1.0^post1', '1.0') > 0, 'rpmvercmp: a caret sorts after the release');

# ---------------------------------------------------------------------------
# EVR comparison
# ---------------------------------------------------------------------------

is(rpm_evr_cmp('1:1.0-1', '1:1.0-2'), -1, 'evr: release decides');
is(rpm_evr_cmp('1:1.0-1', '2:1.0-1'), -1, 'evr: epoch decides');
is(rpm_evr_cmp('1:1.0-1', '1:1.0-1'), 0, 'evr: identical');
check(rpm_evr_cmp('2:1.0-1', '1:9.9-9') > 0, 'evr: an epoch outranks any version');
is(rpm_evr_cmp('1.0-1', '1:1.0-1'), -1, 'evr: a missing epoch is zero');

# The same oracle drives the EVR comparison, now with dashes and colons:
# rpm.vercmp parses its arguments as [epoch:]version[-release] and compares
# field by field, which is exactly the contract of rpm_evr_cmp.  The pairs
# below are the shapes the kernel query produces, plus the cases where
# comparing version and release as one string would order differently.
my @EVR_PAIRS = (
    ['1.0-2', '1.0.1-1'],
    ['1.0', '1.0-1'],
    ['1.0-1-2', '1.0-1'],
    ['2:1.0-1', '1.0-1'],
    ['0:1.0', '1.0'],
    ['1.0~rc1-1', '1.0-1'],
    ['0:6.9.5-100.fc40.x86_64', '0:6.9.6-50.fc40.x86_64'],
    ['0:6.9.5-100.fc40.x86_64', '0:6.9.5-200.fc40.x86_64'],
);
my $evr_oracle = rpm_vercmp_oracle(\@EVR_PAIRS);
if (!defined $evr_oracle) {
    print "skip EVR comparison: rpm is not installed (the oracle)\n";
}
else {
    my $j = 0;
    for my $pair (@EVR_PAIRS) {
        $j++;
        my ($left, $right) = @$pair;
        my $mine = rpm_evr_cmp($left, $right);
        my $sign = $mine <=> 0;
        is($sign, $evr_oracle->[$j - 1], "rpm_evr_cmp($left, $right) matches rpm");
    }
}

# ---------------------------------------------------------------------------
# Formatting and small helpers
# ---------------------------------------------------------------------------

is(format_size(0), '0 B', 'format_size: zero');
is(format_size(512), '512 B', 'format_size: under a kilobyte');
is(format_size(1024), '1.0 KB', 'format_size: one kilobyte');
is(format_size(1536), '1.5 KB', 'format_size: fraction of a kilobyte');
is(format_size(1048576), '1.0 MB', 'format_size: one megabyte');
is(format_size(1073741824), '1.00 GB', 'format_size: one gigabyte');
is(format_size(-1), '0 B', 'format_size: negative is clamped');

is(kernel_pkg_name('fedora'), 'kernel-core', 'kernel_pkg_name: Fedora');
is(kernel_pkg_name('openeuler'), 'kernel', 'kernel_pkg_name: openEuler');
is(kernel_pkg_name('centos'), 'kernel-core', 'kernel_pkg_name: CentOS Stream');

is(last_lines("a\nb\nc\nd\n", 2), 'c | d', 'last_lines: the last two lines, joined');
is(last_lines("1\n2\n3\n4\n", 10), '1 | 2 | 3 | 4', 'last_lines: a count above the line number');
is(last_lines("\n\n", 3), 'no error output', 'last_lines: blank input is named as no output');

my ($gone, $left) = split_by_presence(['a', 'b', 'c'], ['b', 'd']);
is(join(',', @$gone), 'a,c', 'split_by_presence: gone holds what vanished');
is(join(',', @$left), 'b', 'split_by_presence: left holds the survivors');

# ---------------------------------------------------------------------------
# JSON decoder
# ---------------------------------------------------------------------------

my $decoded = json_decode('{"a":1,"b":[true,false,null],"c":"x\\ny","d":{"e":2.5}}');
is(ref($decoded), 'HASH', 'json: an object decodes to a hash');
is($decoded->{a}, 1, 'json: an integer');
is(ref($decoded->{b}), 'ARRAY', 'json: an array decodes to an array');
is($decoded->{b}[0], 1, 'json: true is truthy');
is($decoded->{b}[1], 0, 'json: false is falsey');
is($decoded->{b}[2], undef, 'json: null is undef');
is($decoded->{c}, "x\ny", 'json: an escaped newline');
is($decoded->{d}{e}, 2.5, 'json: a nested float');

my $escaped = json_decode('{"s":"a\"b\\\\c\/d\te"}');
is($escaped->{s}, "a\"b\\c/d\te", 'json: quotes, backslashes, a solidus and a tab');

my $unicode = json_decode('{"s":"\u0041\u00e9"}');
is($unicode->{s}, "A\xc3\xa9", 'json: a unicode escape becomes UTF-8 bytes');

my $empty = json_decode('[]');
is(ref($empty), 'ARRAY', 'json: an empty array');
is(scalar(@$empty), 0, 'json: an empty array has no elements');

# The decoder dies on malformed input rather than returning a sentinel, so a caller
# that cannot trust its input wraps the call; the test asserts that contract.
my $died = eval { json_decode('not json'); 1 } ? 0 : 1;
is($died, 1, 'json: malformed input dies rather than returning a value');
like($@, qr/unrecognised token/, 'json: the death names the reason');

# ---------------------------------------------------------------------------
# Arguments
# ---------------------------------------------------------------------------

# parse_args reads the program's arguments, so a test sets them the way a caller does.
my @saved = @ARGV;
@ARGV = ('--dry-run', '--skip-journal');
my %args = parse_args();
is($args{dry_run}, 1, 'args: --dry-run sets the flag');
is($args{skip_journal}, 1, 'args: --skip-journal sets the flag');
is($args{skip_tmp}, 0, 'args: an unset skip stays off');
@ARGV = ();
my %defaults = parse_args();
is($defaults{dry_run}, 0, 'args: dry run defaults to off');
@ARGV = @saved;

# ---------------------------------------------------------------------------
# Temp cleanup, end to end
# ---------------------------------------------------------------------------
#
# clean_temp_dir drives the real find(1), so the age filter, the deletion and
# the verification of what went away are exercised together here, against a
# directory this test owns.

if (!defined find_exe('find')) {
    print "skip temp cleanup: find is not installed\n";
}
else {
    my $dir = "/tmp/system-optimise-test.$$";
    mkdir($dir, 0700) or die "cannot create $dir: $!\n";
    my $aged = "$dir/aged.txt";
    my $fresh = "$dir/fresh.txt";
    for my $file ($aged, $fresh) {
        open(my $fh, '>', $file) or die "cannot create $file: $!\n";
        print {$fh} "test\n";
        close($fh);
    }
    my $old_time = time() - 30 * 86400;
    utime($old_time, $old_time, $aged);

    my @warnings;
    my @errors;
    my ($count, $bytes) = clean_temp_dir($dir, 10,
        dry_run => 1, warnings => \@warnings, errors => \@errors);
    is($count, 1, 'temp: dry run counts the one aged file');
    check(-e $aged, 'temp: dry run leaves the aged file in place');
    is(scalar(@errors), 0, 'temp: dry run reports no errors');

    ($count, $bytes) = clean_temp_dir($dir, 10,
        dry_run => 0, warnings => \@warnings, errors => \@errors);
    is($count, 1, 'temp: the real run reports the aged file as removed');
    check(!-e $aged, 'temp: the aged file is gone');
    check(-e $fresh, 'temp: the fresh file survives');
    check($bytes > 0, 'temp: the freed size is above zero');
    is(scalar(@errors), 0, 'temp: the real run reports no errors');

    my ($again) = clean_temp_dir($dir, 10,
        dry_run => 0, warnings => \@warnings, errors => \@errors);
    is($again, 0, 'temp: a second run finds nothing to remove');

    unlink($fresh);
    rmdir($dir);
}

# ---------------------------------------------------------------------------
# The command runner and the scratch directory
# ---------------------------------------------------------------------------

# A file that cannot be exec'd: the runner must report 126 and name the
# binary, rather than swallowing the reason the exec failed.
my $bad_exe = "/tmp/system-optimise-test-noexec.$$";
if (open(my $fh, '>', $bad_exe)) {
    print {$fh} "#!/nonexistent/interpreter\n";
    close($fh);
    chmod(0755, $bad_exe);
    my $result = run([$bad_exe]);
    is($result->{rc}, 126, 'run: a failed exec reports 126');
    like($result->{err}, qr/cannot execute/, 'run: the failure names the binary');
    unlink($bad_exe);
}
else {
    print "skip runner: cannot write $bad_exe\n";
}

# An empty TMPDIR must fall back to /tmp rather than placing the scratch
# directory at the filesystem root.
my $empty_tmpdir = eval {
    remove_scratch();   # the cached directory would bypass the fallback
    local $ENV{TMPDIR} = '';
    my $scratch = scratch_dir();
    remove_scratch();
    return $scratch;
};
if (defined $empty_tmpdir) {
    like($empty_tmpdir, qr{^/tmp/system-optimise\.},
        'scratch_dir: an empty TMPDIR falls back to /tmp');
}
else {
    print "skip scratch_dir: cannot create a scratch directory\n";
}

print "\n" . ($failed ? "$failed FAILED of " . ($passed + $failed) : "all $passed checks passed") . "\n";
exit($failed ? 1 : 0);