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

# Checks for system-diag.pl: the JSON encoder, the calendar and formatting helpers,
# the address validation and the section result reader.
#
# Run from anywhere: perl tests/system-diag.pl

use strict;
use warnings;

my $root = $0 =~ m{^(.*)/[^/]+$} ? "$1/.." : '..';
$root = "./$root" if $root !~ m{^/};
require "$root/system-diag.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;
}

# ---------------------------------------------------------------------------
# JSON
# ---------------------------------------------------------------------------

is(json_quote('plain'), '"plain"', 'json_quote: a plain word');
is(json_quote("a\"b"), '"a\\"b"', 'json_quote: a double quote is escaped');
is(json_quote("a\nb"), '"a\\nb"', 'json_quote: a newline is escaped');
is(json_quote("a\tb"), '"a\\tb"', 'json_quote: a tab is escaped');
is(json_quote('back\\slash'), '"back\\\\slash"', 'json_quote: a backslash is escaped');

my $encoded = json_encode({ a => 1, b => 'x', c => [1, 2], d => undef, e => 1.5 });
like($encoded, qr/"a": 1/, 'json_encode: an integer');
like($encoded, qr/"b": "x"/, 'json_encode: a string');
like($encoded, qr/"d": null/, 'json_encode: an undefined value');
like($encoded, qr/"e": 1\.5/, 'json_encode: a float');
like($encoded, qr/"c": \[\s*1,\s*2\s*\]/s, 'json_encode: an array');
like($encoded, qr/\A\{\n/, 'json_encode: an object opens on its own line');
like($encoded, qr/\}\n\z/, 'json_encode: the document ends with a newline');

like(json_encode([1, 2, 3]), qr/\A\[\n/, 'json_encode: a top-level array');

# ---------------------------------------------------------------------------
# Calendar and time
# ---------------------------------------------------------------------------

is(_days_from_civil(1970, 1, 1), 0, 'calendar: the epoch is day zero');
is(_days_from_civil(1970, 1, 2), 1, 'calendar: the next day');
is(_days_from_civil(1969, 12, 31), -1, 'calendar: the day before the epoch');
is(_days_from_civil(2000, 3, 1), 11017, 'calendar: the day after the leap day of 2000');
# Cross-checked with the system's own calendar: timegm for that date over 86400.
is(_days_from_civil(2026, 9, 17), 20713, 'calendar: a current date');

local $ENV{TZ} = 'UTC';
is(timestamp_fields(0), '1970-01-01T00:00:00+0000', 'timestamp: the epoch in UTC');
is(timestamp_fields(86400), '1970-01-02T00:00:00+0000', 'timestamp: one day on');
like(timestamp_fields(1787961600), qr/\A\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}[+-]\d{4}\z/,
    'timestamp: the shape of a timestamp');
like(utc_offset(time()), qr/\A[+-]\d{4}\z/, 'timestamp: the offset has a sign and four digits');

like(uptime_human(90061), qr/1/, 'uptime: a day is reported');
like(uptime_human(0), qr/\d/, 'uptime: zero still reads as a duration');

# ---------------------------------------------------------------------------
# Bars and percentages
# ---------------------------------------------------------------------------

