feat: initial release of the scripts collection
Assisted-by: GLM 5.3 Flash
This commit is contained in:
@@ -0,0 +1,325 @@
|
||||
#!/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);
|
||||
Reference in New Issue
Block a user