281 lines
13 KiB
Perl
281 lines
13 KiB
Perl
|
#!/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);
|