# The bar carries colour codes around its cells and the percentage after them, so the
# assertions strip the codes first.
sub bar_plain {
    my ($text) = @_;
    $text =~ s/\e\[[0-9;]*m//g;
    return $text;
}

is(bar_plain(_bar(50, 100, 10)), "\xe2\x96\x88" x 5 . "\xe2\x96\x91" x 5 . '  50%',
    'bar: half of ten cells');
is(bar_plain(_bar(100, 100, 10)), "\xe2\x96\x88" x 10 . '  100%', 'bar: a full bar');
is(bar_plain(_bar(0, 100, 10)), "\xe2\x96\x91" x 10 . '  0%', 'bar: an empty bar');
is(bar_plain(_bar(0, 0, 10)), "\xe2\x96\x91" x 10 . '  0%', 'bar: a zero maximum does not divide');
# Colour is off when stdout is not a terminal, which is how the tests run, so the bar
# is asserted plain here.

# Deltas: 1000 jiffies in total, 800 of them idle and iowait, so 200 are busy.
is(usage_percent([100, 0, 100, 800, 100], [200, 0, 200, 1600, 100]), '20.0',
    'usage: a fifth of the delta is busy');
is(usage_percent([0, 0, 0, 100, 0], [0, 0, 0, 200, 0]), '0.0', 'usage: an idle machine');
is(usage_percent([0, 0, 0], [1, 1, 1]), '0.0', 'usage: a short sample is zero');

# ---------------------------------------------------------------------------
# Addresses and file systems
# ---------------------------------------------------------------------------

is(_valid_ipv6('::1'), 1, 'ipv6: loopback');
is(_valid_ipv6('2001:db8::1'), 1, 'ipv6: a documentation prefix');
is(_valid_ipv6('127.0.0.1'), 0, 'ipv6: an IPv4 address is not IPv6');
is(_valid_ipv6('2001:db8::1::2'), 0, 'ipv6: two shorthands are invalid');
is(_valid_ipv6('fe80::1%eth0'), 1, 'ipv6: a scope suffix is accepted');

is(is_address('192.168.1.1'), 1, 'address: IPv4');
is(is_address('::1'), 1, 'address: IPv6');
is(is_address('not-an-address'), 0, 'address: a word is not an address');
is(is_address(''), 0, 'address: an empty string is not an address');

is(skip_filesystem('tmpfs', '/run'), 1, 'filesystem: tmpfs is skipped');
is(skip_filesystem('overlay', '/'), 1, 'filesystem: overlay is skipped');
is(skip_filesystem('ext4', '/dev/sda1'), 0, 'filesystem: ext4 is measured');
is(skip_filesystem('xfs', '/dev/mapper/root'), 0, 'filesystem: xfs is measured');

is(unescape_mount_point('/mnt/\\040data'), '/mnt/ data', 'mounts: an escaped space decodes');
is(unescape_mount_point('/mnt/\\011tab'), "/mnt/\ttab", 'mounts: an escaped tab decodes');
is(unescape_mount_point('/mnt/\\134back'), '/mnt/\\back', 'mounts: an escaped backslash decodes');
is(unescape_mount_point('/plain/path'), '/plain/path', 'mounts: a plain path is untouched');

# ---------------------------------------------------------------------------
# Results read back from a section worker
# ---------------------------------------------------------------------------

is(perl_literal('42'), '42', 'literal: a whole number stays a number');
is(perl_literal('08'), "'08'", 'literal: a leading zero is quoted, not octalised');
is(perl_literal('010'), "'010'", 'literal: a leading zero with digits is quoted too');

my $tmp = "/tmp/system-diag-test.$$";
open(my $fh, '>', $tmp) or die "cannot write $tmp: $!\n";
print {$fh} perl_literal({ cpu => { usage_pct => 12.5 }, host => 'node1', key => '18.0', zeroed => '08' });
close($fh);

my ($value, $error) = read_literal($tmp);
is($error, '', 'literal: a written result reads back without error');
is($value->{host}, 'node1', 'literal: a string survives the round trip');
is($value->{cpu}{usage_pct}, 12.5, 'literal: a float survives the round trip');
is($value->{key}, '18.0', 'literal: a numeric-looking string stays a string');
is($value->{zeroed}, '08', 'literal: a leading-zero string survives the round trip');
unlink($tmp);

my ($missing, $missing_error) = read_literal("$tmp.does-not-exist");
is($missing, undef, 'literal: a missing result file yields nothing');
like($missing_error, qr/was not written/, 'literal: a missing result file says so');

# ---------------------------------------------------------------------------
# External tools, through fixture binaries on a private PATH
# ---------------------------------------------------------------------------

# A collector is exercised end to end by replacing its external tool with a Perl
# fixture that prints a known answer, so the parsing is checked against the shape
# of the real tool's output without needing the tool installed.
sub install_fake_bin {
    my ($dir, $name, $body) = @_;
    open(my $fh, '>', "$dir/$name") or die "cannot write $dir/$name: $!\n";
    print {$fh} "#!/usr/bin/env perl\n", $body;
    close($fh);
    chmod(0755, "$dir/$name") or die "cannot chmod $dir/$name: $!\n";
    return;
}

my $bindir = "/tmp/system-diag-test-bin.$$";
mkdir($bindir, 0700) or die "cannot create $bindir: $!\n";

# The fixture PATH is scoped, so the rest of the checks see the real one.
{
    local $ENV{PATH} = "$bindir:$ENV{PATH}";

    install_fake_bin($bindir, 'lspci', <<'FIXTURE');
exit 0 if @ARGV && $ARGV[0] eq '-d';
print "0000:01:00.0 VGA compatible controller: Intel Corporation UHD Graphics 730 (rev 01)\n";
print "0000:02:00.0 3D controller: Huawei Technologies Co., Ltd. Ascend 910A\n";
FIXTURE
    my $gpu = lspci_gpu();
    is($gpu->{cards}[0]{model}, 'Intel Corporation UHD Graphics 730 (rev 01)',
        'lspci: the model is the description, not the whole line');
    is($gpu->{cards}[0]{vendor}, 'Intel', 'lspci: Corporation does not read as AMD');
    is($gpu->{cards}[1]{vendor}, 'Huawei', 'lspci: an Ascend card has its vendor');

    install_fake_bin($bindir, 'systemctl', <<'FIXTURE');
if (@ARGV && $ARGV[0] eq '--failed') {
    print "nginx.service loaded failed failed A high performance web server\n";
}
FIXTURE
    my $failed = failed_units();
    is($failed->[0]{unit}, 'nginx.service', 'services: a failed unit is listed');
    is($failed->[0]{state}, 'failed', 'services: the state is the unit state, not the load state');

    install_fake_bin($bindir, 'iostat', <<'FIXTURE');
print "Device            r/s     rkB/s   w/s     wkB/s\n";
print "sda               4.00    2048.00 10.00   512.00\n\n";
print "Device            r/s     rkB/s   w/s     wkB/s\n";
print "sda               8.00    4096.00 20.00  1024.00\n";
FIXTURE
    my $io = disk_io_stats();
    is($io->{devices}[0]{tps}, '28.00', 'iostat: the second report is the one measured');
    is($io->{devices}[0]{read_mb_s}, '4.00', 'iostat: a kB/s column converts to MB/s');
    is($io->{devices}[0]{write_mb_s}, '1.00', 'iostat: kB/s writes convert to MB/s');

    # Older sysstat printed MB/s columns; dividing those again would report a value
    # 1024 times too small.
    install_fake_bin($bindir, 'iostat', <<'FIXTURE');
print "Device:         rrqm/s   wrqm/s     r/s     w/s   rMB/s   wMB/s\n";
print "sda               0.00     0.00    4.00   10.00   16.00    8.00\n";
FIXTURE
    $io = disk_io_stats();
    is($io->{devices}[0]{read_mb_s}, '16.00', 'iostat: an MB/s column is not divided again');
    is($io->{devices}[0]{write_mb_s}, '8.00', 'iostat: MB/s writes stay in MB/s');

    # A machine with lspci and no GPU at all: collect_gpu answers undef, which is a
    # result and must not reach the report as a collection failure.
    install_fake_bin($bindir, 'lspci', <<'FIXTURE');
exit 0 if @ARGV && $ARGV[0] eq '-d';
print "00:1f.2 SATA controller: Intel Corporation 82801IR SATA [AHCI mode]\n";
FIXTURE
    my $collected = collect_all(['gpu'], 0);
    check(!(ref($collected->{gpu}) eq 'HASH' && $collected->{gpu}{error}),
        'collect: no GPU is a result, not a collection failure');
}

unlink(grep { -f } glob("$bindir/*"));
rmdir($bindir);

# ---------------------------------------------------------------------------
# Health
# ---------------------------------------------------------------------------

my $health = compute_health({});
is(ref($health), 'HASH', 'health: the verdict is a hash');
is($health->{score}, undef, 'health: no data has no score');
is($health->{grade}, 'N/A', 'health: no data is not graded');
is($health->{max_score}, 100, 'health: the maximum is one hundred');
# An ungraded run is the only verdict this test can construct, so the letter is not
# asserted here: it depends on a populated collection, which the script's own run
# exercises.  A check whose condition is a match must be forced into a boolean, since
# in an argument list a failed match yields the empty list and shifts the label into
# the condition slot.
check(ref($health->{breakdown}) eq 'HASH', 'health: the breakdown is a hash');
check(ref($health->{factors_skipped}) eq 'ARRAY', 'health: the skipped factors are listed');

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

my @saved = @ARGV;
@ARGV = ('--json', '--section', 'cpu,memory');
my %args = parse_args();
is($args{json}, 1, 'args: --json');
is($args{section}, 'cpu,memory', 'args: --section takes a list');
@ARGV = ();
my %defaults = parse_args();
is($defaults{json}, 0, 'args: json is off by default');
is($defaults{section}, '', 'args: every section by default');
@ARGV = @saved;

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