2326 lines
80 KiB
Perl
2326 lines
80 KiB
Perl
|
#!/usr/bin/env perl
|
||
|
|
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
||
|
|
# SPDX-License-Identifier: MIT
|
||
|
|
|
||
|
|
# System diagnostics: CPU, memory, disk, network, GPU, services, security,
|
||
|
|
# performance, recent issues, and a health score with a letter grade.
|
||
|
|
#
|
||
|
|
# The data comes from /proc, /sys and system tools, and every source has a graceful
|
||
|
|
# fallback, so a missing tool is reported as unavailable rather than as a fault.
|
||
|
|
#
|
||
|
|
# Perl builtins only: no module has to be installed. What that costs here:
|
||
|
|
#
|
||
|
|
# * the command runner, which forks and keeps stdout and stderr apart in the
|
||
|
|
# scratch directory;
|
||
|
|
# * the section collectors, which run as forked children because the sections
|
||
|
|
# are independent and each is dominated by waiting, each writing its result
|
||
|
|
# as a Perl literal that the parent reads back;
|
||
|
|
# * a JSON encoder for --json, with two details Perl's data model forces: the
|
||
|
|
# values rounded to a decimal are held as numeric strings so 0.0 does not
|
||
|
|
# come out as 0, and the boolean fields are listed by path because Perl has
|
||
|
|
# no boolean type. Object keys are written in sorted order, so the document
|
||
|
|
# is stable from run to run.
|
||
|
|
# * file system sizes, which Perl's builtins do not expose, so `stat -f` is
|
||
|
|
# the transport, printing exactly the four numbers the arithmetic uses.
|
||
|
|
#
|
||
|
|
# One visible consequence of forking the section collectors is that they appear in
|
||
|
|
# the report's own top-process lists: the
|
||
|
|
# readings are real, the workers just happen to be the busiest thing at that moment.
|
||
|
|
#
|
||
|
|
# GPU detection reports AMD through rocm-smi, and any card at all through lspci when
|
||
|
|
# no driver tooling is present. No vendor tooling beyond AMD's is queried: the
|
||
|
|
# NVIDIA driver stack is banned by AGENTS.md, so nothing here reaches for it, and a
|
||
|
|
# card from that vendor is described by lspci like any other hardware.
|
||
|
|
#
|
||
|
|
# External binaries used: who, ip, ss, iostat, ps, stat, systemctl, getenforce,
|
||
|
|
# firewall-cmd, journalctl, last, lspci, rocm-smi, curl and uname.
|
||
|
|
#
|
||
|
|
# Linux only. Progress goes to stderr, the report to stdout.
|
||
|
|
#
|
||
|
|
# Usage:
|
||
|
|
# system-diag.pl # full report
|
||
|
|
# system-diag.pl --section cpu,memory # only selected sections
|
||
|
|
# system-diag.pl --external-ip # also detect external IPs (3rd-party)
|
||
|
|
# system-diag.pl --json # machine-readable output
|
||
|
|
# system-diag.pl --version
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
|
||
|
|
my $VERSION = '2.0.0';
|
||
|
|
|
||
|
|
# Colour follows NO_COLOR (https://no-color.org): it, or a stdout that is not a
|
||
|
|
# terminal, disables every escape.
|
||
|
|
my ($BOLD, $RED, $GREEN, $YELLOW, $CYAN, $MAGENTA, $DIM, $RESET) = (
|
||
|
|
"\033[1m", "\033[31m", "\033[32m", "\033[33m",
|
||
|
|
"\033[36m", "\033[35m", "\033[2m", "\033[0m",
|
||
|
|
);
|
||
|
|
if (defined $ENV{NO_COLOR} || !-t STDOUT) {
|
||
|
|
($BOLD, $RED, $GREEN, $YELLOW, $CYAN, $MAGENTA, $DIM, $RESET) = ('') x 8;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Letter grade to colour, applied when rendering only.
|
||
|
|
my %GRADE_COLOURS = (A => $GREEN, B => $GREEN, C => $YELLOW, D => $YELLOW, F => $RED);
|
||
|
|
|
||
|
|
my $WIDTH = 60;
|
||
|
|
|
||
|
|
my @ALL_SECTIONS = qw(
|
||
|
|
overview cpu memory disk network gpu services security performance issues
|
||
|
|
);
|
||
|
|
|
||
|
|
# The GPU card properties in the order their sources list them: lspci reports model,
|
||
|
|
# vendor and driver, and rocm-smi reports the card id and then its own properties.
|
||
|
|
my @CARD_KEY_ORDER = ('model', 'vendor', 'driver', 'id', 'Card series', 'Card model');
|
||
|
|
|
||
|
|
# Paths whose value is written as true or false, not as 1 or 0.
|
||
|
|
my @JSON_BOOLEANS = (
|
||
|
|
'disk.container',
|
||
|
|
'gpu.fallback',
|
||
|
|
'gpu.unavailable',
|
||
|
|
'security.firewalld.available',
|
||
|
|
'security.firewalld.active',
|
||
|
|
);
|
||
|
|
my %JSON_BOOLEAN = map { $_ => 1 } @JSON_BOOLEANS;
|
||
|
|
|
||
|
|
# Paths whose value is written as a string even when it looks like a number:
|
||
|
|
# every property of a GPU card is parsed text, and a per-core CPU index is written
|
||
|
|
# as a string. Without this they would go out unquoted and a reader would take them
|
||
|
|
# for numbers.
|
||
|
|
my @JSON_STRING_PATHS = (
|
||
|
|
qr/^gpu\.cards\./,
|
||
|
|
qr/^cpu\.per_core\.cpu$/,
|
||
|
|
);
|
||
|
|
|
||
|
|
my $TMP_DIR; # private scratch directory, created only when needed
|
||
|
|
my $PARENT_PID = $$; # a forked child must never clean up for the parent
|
||
|
|
my $RUN_SEQ = 0; # per-call suffix for the runner's files
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Progress, on stderr so stdout stays clean
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub _status {
|
||
|
|
my ($msg) = @_;
|
||
|
|
print STDERR " $msg...";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _status_done {
|
||
|
|
my ($msg) = @_;
|
||
|
|
$msg = 'done' unless defined $msg;
|
||
|
|
print STDERR " $msg\n";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Commands, files and small helpers
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub find_exe {
|
||
|
|
my ($name) = @_;
|
||
|
|
return undef unless defined $name && length $name;
|
||
|
|
if (index($name, '/') >= 0) {
|
||
|
|
return (-f $name && -x _) ? $name : undef;
|
||
|
|
}
|
||
|
|
for my $dir (split /:/, ($ENV{PATH} // '')) {
|
||
|
|
next unless length $dir;
|
||
|
|
my $path = "$dir/$name";
|
||
|
|
return $path if -f $path && -x _;
|
||
|
|
}
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub scratch_dir {
|
||
|
|
return $TMP_DIR if defined $TMP_DIR;
|
||
|
|
my $base = $ENV{TMPDIR} // '/tmp';
|
||
|
|
for my $attempt (0 .. 9) {
|
||
|
|
my $dir = "$base/system-diag.$$" . ($attempt ? ".$attempt" : '');
|
||
|
|
if (mkdir($dir, 0700)) {
|
||
|
|
$TMP_DIR = $dir;
|
||
|
|
return $dir;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
die "cannot create a scratch directory under $base\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub remove_scratch {
|
||
|
|
return unless defined $TMP_DIR;
|
||
|
|
# The collectors fork, and a forked child inherits the END block: only the
|
||
|
|
# process that created the directory may remove it.
|
||
|
|
return unless $$ == $PARENT_PID;
|
||
|
|
if (opendir(my $dh, $TMP_DIR)) {
|
||
|
|
for my $entry (readdir($dh)) {
|
||
|
|
next if $entry eq '.' || $entry eq '..';
|
||
|
|
unlink("$TMP_DIR/$entry");
|
||
|
|
}
|
||
|
|
closedir($dh);
|
||
|
|
}
|
||
|
|
rmdir($TMP_DIR);
|
||
|
|
undef $TMP_DIR;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub slurp {
|
||
|
|
my ($path) = @_;
|
||
|
|
open(my $fh, '<', $path) or return '';
|
||
|
|
my $text = do { local $/ = undef; <$fh> };
|
||
|
|
close($fh);
|
||
|
|
return defined $text ? $text : '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# Run a command and return { rc, out, err }. The locale is forced to C for
|
||
|
|
# English output, and a timeout or a missing binary yields empty output rather
|
||
|
|
# than an exception, which is the contract every caller below expects.
|
||
|
|
sub run {
|
||
|
|
my ($cmd, $timeout) = @_;
|
||
|
|
$timeout = 15 unless defined $timeout;
|
||
|
|
|
||
|
|
my $exe = find_exe($cmd->[0]);
|
||
|
|
return { rc => 127, out => '', err => '' } unless defined $exe;
|
||
|
|
|
||
|
|
my $dir = scratch_dir();
|
||
|
|
$RUN_SEQ++;
|
||
|
|
my $out_file = "$dir/out.$$.$RUN_SEQ";
|
||
|
|
my $err_file = "$dir/err.$$.$RUN_SEQ";
|
||
|
|
|
||
|
|
my $pid = fork();
|
||
|
|
die "cannot fork: $!\n" unless defined $pid;
|
||
|
|
if ($pid == 0) {
|
||
|
|
if (open(STDOUT, '>', $out_file) && open(STDERR, '>', $err_file)) {
|
||
|
|
$ENV{LANG} = 'C';
|
||
|
|
$ENV{LC_ALL} = 'C';
|
||
|
|
exec { $exe } @$cmd;
|
||
|
|
}
|
||
|
|
exit 126;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $timed_out = 0;
|
||
|
|
eval {
|
||
|
|
local $SIG{ALRM} = sub { die "alarm\n" };
|
||
|
|
alarm($timeout);
|
||
|
|
waitpid($pid, 0);
|
||
|
|
alarm(0);
|
||
|
|
1;
|
||
|
|
} or do { $timed_out = 1; alarm(0) };
|
||
|
|
|
||
|
|
my $rc;
|
||
|
|
if ($timed_out) {
|
||
|
|
kill('TERM', $pid);
|
||
|
|
select(undef, undef, undef, 0.1);
|
||
|
|
kill('KILL', $pid);
|
||
|
|
waitpid($pid, 0);
|
||
|
|
$rc = 124;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$rc = $? >> 8;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $out = slurp($out_file);
|
||
|
|
my $err = slurp($err_file);
|
||
|
|
unlink($out_file, $err_file);
|
||
|
|
return { rc => $rc, out => $timed_out ? '' : $out, err => $timed_out ? '' : $err };
|
||
|
|
}
|
||
|
|
|
||
|
|
sub read_file {
|
||
|
|
my ($path) = @_;
|
||
|
|
open(my $fh, '<', $path) or return '';
|
||
|
|
my $text = do { local $/ = undef; <$fh> };
|
||
|
|
close($fh);
|
||
|
|
return '' unless defined $text;
|
||
|
|
$text =~ s/^\s+//;
|
||
|
|
$text =~ s/\s+$//;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub read_lines {
|
||
|
|
my ($path) = @_;
|
||
|
|
open(my $fh, '<', $path) or return [];
|
||
|
|
my @lines;
|
||
|
|
while (my $line = <$fh>) {
|
||
|
|
$line =~ s/^\s+//;
|
||
|
|
$line =~ s/\s+$//;
|
||
|
|
push @lines, $line;
|
||
|
|
}
|
||
|
|
close($fh);
|
||
|
|
return \@lines;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub uname {
|
||
|
|
my ($flag) = @_;
|
||
|
|
my $p = run(['uname', $flag], 5);
|
||
|
|
my $value = $p->{out};
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
# A textual usage bar: filled and empty cells with the percentage at the end.
|
||
|
|
sub _bar {
|
||
|
|
my ($value, $maximum, $width) = @_;
|
||
|
|
$maximum = 100.0 unless defined $maximum;
|
||
|
|
$width = 20 unless defined $width;
|
||
|
|
my $ratio = $maximum > 0 ? $value / $maximum : 0.0;
|
||
|
|
$ratio = 0.0 if $ratio < 0.0;
|
||
|
|
$ratio = 1.0 if $ratio > 1.0;
|
||
|
|
my $filled = int($ratio * $width);
|
||
|
|
my $colour = $ratio < 0.80 ? $GREEN : $ratio < 0.90 ? $YELLOW : $RED;
|
||
|
|
my $bar = $colour . ("█" x $filled) . $DIM . ("░" x ($width - $filled)) . $RESET;
|
||
|
|
return $bar . ' ' . sprintf('%.0f%%', $ratio * 100);
|
||
|
|
}
|
||
|
|
|
||
|
|
# Seconds since the epoch in the local calendar, so a UTC offset can be derived.
|
||
|
|
sub _days_from_civil {
|
||
|
|
my ($year, $month, $day) = @_;
|
||
|
|
$year -= $month <= 2 ? 1 : 0;
|
||
|
|
my $era = int(($year >= 0 ? $year : $year - 399) / 400);
|
||
|
|
my $yoe = $year - $era * 400;
|
||
|
|
my $doy = int((153 * ($month + ($month > 2 ? -3 : 9)) + 2) / 5) + $day - 1;
|
||
|
|
my $doe = $yoe * 365 + int($yoe / 4) - int($yoe / 100) + $doy;
|
||
|
|
return $era * 146097 + $doe - 719468;
|
||
|
|
}
|
||
|
|
|
||
|
|
# A +hhmm offset in the form strftime's %z prints. Perl's localtime reports
|
||
|
|
# no offset, so the same instant is read as both local and UTC calendar time and
|
||
|
|
# the difference is the offset.
|
||
|
|
sub utc_offset {
|
||
|
|
my ($t) = @_;
|
||
|
|
my @lt = localtime($t);
|
||
|
|
my @gt = gmtime($t);
|
||
|
|
my $offset = (_days_from_civil($lt[5] + 1900, $lt[4] + 1, $lt[3]) * 1440 + $lt[2] * 60 + $lt[1])
|
||
|
|
- (_days_from_civil($gt[5] + 1900, $gt[4] + 1, $gt[3]) * 1440 + $gt[2] * 60 + $gt[1]);
|
||
|
|
my $sign = $offset < 0 ? '-' : '+';
|
||
|
|
$offset = -$offset if $offset < 0;
|
||
|
|
return sprintf('%s%02d%02d', $sign, int($offset / 60), $offset % 60);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub timestamp_fields {
|
||
|
|
my ($t) = @_;
|
||
|
|
my @lt = localtime($t);
|
||
|
|
return sprintf('%04d-%02d-%02dT%02d:%02d:%02d%s',
|
||
|
|
$lt[5] + 1900, $lt[4] + 1, $lt[3], $lt[2], $lt[1], $lt[0], utc_offset($t));
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# JSON, written by hand
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub json_encode {
|
||
|
|
my ($value) = @_;
|
||
|
|
my $out = '';
|
||
|
|
json_render($value, '', 0, \$out);
|
||
|
|
return $out . "\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub json_quote {
|
||
|
|
my ($text) = @_;
|
||
|
|
my $bytes = $text;
|
||
|
|
# Non-ASCII escapes as \uXXXX, so the byte string is decoded to characters
|
||
|
|
# before escaping.
|
||
|
|
utf8::decode($bytes);
|
||
|
|
my $out = '"';
|
||
|
|
for my $char (split //, $bytes) {
|
||
|
|
my $code = ord($char);
|
||
|
|
if ($char eq '"') { $out .= '\\"' }
|
||
|
|
elsif ($char eq '\\') { $out .= '\\\\' }
|
||
|
|
elsif ($char eq "\b") { $out .= '\\b' }
|
||
|
|
elsif ($char eq "\f") { $out .= '\\f' }
|
||
|
|
elsif ($char eq "\n") { $out .= '\\n' }
|
||
|
|
elsif ($char eq "\r") { $out .= '\\r' }
|
||
|
|
elsif ($char eq "\t") { $out .= '\\t' }
|
||
|
|
elsif ($code < 0x20) { $out .= sprintf('\\u%04x', $code) }
|
||
|
|
elsif ($code > 0x7e) {
|
||
|
|
if ($code > 0xffff) {
|
||
|
|
my $rest = $code - 0x10000;
|
||
|
|
$out .= sprintf('\\u%04x\\u%04x', 0xd800 + ($rest >> 10), 0xdc00 + ($rest & 0x3ff));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$out .= sprintf('\\u%04x', $code);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else { $out .= $char }
|
||
|
|
}
|
||
|
|
return $out . '"';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub json_render {
|
||
|
|
my ($value, $path, $indent, $out) = @_;
|
||
|
|
if (!defined $value) {
|
||
|
|
$$out .= 'null';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if (ref $value eq 'HASH') {
|
||
|
|
my @keys = sort keys %$value;
|
||
|
|
if (!@keys) {
|
||
|
|
$$out .= '{}';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$$out .= "{\n";
|
||
|
|
for my $index (0 .. $#keys) {
|
||
|
|
my $key = $keys[$index];
|
||
|
|
my $child_path = length $path ? "$path.$key" : $key;
|
||
|
|
$$out .= (' ' x (2 * ($indent + 1))) . json_quote($key) . ': ';
|
||
|
|
json_render($value->{$key}, $child_path, $indent + 1, $out);
|
||
|
|
$$out .= ',' if $index < $#keys;
|
||
|
|
$$out .= "\n";
|
||
|
|
}
|
||
|
|
$$out .= (' ' x (2 * $indent)) . '}';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if (ref $value eq 'ARRAY') {
|
||
|
|
if (!@$value) {
|
||
|
|
$$out .= '[]';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$$out .= "[\n";
|
||
|
|
for my $index (0 .. $#$value) {
|
||
|
|
$$out .= ' ' x (2 * ($indent + 1));
|
||
|
|
json_render($value->[$index], $path, $indent + 1, $out);
|
||
|
|
$$out .= ',' if $index < $#$value;
|
||
|
|
$$out .= "\n";
|
||
|
|
}
|
||
|
|
$$out .= (' ' x (2 * $indent)) . ']';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if ($JSON_BOOLEAN{$path}) {
|
||
|
|
$$out .= $value ? 'true' : 'false';
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if (grep { $path =~ $_ } @JSON_STRING_PATHS) {
|
||
|
|
$$out .= json_quote("$value");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if ($value =~ /^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][-+]?[0-9]+)?$/) {
|
||
|
|
$$out .= $value;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$$out .= json_quote($value);
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: system overview
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub parse_os_release {
|
||
|
|
my %info;
|
||
|
|
for my $line (@{ read_lines('/etc/os-release') }) {
|
||
|
|
next unless index($line, '=') >= 0;
|
||
|
|
my ($key, $value) = split /=/, $line, 2;
|
||
|
|
$key =~ s/^\s+//;
|
||
|
|
$key =~ s/\s+$//;
|
||
|
|
$value = '' unless defined $value;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
$value =~ s/^"//;
|
||
|
|
$value =~ s/"$//;
|
||
|
|
$info{$key} = $value;
|
||
|
|
}
|
||
|
|
return \%info;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub uptime_human {
|
||
|
|
my ($seconds) = @_;
|
||
|
|
$seconds = int($seconds);
|
||
|
|
my $days = int($seconds / 86400);
|
||
|
|
my $rem = $seconds % 86400;
|
||
|
|
my $hours = int($rem / 3600);
|
||
|
|
my $minutes = int(($rem % 3600) / 60);
|
||
|
|
|
||
|
|
my @parts;
|
||
|
|
push @parts, $days . ' day' . ($days != 1 ? 's' : '') if $days;
|
||
|
|
push @parts, $hours . ' hour' . ($hours != 1 ? 's' : '') if $hours;
|
||
|
|
push @parts, $minutes . ' minute' . ($minutes != 1 ? 's' : '') if $minutes || !@parts;
|
||
|
|
return join(', ', @parts);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub boot_time {
|
||
|
|
for my $line (@{ read_lines('/proc/stat') }) {
|
||
|
|
next unless index($line, 'btime ') == 0;
|
||
|
|
my @fields = split ' ', $line;
|
||
|
|
next unless @fields >= 2 && $fields[1] =~ /^\d+$/;
|
||
|
|
my @lt = localtime($fields[1] + 0);
|
||
|
|
return sprintf('%04d-%02d-%02d %02d:%02d:%02d',
|
||
|
|
$lt[5] + 1900, $lt[4] + 1, $lt[3], $lt[2], $lt[1], $lt[0]);
|
||
|
|
}
|
||
|
|
return 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub load_average {
|
||
|
|
my $content = read_file('/proc/loadavg');
|
||
|
|
my @parts = split ' ', $content;
|
||
|
|
return (0.0, 0.0, 0.0) unless @parts >= 3;
|
||
|
|
for my $value (@parts[0 .. 2]) {
|
||
|
|
return (0.0, 0.0, 0.0) unless $value =~ /^\d+(?:\.\d+)?$/;
|
||
|
|
}
|
||
|
|
return ($parts[0] + 0, $parts[1] + 0, $parts[2] + 0);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub cpu_count {
|
||
|
|
# os.cpu_count() is the online processor count, which /sys reports as a list of
|
||
|
|
# ranges.
|
||
|
|
my $online = read_file('/sys/devices/system/cpu/online');
|
||
|
|
if (length $online) {
|
||
|
|
my $count = 0;
|
||
|
|
for my $part (split /,/, $online) {
|
||
|
|
if ($part =~ /^(\d+)-(\d+)$/) { $count += $2 - $1 + 1 }
|
||
|
|
elsif ($part =~ /^\d+$/) { $count += 1 }
|
||
|
|
}
|
||
|
|
return $count if $count > 0;
|
||
|
|
}
|
||
|
|
my $processors = 0;
|
||
|
|
for my $line (@{ read_lines('/proc/cpuinfo') }) {
|
||
|
|
$processors++ if index($line, 'processor') == 0;
|
||
|
|
}
|
||
|
|
return $processors > 0 ? $processors : 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub logged_users {
|
||
|
|
my $p = run(['who'], 15);
|
||
|
|
my %users;
|
||
|
|
for my $line (split /\n/, $p->{out}) {
|
||
|
|
next unless length $line;
|
||
|
|
my @fields = split ' ', $line;
|
||
|
|
$users{ $fields[0] } = 1 if @fields;
|
||
|
|
}
|
||
|
|
return scalar keys %users;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_overview {
|
||
|
|
my $os_info = parse_os_release();
|
||
|
|
my $os_name = $os_info->{PRETTY_NAME} // $os_info->{NAME} // 'unknown';
|
||
|
|
my ($load1, $load5, $load15) = load_average();
|
||
|
|
|
||
|
|
my $uptime_seconds = 0.0;
|
||
|
|
my $uptime_raw = read_file('/proc/uptime');
|
||
|
|
if (length $uptime_raw) {
|
||
|
|
my @parts = split ' ', $uptime_raw;
|
||
|
|
$uptime_seconds = $parts[0] + 0 if @parts && $parts[0] =~ /^\d+(?:\.\d+)?$/;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $hostname = read_file('/proc/sys/kernel/hostname');
|
||
|
|
return {
|
||
|
|
hostname => length $hostname ? $hostname : uname('-n'),
|
||
|
|
os => $os_name,
|
||
|
|
kernel => read_file('/proc/sys/kernel/osrelease'),
|
||
|
|
uptime_seconds => $uptime_seconds,
|
||
|
|
uptime_human => uptime_human($uptime_seconds),
|
||
|
|
load_1min => $load1,
|
||
|
|
load_5min => $load5,
|
||
|
|
load_15min => $load15,
|
||
|
|
cpu_cores => cpu_count(),
|
||
|
|
users_logged => logged_users(),
|
||
|
|
boot_time => boot_time(),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: CPU
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub cpu_model {
|
||
|
|
for my $line (@{ read_lines('/proc/cpuinfo') }) {
|
||
|
|
next unless index($line, 'model name') == 0;
|
||
|
|
my (undef, $value) = split /:/, $line, 2;
|
||
|
|
$value = '' unless defined $value;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
return 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub cpu_cores_threads {
|
||
|
|
my $cpuinfo = read_file('/proc/cpuinfo');
|
||
|
|
my %cores;
|
||
|
|
my $threads = 0;
|
||
|
|
my $physical_id = '0';
|
||
|
|
for my $line (split /\n/, $cpuinfo) {
|
||
|
|
if (index($line, 'physical id') == 0) {
|
||
|
|
my (undef, $value) = split /:/, $line, 2;
|
||
|
|
$value = '' unless defined $value;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
$physical_id = $value;
|
||
|
|
}
|
||
|
|
elsif (index($line, 'core id') == 0) {
|
||
|
|
my (undef, $value) = split /:/, $line, 2;
|
||
|
|
$value = '' unless defined $value;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
$cores{"$physical_id:$value"} = 1;
|
||
|
|
}
|
||
|
|
elsif (index($line, 'processor') == 0) {
|
||
|
|
$threads++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my $phys = keys %cores ? scalar(keys %cores) : cpu_count();
|
||
|
|
return ($phys, $threads ? $threads : cpu_count());
|
||
|
|
}
|
||
|
|
|
||
|
|
sub cpu_frequency {
|
||
|
|
for my $line (@{ read_lines('/proc/cpuinfo') }) {
|
||
|
|
next unless index(lc($line), 'cpu mhz') >= 0;
|
||
|
|
my (undef, $value) = split /:/, $line, 2;
|
||
|
|
$value = '' unless defined $value;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
return "$value MHz";
|
||
|
|
}
|
||
|
|
my $freq = read_file('/sys/devices/system/cpu/cpu0/cpufreq/scaling_cur_freq');
|
||
|
|
if (length $freq && $freq =~ /^\d+$/) {
|
||
|
|
return sprintf('%.0f MHz', $freq / 1000);
|
||
|
|
}
|
||
|
|
return 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub cpu_temperature {
|
||
|
|
my $base = '/sys/class/hwmon';
|
||
|
|
return 'unknown' unless -d $base;
|
||
|
|
my @entries;
|
||
|
|
if (opendir(my $dh, $base)) {
|
||
|
|
@entries = sort grep { $_ ne '.' && $_ ne '..' } readdir($dh);
|
||
|
|
closedir($dh);
|
||
|
|
}
|
||
|
|
for my $entry (@entries) {
|
||
|
|
my $name = lc(read_file("$base/$entry/name"));
|
||
|
|
next unless $name eq 'coretemp' || $name eq 'k10temp'
|
||
|
|
|| $name eq 'cpu_thermal' || $name eq 'acpitz';
|
||
|
|
for my $index (1 .. 4) {
|
||
|
|
my $temp_raw = read_file("$base/$entry/temp${index}_input");
|
||
|
|
next unless length $temp_raw;
|
||
|
|
return sprintf('%.1f', $temp_raw / 1000.0) . "°C" if $temp_raw =~ /^-?\d+$/;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub parse_cpu_fields {
|
||
|
|
my ($line) = @_;
|
||
|
|
my @fields = split ' ', $line;
|
||
|
|
return () if @fields < 9;
|
||
|
|
my @values = @fields[1 .. 8];
|
||
|
|
for my $value (@values) {
|
||
|
|
return () unless defined $value && $value =~ /^\d+$/;
|
||
|
|
}
|
||
|
|
return @values;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub read_cpu_times {
|
||
|
|
my @aggregate;
|
||
|
|
my @per_core;
|
||
|
|
for my $line (@{ read_lines('/proc/stat') }) {
|
||
|
|
if (index($line, 'cpu ') == 0) {
|
||
|
|
@aggregate = parse_cpu_fields($line);
|
||
|
|
}
|
||
|
|
elsif (substr($line, 0, 3) eq 'cpu' && substr($line, 3, 1) =~ /^\d$/) {
|
||
|
|
my @fields = parse_cpu_fields($line);
|
||
|
|
push @per_core, \@fields if @fields;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return (\@aggregate, \@per_core);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub usage_percent {
|
||
|
|
my ($times1, $times2) = @_;
|
||
|
|
return '0.0' unless @$times1 >= 5 && @$times2 >= 5;
|
||
|
|
# iowait counts as idle: a process waiting on disk is not using the CPU.
|
||
|
|
my $idle_delta = ($times2->[3] + $times2->[4]) - ($times1->[3] + $times1->[4]);
|
||
|
|
my $total_delta = 0;
|
||
|
|
$total_delta += $times2->[$_] - $times1->[$_] for 0 .. $#$times2;
|
||
|
|
return '0.0' if $total_delta <= 0;
|
||
|
|
return sprintf('%.1f', (1 - $idle_delta / $total_delta) * 100);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub cpu_usage {
|
||
|
|
my ($sample_interval) = @_;
|
||
|
|
$sample_interval = 0.2 unless defined $sample_interval;
|
||
|
|
my ($agg1, $cores1) = read_cpu_times();
|
||
|
|
select(undef, undef, undef, $sample_interval);
|
||
|
|
my ($agg2, $cores2) = read_cpu_times();
|
||
|
|
|
||
|
|
my @per_core;
|
||
|
|
my $count = @$cores1 < @$cores2 ? scalar(@$cores1) : scalar(@$cores2);
|
||
|
|
for my $index (0 .. $count - 1) {
|
||
|
|
push @per_core, {
|
||
|
|
cpu => "$index",
|
||
|
|
usage_pct => usage_percent($cores1->[$index], $cores2->[$index]),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
return (usage_percent($agg1, $agg2), \@per_core);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_cpu {
|
||
|
|
my ($phys_cores, $threads) = cpu_cores_threads();
|
||
|
|
my ($usage, $per_core) = cpu_usage();
|
||
|
|
|
||
|
|
return {
|
||
|
|
model => cpu_model(),
|
||
|
|
architecture => uname('-m'),
|
||
|
|
physical_cores => $phys_cores,
|
||
|
|
threads => $threads,
|
||
|
|
frequency => cpu_frequency(),
|
||
|
|
temperature => cpu_temperature(),
|
||
|
|
usage_pct => $usage,
|
||
|
|
per_core => $per_core,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: memory
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub parse_meminfo {
|
||
|
|
my %mem;
|
||
|
|
for my $line (@{ read_lines('/proc/meminfo') }) {
|
||
|
|
my @parts = split ' ', $line;
|
||
|
|
next unless @parts >= 2;
|
||
|
|
my $key = $parts[0];
|
||
|
|
$key =~ s/:$//;
|
||
|
|
$mem{$key} = $parts[1] + 0 if $parts[1] =~ /^\d+$/;
|
||
|
|
}
|
||
|
|
return \%mem;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub top_mem_processes {
|
||
|
|
my ($count) = @_;
|
||
|
|
$count = 5 unless defined $count;
|
||
|
|
my $p = run(['ps', '-eo', 'pid,user,rss,comm', '--sort=-rss', '--no-headers'], 5);
|
||
|
|
my @procs;
|
||
|
|
my @lines = split /\n/, $p->{out};
|
||
|
|
for my $line (@lines[0 .. ($count - 1 > $#lines ? $#lines : $count - 1)]) {
|
||
|
|
next unless defined $line;
|
||
|
|
my @parts = split ' ', $line, 4;
|
||
|
|
next unless @parts >= 4;
|
||
|
|
next unless $parts[0] =~ /^\d+$/ && $parts[2] =~ /^\d+$/;
|
||
|
|
push @procs, {
|
||
|
|
pid => $parts[0] + 0,
|
||
|
|
user => $parts[1],
|
||
|
|
rss_mb => sprintf('%.1f', $parts[2] / 1024),
|
||
|
|
command => $parts[3],
|
||
|
|
};
|
||
|
|
}
|
||
|
|
return \@procs;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_memory {
|
||
|
|
my $mem = parse_meminfo();
|
||
|
|
my %m = map { $_ => ($mem->{$_} // 0) } keys %$mem;
|
||
|
|
|
||
|
|
my $total = int(($m{MemTotal} // 0) / 1024);
|
||
|
|
my $free = int(($m{MemFree} // 0) / 1024);
|
||
|
|
my $available = int(($m{MemAvailable} // 0) / 1024);
|
||
|
|
my $used = $available ? $total - $available : $total - $free;
|
||
|
|
|
||
|
|
my $swap_total = int(($m{SwapTotal} // 0) / 1024);
|
||
|
|
my $swap_free = int(($m{SwapFree} // 0) / 1024);
|
||
|
|
my $swap_used = $swap_total - $swap_free;
|
||
|
|
|
||
|
|
return {
|
||
|
|
total_mb => $total,
|
||
|
|
used_mb => $used,
|
||
|
|
free_mb => $free,
|
||
|
|
available_mb => $available,
|
||
|
|
usage_pct => $total > 0 ? sprintf('%.1f', $used / $total * 100) : '0.0',
|
||
|
|
swap_total_mb => $swap_total,
|
||
|
|
swap_used_mb => $swap_used,
|
||
|
|
swap_usage_pct => $swap_total > 0 ? sprintf('%.1f', $swap_used / $swap_total * 100) : '0.0',
|
||
|
|
top_processes => top_mem_processes(),
|
||
|
|
buffers_mb => int(($m{Buffers} // 0) / 1024),
|
||
|
|
cached_mb => int(($m{Cached} // 0) / 1024),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: disk
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub skip_filesystem {
|
||
|
|
my ($fs_type, $device) = @_;
|
||
|
|
my %excluded = map { $_ => 1 } qw(
|
||
|
|
tmpfs devtmpfs squashfs overlay proc sysfs devpts cgroup cgroup2 pstore bpf
|
||
|
|
debugfs tracefs securityfs hugetlbfs fuse.gvfsd-fuse fuse.portal ramfs
|
||
|
|
efivarfs configfs selinuxfs systemd-1 mqueue fusectl sunrpc binfmt_misc
|
||
|
|
autofs rpc_pipefs nsfs
|
||
|
|
);
|
||
|
|
return 1 if $excluded{$fs_type};
|
||
|
|
return 1 if index($device, 'tmpfs') == 0 || index($device, 'devtmpfs') == 0;
|
||
|
|
# Network filesystems: stat() blocks in uninterruptible I/O while the server is
|
||
|
|
# unreachable, which would stall the whole report.
|
||
|
|
for my $prefix ('nfs', 'cifs', 'smbfs', 'ncpfs', 'sshfs', '9p', 'afs') {
|
||
|
|
return 1 if index($fs_type, $prefix) == 0;
|
||
|
|
}
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# The four numbers statvfs would have given, through stat(1), which reports the
|
||
|
|
# same fields: total blocks, free blocks, blocks available to unprivileged users,
|
||
|
|
# and the fundamental block size.
|
||
|
|
sub filesystem_stats {
|
||
|
|
my ($mountpoint) = @_;
|
||
|
|
my $p = run(['stat', '-f', '-c', '%b %f %a %S', '--', $mountpoint], 5);
|
||
|
|
return undef if $p->{rc} != 0;
|
||
|
|
my @fields = split ' ', $p->{out};
|
||
|
|
return undef unless @fields >= 4;
|
||
|
|
for my $value (@fields[0 .. 3]) {
|
||
|
|
return undef unless $value =~ /^\d+$/;
|
||
|
|
}
|
||
|
|
return {
|
||
|
|
blocks => $fields[0] + 0,
|
||
|
|
frsize => $fields[3] + 0,
|
||
|
|
avail => $fields[2] + 0,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# The kernel octal-escapes space, tab, newline and backslash in the mount point
|
||
|
|
# field of /proc/mounts, and stat() needs the decoded path.
|
||
|
|
sub unescape_mount_point {
|
||
|
|
my ($text) = @_;
|
||
|
|
$text =~ s/\\(040|011|012|134)/chr(oct($1))/eg;
|
||
|
|
return $text;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub mounts {
|
||
|
|
my @fs_list;
|
||
|
|
my %seen_devices;
|
||
|
|
for my $line (@{ read_lines('/proc/mounts') }) {
|
||
|
|
my @parts = split ' ', $line;
|
||
|
|
next if @parts < 6;
|
||
|
|
my ($device, $mountpoint, $fs_type) = @parts[0 .. 2];
|
||
|
|
next if skip_filesystem($fs_type, $device);
|
||
|
|
$mountpoint = unescape_mount_point($mountpoint);
|
||
|
|
my @st = stat($mountpoint);
|
||
|
|
next unless @st;
|
||
|
|
my $st_dev = $st[0];
|
||
|
|
next if $seen_devices{$st_dev}++;
|
||
|
|
my $fs = filesystem_stats($mountpoint);
|
||
|
|
next unless defined $fs;
|
||
|
|
my $total = $fs->{blocks} * $fs->{frsize};
|
||
|
|
my $available = $fs->{avail} * $fs->{frsize};
|
||
|
|
my $used = $total - $available;
|
||
|
|
|
||
|
|
push @fs_list, {
|
||
|
|
device => $device,
|
||
|
|
mountpoint => $mountpoint,
|
||
|
|
fstype => $fs_type,
|
||
|
|
size_gb => sprintf('%.1f', $total / (1024**3)),
|
||
|
|
used_gb => sprintf('%.1f', $used / (1024**3)),
|
||
|
|
available_gb => sprintf('%.1f', $available / (1024**3)),
|
||
|
|
use_pct => $total > 0 ? sprintf('%.1f', $used / $total * 100) : '0.0',
|
||
|
|
};
|
||
|
|
}
|
||
|
|
return \@fs_list;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub disk_io_stats {
|
||
|
|
my $p = run(['iostat', '-d', '-x', '1', '2'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
return undef unless length $out;
|
||
|
|
|
||
|
|
# Split into report blocks, each starting at a Device header.
|
||
|
|
my @blocks;
|
||
|
|
my @current;
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
if (index($line, 'Device') >= 0 && index($line, 'r/s') >= 0) {
|
||
|
|
push @blocks, [@current] if @current;
|
||
|
|
@current = ($line);
|
||
|
|
}
|
||
|
|
elsif (@current) {
|
||
|
|
push @current, $line;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
push @blocks, [@current] if @current;
|
||
|
|
return undef unless @blocks;
|
||
|
|
|
||
|
|
my $lines = $blocks[-1];
|
||
|
|
my @header = split ' ', $lines->[0];
|
||
|
|
my %columns;
|
||
|
|
for my $index (0 .. $#header) {
|
||
|
|
$columns{ $header[$index] } = $index;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $value = sub {
|
||
|
|
my ($parts, @names) = @_;
|
||
|
|
for my $name (@names) {
|
||
|
|
my $index = $columns{$name};
|
||
|
|
next unless defined $index && $index < @$parts;
|
||
|
|
return $parts->[$index] =~ /^-?\d+(?:\.\d+)?$/ ? $parts->[$index] + 0 : 0.0;
|
||
|
|
}
|
||
|
|
return 0.0;
|
||
|
|
};
|
||
|
|
|
||
|
|
# Throughput in MB/s: the kB/s column current sysstat prints is converted, but
|
||
|
|
# the MB/s column older sysstat printed is already in the unit asked for, so
|
||
|
|
# dividing that one as well would report a value 1024 times too small.
|
||
|
|
my $rate_mb_s = sub {
|
||
|
|
my ($parts, $kb_name, $mb_name) = @_;
|
||
|
|
for my $candidate ([$kb_name, 1024], [$mb_name, 1]) {
|
||
|
|
my ($name, $divisor) = @$candidate;
|
||
|
|
my $index = $columns{$name};
|
||
|
|
next unless defined $index && $index < @$parts;
|
||
|
|
return $parts->[$index] =~ /^-?\d+(?:\.\d+)?$/ ? $parts->[$index] / $divisor : 0.0;
|
||
|
|
}
|
||
|
|
return 0.0;
|
||
|
|
};
|
||
|
|
|
||
|
|
my @devices;
|
||
|
|
for my $line (@$lines[1 .. $#$lines]) {
|
||
|
|
my @parts = split ' ', $line;
|
||
|
|
next unless @parts;
|
||
|
|
next if $parts[0] eq 'Device';
|
||
|
|
my $reads = $value->(\@parts, 'r/s');
|
||
|
|
my $writes = $value->(\@parts, 'w/s');
|
||
|
|
push @devices, {
|
||
|
|
device => $parts[0],
|
||
|
|
tps => sprintf('%.2f', $reads + $writes),
|
||
|
|
read_mb_s => sprintf('%.2f', $rate_mb_s->(\@parts, 'rkB/s', 'rMB/s')),
|
||
|
|
write_mb_s => sprintf('%.2f', $rate_mb_s->(\@parts, 'wkB/s', 'wMB/s')),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
return @devices ? { devices => \@devices } : undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub in_container {
|
||
|
|
return 1 if -e '/run/.containerenv' || -e '/.dockerenv';
|
||
|
|
for my $line (@{ read_lines('/proc/mounts') }) {
|
||
|
|
my @parts = split ' ', $line;
|
||
|
|
return 1 if @parts >= 3 && $parts[1] eq '/' && $parts[2] eq 'overlay';
|
||
|
|
}
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_disk {
|
||
|
|
my $mounts = mounts();
|
||
|
|
my $total_gb = 0;
|
||
|
|
my $used_gb = 0;
|
||
|
|
for my $mount (@$mounts) {
|
||
|
|
$total_gb += $mount->{size_gb};
|
||
|
|
$used_gb += $mount->{used_gb};
|
||
|
|
}
|
||
|
|
my @critical = grep { $_->{use_pct} > 90 } @$mounts;
|
||
|
|
|
||
|
|
return {
|
||
|
|
filesystems => $mounts,
|
||
|
|
total_gb => sprintf('%.1f', $total_gb),
|
||
|
|
used_gb => sprintf('%.1f', $used_gb),
|
||
|
|
usage_pct => $total_gb > 0 ? sprintf('%.1f', $used_gb / $total_gb * 100) : '0.0',
|
||
|
|
critical_fs => \@critical,
|
||
|
|
io_stats => disk_io_stats(),
|
||
|
|
container => in_container(),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: network
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub net_interfaces {
|
||
|
|
my @ifaces;
|
||
|
|
my $net_path = '/sys/class/net';
|
||
|
|
return \@ifaces unless -d $net_path;
|
||
|
|
my @entries;
|
||
|
|
if (opendir(my $dh, $net_path)) {
|
||
|
|
@entries = sort grep { $_ ne '.' && $_ ne '..' } readdir($dh);
|
||
|
|
closedir($dh);
|
||
|
|
}
|
||
|
|
|
||
|
|
for my $iface (@entries) {
|
||
|
|
next if $iface eq 'lo';
|
||
|
|
my $operstate = read_file("$net_path/$iface/operstate");
|
||
|
|
my $speed_raw = read_file("$net_path/$iface/speed");
|
||
|
|
my $speed = length($speed_raw) && $speed_raw ne '-1' ? "$speed_raw Mbps" : 'unknown';
|
||
|
|
|
||
|
|
my $p = run(['ip', '-br', 'addr', 'show', $iface], 5);
|
||
|
|
my (@ipv4, @ipv6);
|
||
|
|
my $out = $p->{out};
|
||
|
|
if (length $out) {
|
||
|
|
my @parts = split ' ', $out;
|
||
|
|
my $skip_next = 0;
|
||
|
|
for my $part (@parts[2 .. $#parts]) {
|
||
|
|
next unless defined $part;
|
||
|
|
if ($part eq 'peer') {
|
||
|
|
$skip_next = 1; # the next token is the remote end's address
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
if ($skip_next) { $skip_next = 0; next }
|
||
|
|
if (index($part, '.') >= 0 && index($part, '/') >= 0) {
|
||
|
|
my ($address) = split /\//, $part, 2;
|
||
|
|
push @ipv4, $address;
|
||
|
|
}
|
||
|
|
elsif (index($part, ':') >= 0 && index($part, '/') >= 0) {
|
||
|
|
my ($address) = split /\//, $part, 2;
|
||
|
|
push @ipv6, $address;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
push @ifaces, {
|
||
|
|
name => $iface,
|
||
|
|
state => length($operstate) ? uc($operstate) : 'UNKNOWN',
|
||
|
|
speed => $speed,
|
||
|
|
ipv4 => \@ipv4,
|
||
|
|
ipv6 => \@ipv6,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
return \@ifaces;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub connection_summary {
|
||
|
|
my $p = run(['ss', '-s'], 5);
|
||
|
|
my %result;
|
||
|
|
for my $line (split /\n/, $p->{out}) {
|
||
|
|
if (index($line, 'TCP:') >= 0) {
|
||
|
|
$result{tcp_established} = $1 + 0 if $line =~ /estab\s+(\d+)/;
|
||
|
|
}
|
||
|
|
if (index($line, 'Total:') >= 0) {
|
||
|
|
$result{total} = $1 + 0 if $line =~ /(\d+)/;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return \%result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub default_routes {
|
||
|
|
my %routes = (v6 => '', v4 => '');
|
||
|
|
my $p = run(['ip', '-6', 'route', 'show', 'default'], 5);
|
||
|
|
my $out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
$routes{v6} = $out if length $out;
|
||
|
|
$p = run(['ip', '-4', 'route', 'show', 'default'], 5);
|
||
|
|
$out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
$routes{v4} = $out if length $out;
|
||
|
|
return \%routes;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Whether a string is an IPv4 or an IPv6 address.
|
||
|
|
sub is_address {
|
||
|
|
my ($text) = @_;
|
||
|
|
return 0 unless length $text;
|
||
|
|
if (index($text, ':') >= 0) {
|
||
|
|
return _valid_ipv6($text);
|
||
|
|
}
|
||
|
|
my @octets = split /\./, $text, -1;
|
||
|
|
return 0 unless @octets == 4;
|
||
|
|
for my $octet (@octets) {
|
||
|
|
return 0 unless $octet =~ /^\d{1,3}$/ && $octet <= 255;
|
||
|
|
}
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _valid_ipv6 {
|
||
|
|
my ($ip) = @_;
|
||
|
|
$ip =~ s/%.*//;
|
||
|
|
return 0 unless $ip =~ /^[0-9a-fA-F:.]+$/ && index($ip, ':') >= 0;
|
||
|
|
my ($head, $tail) = ($ip, '');
|
||
|
|
my $shorthand = 0;
|
||
|
|
if (index($ip, '::') >= 0) {
|
||
|
|
($head, $tail) = split /::/, $ip, 2;
|
||
|
|
$shorthand = 1;
|
||
|
|
}
|
||
|
|
my @head = length($head // '') ? split(/:/, $head, -1) : ();
|
||
|
|
my @tail = length($tail // '') ? split(/:/, $tail, -1) : ();
|
||
|
|
if (@tail && $tail[-1] =~ /\./) {
|
||
|
|
my $quad = pop @tail;
|
||
|
|
my @octets = split /\./, $quad, -1;
|
||
|
|
return 0 unless @octets == 4;
|
||
|
|
for my $octet (@octets) {
|
||
|
|
return 0 unless $octet =~ /^\d{1,3}$/ && $octet <= 255;
|
||
|
|
}
|
||
|
|
push @tail, '0', '0';
|
||
|
|
}
|
||
|
|
return 0 if @head + @tail > ($shorthand ? 7 : 8);
|
||
|
|
my @groups = $shorthand
|
||
|
|
? (@head, (0) x (8 - @head - @tail), @tail)
|
||
|
|
: (@head, @tail);
|
||
|
|
return 0 unless @groups == 8;
|
||
|
|
for my $group (@groups) {
|
||
|
|
return 0 unless $group =~ /^[0-9a-fA-F]{1,4}$/;
|
||
|
|
}
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub external_ip {
|
||
|
|
my %result = (v6 => 'unknown', v4 => 'unknown');
|
||
|
|
for my $item (['v6', '-6'], ['v4', '-4']) {
|
||
|
|
my ($family, $flag) = @$item;
|
||
|
|
# -f fails on HTTP errors; without it a captive portal or an error page
|
||
|
|
# would be accepted as the external address.
|
||
|
|
my $p = run(['curl', $flag, '--max-time', '5', '-fsS', 'https://icanhazip.com'], 8);
|
||
|
|
my $body = $p->{out};
|
||
|
|
$body =~ s/^\s+//;
|
||
|
|
$body =~ s/\s+$//;
|
||
|
|
next unless is_address($body);
|
||
|
|
$result{$family} = $body;
|
||
|
|
}
|
||
|
|
return \%result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_network {
|
||
|
|
my ($include_external) = @_;
|
||
|
|
my %data = (
|
||
|
|
interfaces => net_interfaces(),
|
||
|
|
connections => connection_summary(),
|
||
|
|
routes => default_routes(),
|
||
|
|
);
|
||
|
|
$data{external_ip} = external_ip() if $include_external;
|
||
|
|
return \%data;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: GPU
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# The vendor side of the GPU section reports both sources together: AMD in detail
|
||
|
|
# through rocm-smi, which brings memory and utilisation, and AMD, Intel and Huawei
|
||
|
|
# cards through lspci, which needs no vendor tooling at all. A compute device with
|
||
|
|
# no display class, such as an Instinct or an Ascend, is reached through its PCI
|
||
|
|
# identifier instead, and an AMD card rocm-smi has already described is not listed
|
||
|
|
# twice.
|
||
|
|
|
||
|
|
# Matches rocm-smi data lines across ROCm versions, with or without the bracketed
|
||
|
|
# card index: "GPU[0]\t\t: Card series:\t…" and "GPU\t\t: …".
|
||
|
|
my $ROCM_LINE = qr/^GPU(?:\[(\d+)\])?\s*:\s*([^:]+?)\s*:\s*(.+)$/;
|
||
|
|
|
||
|
|
sub rocm_smi_bin {
|
||
|
|
my $found = find_exe('rocm-smi');
|
||
|
|
return $found if defined $found;
|
||
|
|
my $default = '/opt/rocm/bin/rocm-smi';
|
||
|
|
return -f $default ? $default : undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub rocm_vram {
|
||
|
|
my ($binary) = @_;
|
||
|
|
my $p = run([$binary, '--showmeminfo', 'vram'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
return undef unless length $out;
|
||
|
|
|
||
|
|
my ($total_bytes, $used_bytes) = (0, 0);
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
my $stripped = $line;
|
||
|
|
$stripped =~ s/^\s+//;
|
||
|
|
$stripped =~ s/\s+$//;
|
||
|
|
next unless $stripped =~ $ROCM_LINE;
|
||
|
|
my $key = $2;
|
||
|
|
$key =~ s/^\s+//;
|
||
|
|
$key =~ s/\s+$//;
|
||
|
|
my $raw = $3;
|
||
|
|
my @fields = split ' ', $raw;
|
||
|
|
next unless @fields && $fields[0] =~ /^\d+$/;
|
||
|
|
my $value = $fields[0] + 0;
|
||
|
|
# Keys are matched exactly: "VRAM Total Used Memory (B)" contains both words
|
||
|
|
# "Total" and "Used", so substring matching would double-count.
|
||
|
|
if ($key eq 'VRAM Total Used Memory (B)') { $used_bytes += $value }
|
||
|
|
elsif ($key eq 'VRAM Total Memory (B)') { $total_bytes += $value }
|
||
|
|
}
|
||
|
|
|
||
|
|
return undef if $total_bytes <= 0;
|
||
|
|
my $mib = 1024 * 1024;
|
||
|
|
return {
|
||
|
|
total_mb => int($total_bytes / $mib),
|
||
|
|
used_mb => int($used_bytes / $mib),
|
||
|
|
free_mb => int(($total_bytes - $used_bytes) / $mib),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub amd_gpu {
|
||
|
|
my $binary = rocm_smi_bin();
|
||
|
|
return undef unless defined $binary;
|
||
|
|
my $p = run([$binary, '--showproductname', '--showuse'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
return undef unless length $out;
|
||
|
|
|
||
|
|
# Every rocm-smi data line is prefixed with "GPU[N] :", so the pairs are grouped
|
||
|
|
# by card: looping per line would make one card per line.
|
||
|
|
my %cards;
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
my $stripped = $line;
|
||
|
|
$stripped =~ s/^\s+//;
|
||
|
|
$stripped =~ s/\s+$//;
|
||
|
|
next unless $stripped =~ $ROCM_LINE;
|
||
|
|
my $card_id = defined $1 && length $1 ? $1 : '0';
|
||
|
|
my $key = $2;
|
||
|
|
$key =~ s/^\s+//;
|
||
|
|
$key =~ s/\s+$//;
|
||
|
|
my $value = $3;
|
||
|
|
$value =~ s/^\s+//;
|
||
|
|
$value =~ s/\s+$//;
|
||
|
|
$cards{$card_id} = { id => $card_id } unless exists $cards{$card_id};
|
||
|
|
$cards{$card_id}{$key} = $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
return undef unless %cards;
|
||
|
|
my %info = (vendor => 'AMD', cards => [ map { $cards{$_} } sort keys %cards ]);
|
||
|
|
my $vram = rocm_vram($binary);
|
||
|
|
$info{vram} = $vram if $vram;
|
||
|
|
return \%info;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub lspci_gpu {
|
||
|
|
return { unavailable => 1 } unless defined find_exe('lspci');
|
||
|
|
my $p = run(['lspci'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
return { unavailable => 1 } unless length $out;
|
||
|
|
my @cards;
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
my $lower = lc($line);
|
||
|
|
next unless index($lower, 'vga') >= 0 || index($lower, 'display') >= 0
|
||
|
|
|| index($lower, '3d') >= 0;
|
||
|
|
my @parts = split /: /, $line, 3;
|
||
|
|
my $model = @parts >= 2 ? $parts[-1] : $line;
|
||
|
|
$model =~ s/^\s+//;
|
||
|
|
$model =~ s/\s+$//;
|
||
|
|
my $vendor = '';
|
||
|
|
# The vendor names are matched as words, never as substrings: "ati" is
|
||
|
|
# inside "Corporation", so a substring match would report every Intel card
|
||
|
|
# as AMD.
|
||
|
|
$vendor = 'AMD' if $lower =~ /\b(?:amd|radeon|ati)\b/;
|
||
|
|
$vendor = 'Intel' if !length $vendor && $lower =~ /\bintel\b/;
|
||
|
|
$vendor = 'Huawei' if !length $vendor && $lower =~ /\b(?:huawei|hisilicon|ascend)\b/;
|
||
|
|
push @cards, { model => $model, vendor => $vendor, driver => '(not loaded)' };
|
||
|
|
}
|
||
|
|
if (!@cards) {
|
||
|
|
# Probe for compute devices that carry no display class, such as an AMD
|
||
|
|
# Instinct or a Huawei Ascend: they answer to the vendor's PCI identifier and
|
||
|
|
# would otherwise be missed entirely.
|
||
|
|
for my $probe (['1002:', 'AMD'], ['19e5:', 'Huawei']) {
|
||
|
|
my ($id, $vendor) = @$probe;
|
||
|
|
my $p2 = run(['lspci', '-d', $id], 10);
|
||
|
|
for my $line (split /\n/, $p2->{out}) {
|
||
|
|
my $stripped = $line;
|
||
|
|
$stripped =~ s/^\s+//;
|
||
|
|
$stripped =~ s/\s+$//;
|
||
|
|
next unless length $stripped;
|
||
|
|
push @cards, { model => $stripped, vendor => $vendor, driver => '(not loaded)' };
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return undef unless @cards;
|
||
|
|
return {
|
||
|
|
vendor => length($cards[0]{vendor}) ? $cards[0]{vendor} : 'unknown',
|
||
|
|
cards => \@cards,
|
||
|
|
fallback => 1,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Both sources are reported together: the cards rocm-smi describes come first,
|
||
|
|
# with their memory and utilisation, and every other card lspci can see is
|
||
|
|
# appended, so a machine with an AMD card and an Intel or Huawei one reports all
|
||
|
|
# of them. The fallback flag still means what it means: nothing but lspci
|
||
|
|
# answered.
|
||
|
|
sub collect_gpu {
|
||
|
|
my $amd = amd_gpu();
|
||
|
|
my $lspci = lspci_gpu();
|
||
|
|
my $extra = [];
|
||
|
|
if ($lspci && !$lspci->{unavailable}) {
|
||
|
|
# An AMD card rocm-smi already described must not be listed twice, but with no
|
||
|
|
# rocm-smi answer lspci's AMD card is the only one there is.
|
||
|
|
$extra = [ grep { !$amd || !length $_->{vendor} || $_->{vendor} ne 'AMD' }
|
||
|
|
@{ $lspci->{cards} } ];
|
||
|
|
}
|
||
|
|
|
||
|
|
my @cards = (($amd ? @{ $amd->{cards} } : ()), @$extra);
|
||
|
|
return $lspci unless @cards;
|
||
|
|
|
||
|
|
# The AMD cards come from rocm-smi, which does not label them with a vendor, so
|
||
|
|
# the summary takes AMD from its source and the rest from the cards themselves.
|
||
|
|
my @vendor_list = $amd ? ('AMD') : ();
|
||
|
|
push @vendor_list, map { $_->{vendor} // '' } @$extra;
|
||
|
|
my %seen_vendor;
|
||
|
|
my @vendors = grep { length && !$seen_vendor{$_}++ } @vendor_list;
|
||
|
|
my %info = (
|
||
|
|
vendor => @vendors ? join(', ', @vendors) : 'unknown',
|
||
|
|
cards => \@cards,
|
||
|
|
);
|
||
|
|
$info{vram} = $amd->{vram} if $amd && $amd->{vram};
|
||
|
|
$info{fallback} = 1 unless $amd;
|
||
|
|
return \%info;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: services
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub failed_units {
|
||
|
|
return undef unless defined find_exe('systemctl');
|
||
|
|
# --plain is required: without it systemd prefixes failed units with a bullet
|
||
|
|
# even when the output is piped, which breaks field parsing.
|
||
|
|
my $p = run(['systemctl', '--failed', '--no-legend', '--no-pager', '--plain'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
my @units;
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
# The columns are unit, load, active, sub, description: the unit's own state
|
||
|
|
# is the sub column, not the load column.
|
||
|
|
my @parts = split ' ', $line, 5;
|
||
|
|
next if @parts < 4;
|
||
|
|
push @units, { unit => $parts[0], state => $parts[3] };
|
||
|
|
}
|
||
|
|
return \@units;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub check_service {
|
||
|
|
my ($name) = @_;
|
||
|
|
my $p = run(['systemctl', 'is-active', $name, '--no-pager'], 5);
|
||
|
|
my $status = $p->{out};
|
||
|
|
$status =~ s/^\s+//;
|
||
|
|
$status =~ s/\s+$//;
|
||
|
|
return { name => $name, status => length $status ? $status : 'not-found' };
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_services {
|
||
|
|
my @key_services = qw(sshd firewalld nginx postgresql);
|
||
|
|
my %svc_status;
|
||
|
|
$svc_status{$_} = check_service($_) for @key_services;
|
||
|
|
return {
|
||
|
|
failed_units => failed_units(),
|
||
|
|
key_services => \%svc_status,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: security
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub selinux_status {
|
||
|
|
my $p = run(['getenforce'], 5);
|
||
|
|
my $out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
return length $out ? $out : 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
sub firewalld_info {
|
||
|
|
my %result = (available => 0, active => 0, default_zone => '', zones => []);
|
||
|
|
my $p = run(['firewall-cmd', '--state'], 5);
|
||
|
|
my $state = $p->{out};
|
||
|
|
$state =~ s/^\s+//;
|
||
|
|
$state =~ s/\s+$//;
|
||
|
|
return \%result unless length $state;
|
||
|
|
$result{available} = 1;
|
||
|
|
$result{active} = $state eq 'running' ? 1 : 0;
|
||
|
|
|
||
|
|
$p = run(['firewall-cmd', '--get-default-zone'], 5);
|
||
|
|
my $zone = $p->{out};
|
||
|
|
$zone =~ s/^\s+//;
|
||
|
|
$zone =~ s/\s+$//;
|
||
|
|
$result{default_zone} = $zone if length $zone;
|
||
|
|
|
||
|
|
$p = run(['firewall-cmd', '--get-active-zones'], 5);
|
||
|
|
my $out = $p->{out};
|
||
|
|
if (length $out) {
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
my $stripped = $line;
|
||
|
|
$stripped =~ s/^\s+//;
|
||
|
|
$stripped =~ s/\s+$//;
|
||
|
|
# Zone names sit at column 0; member lines are indented, so the
|
||
|
|
# indentation has to be checked before stripping.
|
||
|
|
next unless length $stripped;
|
||
|
|
next if index($line, ' ') == 0 || index($line, "\t") == 0;
|
||
|
|
push @{ $result{zones} }, $stripped;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return \%result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub failed_ssh_attempts {
|
||
|
|
my $p = run(['journalctl', '-u', 'sshd', '--since', 'today', '--no-pager'], 10);
|
||
|
|
my $out = $p->{out};
|
||
|
|
if (!length $out) {
|
||
|
|
# Fall back to the "ssh" unit name used by some distributions.
|
||
|
|
$p = run(['journalctl', '-u', 'ssh', '--since', 'today', '--no-pager'], 10);
|
||
|
|
$out = $p->{out};
|
||
|
|
}
|
||
|
|
my $lower = lc($out);
|
||
|
|
my $count = () = $lower =~ /failed password/g;
|
||
|
|
return $count;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub last_logins {
|
||
|
|
my ($count) = @_;
|
||
|
|
$count = 3 unless defined $count;
|
||
|
|
my $p = run(['last', '-n', "$count", '--no-hostname'], 5);
|
||
|
|
my @logins;
|
||
|
|
for my $line (split /\n/, $p->{out}) {
|
||
|
|
next unless length $line;
|
||
|
|
my $lower = lc($line);
|
||
|
|
next if index($lower, 'reboot') >= 0 || index($lower, 'wtmp') >= 0;
|
||
|
|
$line =~ s/^\s+//;
|
||
|
|
$line =~ s/\s+$//;
|
||
|
|
push @logins, $line;
|
||
|
|
last if @logins >= $count;
|
||
|
|
}
|
||
|
|
return \@logins;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub open_ports_count {
|
||
|
|
my $p = run(['ss', '-tlnp'], 5);
|
||
|
|
my $out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
my @lines = grep { length && index($_, 'LISTEN') >= 0 } split /\n/, $out;
|
||
|
|
return scalar @lines;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_security {
|
||
|
|
return {
|
||
|
|
selinux => selinux_status(),
|
||
|
|
firewalld => firewalld_info(),
|
||
|
|
failed_ssh_attempts => failed_ssh_attempts(),
|
||
|
|
last_logins => last_logins(),
|
||
|
|
open_ports_count => open_ports_count(),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: performance
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub process_counts {
|
||
|
|
my ($total, $zombies) = (0, 0);
|
||
|
|
my @entries;
|
||
|
|
if (opendir(my $dh, '/proc')) {
|
||
|
|
@entries = grep { /^\d+$/ } readdir($dh);
|
||
|
|
closedir($dh);
|
||
|
|
}
|
||
|
|
for my $entry (@entries) {
|
||
|
|
$total++;
|
||
|
|
my $status = read_file("/proc/$entry/status");
|
||
|
|
for my $line (split /\n/, $status) {
|
||
|
|
next unless index($line, 'State:') == 0;
|
||
|
|
$zombies++ if index($line, 'Z') >= 0;
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return { total => $total, zombies => $zombies };
|
||
|
|
}
|
||
|
|
|
||
|
|
sub top_cpu_processes {
|
||
|
|
my ($count) = @_;
|
||
|
|
$count = 5 unless defined $count;
|
||
|
|
my $p = run(['ps', '-eo', 'pid,user,%cpu,comm', '--sort=-%cpu', '--no-headers'], 5);
|
||
|
|
my @procs;
|
||
|
|
my @lines = split /\n/, $p->{out};
|
||
|
|
for my $line (@lines[0 .. ($count - 1 > $#lines ? $#lines : $count - 1)]) {
|
||
|
|
next unless defined $line;
|
||
|
|
my @parts = split ' ', $line, 4;
|
||
|
|
next unless @parts >= 4;
|
||
|
|
next unless $parts[0] =~ /^\d+$/ && $parts[2] =~ /^-?\d+(?:\.\d+)?$/;
|
||
|
|
push @procs, {
|
||
|
|
pid => $parts[0] + 0,
|
||
|
|
user => $parts[1],
|
||
|
|
cpu_pct => sprintf('%.1f', $parts[2]),
|
||
|
|
command => $parts[3],
|
||
|
|
};
|
||
|
|
}
|
||
|
|
return \@procs;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub context_switches {
|
||
|
|
my %result = (ctxt => 0, intr => 0);
|
||
|
|
for my $line (@{ read_lines('/proc/stat') }) {
|
||
|
|
if (index($line, 'ctxt ') == 0) {
|
||
|
|
my @fields = split ' ', $line;
|
||
|
|
$result{ctxt} = $fields[1] + 0 if @fields >= 2 && $fields[1] =~ /^\d+$/;
|
||
|
|
}
|
||
|
|
if (index($line, 'intr ') == 0) {
|
||
|
|
my @fields = split ' ', $line;
|
||
|
|
$result{intr} = $fields[1] + 0 if @fields >= 2 && $fields[1] =~ /^\d+$/;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return \%result;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_performance {
|
||
|
|
my $counts = process_counts();
|
||
|
|
my ($load1) = load_average();
|
||
|
|
my $cores = cpu_count();
|
||
|
|
|
||
|
|
return {
|
||
|
|
processes_total => $counts->{total},
|
||
|
|
zombies => $counts->{zombies},
|
||
|
|
top_cpu_processes => top_cpu_processes(),
|
||
|
|
context_switches => context_switches(),
|
||
|
|
load_vs_cores_ratio => sprintf('%.2f', $load1 / $cores),
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Section: recent issues
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub _journal_lines {
|
||
|
|
my ($cmd, $timeout, $keep_tail) = @_;
|
||
|
|
my $p = run($cmd, $timeout);
|
||
|
|
my $out = $p->{out};
|
||
|
|
$out =~ s/^\s+//;
|
||
|
|
$out =~ s/\s+$//;
|
||
|
|
my @lines;
|
||
|
|
for my $line (split /\n/, $out) {
|
||
|
|
my $stripped = $line;
|
||
|
|
$stripped =~ s/^\s+//;
|
||
|
|
$stripped =~ s/\s+$//;
|
||
|
|
next unless length $stripped;
|
||
|
|
next if index($stripped, '-- No entries --') >= 0;
|
||
|
|
next if index($stripped, 'No entries') >= 0;
|
||
|
|
push @lines, $stripped;
|
||
|
|
}
|
||
|
|
return [] unless @lines;
|
||
|
|
# Most journals keep their first ten lines and the OOM journal its last five,
|
||
|
|
# without running off the end of a short answer.
|
||
|
|
my $count = $keep_tail ? 5 : 10;
|
||
|
|
if ($#lines > $count - 1) {
|
||
|
|
return $keep_tail ? [@lines[$#lines - $count + 1 .. $#lines]] : [@lines[0 .. $count - 1]];
|
||
|
|
}
|
||
|
|
return \@lines;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub collect_issues {
|
||
|
|
my $recent_errors = _journal_lines(
|
||
|
|
['journalctl', '-p', 'err', '-n', '10', '--no-pager'], 10, 0);
|
||
|
|
my $kernel_oops = _journal_lines(
|
||
|
|
['journalctl', '-k', '--no-pager', '--grep', 'Oops|BUG', '--output', 'short'], 10, 0);
|
||
|
|
$kernel_oops = [@$kernel_oops[0 .. 4]] if @$kernel_oops > 5;
|
||
|
|
|
||
|
|
# Also check for a kernel panic.
|
||
|
|
if (!@$kernel_oops) {
|
||
|
|
$kernel_oops = _journal_lines(
|
||
|
|
['journalctl', '-k', '--no-pager', '--grep', 'panic', '--output', 'short'], 10, 0);
|
||
|
|
$kernel_oops = [@$kernel_oops[0 .. 4]] if @$kernel_oops > 5;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $oom_events = _journal_lines(
|
||
|
|
['journalctl', '-k', '--no-pager', '--grep', 'Out of memory', '--output', 'short'],
|
||
|
|
10, 1);
|
||
|
|
|
||
|
|
return {
|
||
|
|
recent_errors => $recent_errors,
|
||
|
|
kernel_oops => $kernel_oops,
|
||
|
|
oom_events => $oom_events,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Health score
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
# Each factor is worth a fixed maximum: CPU 10, memory 10, disk 15, SELinux 10,
|
||
|
|
# failed services 15, load 10, zombies 10, swap 10, firewall 10. A factor whose
|
||
|
|
# data source is unavailable is excluded and the score is renormalised against the
|
||
|
|
# remaining maximum, so missing tooling never reads as a security failure, while an
|
||
|
|
# explicitly disabled control still scores nothing.
|
||
|
|
sub compute_health {
|
||
|
|
my ($data) = @_;
|
||
|
|
my $earned = 0;
|
||
|
|
my $possible = 0;
|
||
|
|
my (%breakdown, %maxima, @skipped);
|
||
|
|
|
||
|
|
my $factor = sub {
|
||
|
|
my ($name, $points, $maximum) = @_;
|
||
|
|
if (!defined $points) {
|
||
|
|
push @skipped, $name;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$breakdown{$name} = $points;
|
||
|
|
$maxima{$name} = $maximum;
|
||
|
|
$earned += $points;
|
||
|
|
$possible += $maximum;
|
||
|
|
return;
|
||
|
|
};
|
||
|
|
|
||
|
|
# Each section is read through a lexical first. A chained lookup such as
|
||
|
|
# $data->{cpu}{usage_pct} would autovivify $data->{cpu} into an empty hash when
|
||
|
|
# the section was never collected, and the report would then print a section
|
||
|
|
# full of unknowns instead of treating it as absent.
|
||
|
|
my $cpu_data = $data->{cpu} // {};
|
||
|
|
my $cpu_pct = $cpu_data->{usage_pct};
|
||
|
|
my $cpu_points;
|
||
|
|
if (defined $cpu_pct) {
|
||
|
|
$cpu_points = $cpu_pct < 80 ? 10 : $cpu_pct < 90 ? 8 : $cpu_pct < 95 ? 4 : 0;
|
||
|
|
}
|
||
|
|
$factor->('cpu_usage', $cpu_points, 10);
|
||
|
|
|
||
|
|
my $mem_data = $data->{memory} // {};
|
||
|
|
my $mem_pct = $mem_data->{usage_pct};
|
||
|
|
my $mem_points;
|
||
|
|
if (defined $mem_pct) {
|
||
|
|
$mem_points = $mem_pct < 85 ? 10 : $mem_pct < 90 ? 8 : $mem_pct < 95 ? 4 : 0;
|
||
|
|
}
|
||
|
|
$factor->('memory_usage', $mem_points, 10);
|
||
|
|
|
||
|
|
my $disk_data = $data->{disk} // {};
|
||
|
|
my $critical = $disk_data->{critical_fs};
|
||
|
|
my $disk_points;
|
||
|
|
if (defined $critical) {
|
||
|
|
$disk_points = !@$critical ? 15 : @$critical == 1 ? 10 : 0;
|
||
|
|
}
|
||
|
|
$factor->('disk_usage', $disk_points, 15);
|
||
|
|
|
||
|
|
# "unknown" means getenforce is not installed, so the factor is not assessable.
|
||
|
|
my $security_data = $data->{security} // {};
|
||
|
|
my $selinux = $security_data->{selinux};
|
||
|
|
$selinux = 'unknown' unless defined $selinux;
|
||
|
|
my $selinux_points;
|
||
|
|
if ($selinux ne 'unknown') {
|
||
|
|
$selinux_points = $selinux eq 'Enforcing' ? 10 : $selinux eq 'Permissive' ? 5 : 0;
|
||
|
|
}
|
||
|
|
$factor->('selinux', $selinux_points, 10);
|
||
|
|
|
||
|
|
# undef means systemctl is not installed, so the factor is not assessable.
|
||
|
|
my $services_data = $data->{services} // {};
|
||
|
|
my $failed = $services_data->{failed_units};
|
||
|
|
my $svc_points;
|
||
|
|
if (defined $failed) {
|
||
|
|
my $count = scalar @$failed;
|
||
|
|
$svc_points = $count == 0 ? 15 : $count <= 2 ? 10 : $count <= 5 ? 5 : 0;
|
||
|
|
}
|
||
|
|
$factor->('services', $svc_points, 15);
|
||
|
|
|
||
|
|
my $overview_data = $data->{overview} // {};
|
||
|
|
my $load1 = $overview_data->{load_1min};
|
||
|
|
my $cores = $overview_data->{cpu_cores} // 1;
|
||
|
|
$cores = 1 unless $cores;
|
||
|
|
my $load_points;
|
||
|
|
if (defined $load1) {
|
||
|
|
$load_points = $load1 < $cores ? 10 : $load1 < $cores * 2 ? 5 : 0;
|
||
|
|
}
|
||
|
|
$factor->('load', $load_points, 10);
|
||
|
|
|
||
|
|
my $performance_data = $data->{performance} // {};
|
||
|
|
my $zombies = $performance_data->{zombies};
|
||
|
|
my $zombie_points;
|
||
|
|
if (defined $zombies) {
|
||
|
|
$zombie_points = $zombies == 0 ? 10 : $zombies <= 3 ? 5 : 0;
|
||
|
|
}
|
||
|
|
$factor->('zombies', $zombie_points, 10);
|
||
|
|
|
||
|
|
my $swap_pct = $mem_data->{swap_usage_pct};
|
||
|
|
my $swap_points;
|
||
|
|
if (defined $swap_pct) {
|
||
|
|
$swap_points = $swap_pct < 50 ? 10 : $swap_pct < 75 ? 5 : 0;
|
||
|
|
}
|
||
|
|
$factor->('swap', $swap_points, 10);
|
||
|
|
|
||
|
|
# available false means firewall-cmd is not installed, so not assessable.
|
||
|
|
my $fw = $security_data->{firewalld} // {};
|
||
|
|
my $fw_points;
|
||
|
|
if ($fw->{available}) {
|
||
|
|
$fw_points = $fw->{active} ? 10 : 0;
|
||
|
|
}
|
||
|
|
$factor->('firewall', $fw_points, 10);
|
||
|
|
|
||
|
|
# Nothing assessable at all, which a subset run or a failed collection can
|
||
|
|
# produce, must not read as a failing grade.
|
||
|
|
if ($possible <= 0) {
|
||
|
|
return {
|
||
|
|
score => undef,
|
||
|
|
max_score => 100,
|
||
|
|
grade => 'N/A',
|
||
|
|
breakdown => \%breakdown,
|
||
|
|
maxima => \%maxima,
|
||
|
|
factors_skipped => \@skipped,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
my $score = sprintf('%.0f', 100 * $earned / $possible);
|
||
|
|
my $letter = $score >= 90 ? 'A' : $score >= 80 ? 'B' : $score >= 70 ? 'C'
|
||
|
|
: $score >= 60 ? 'D' : 'F';
|
||
|
|
|
||
|
|
return {
|
||
|
|
score => $score + 0,
|
||
|
|
max_score => 100,
|
||
|
|
grade => $letter,
|
||
|
|
breakdown => \%breakdown,
|
||
|
|
maxima => \%maxima,
|
||
|
|
factors_skipped => \@skipped,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Human-readable report
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub section_header {
|
||
|
|
my ($title) = @_;
|
||
|
|
print "\n${BOLD}── $title ──$RESET\n";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub kv {
|
||
|
|
my ($label, $value, $colour) = @_;
|
||
|
|
$colour = '' unless defined $colour;
|
||
|
|
if (length $colour) {
|
||
|
|
printf " %-22s %s%s%s\n", $label, $colour, $value, $RESET;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
printf " %-22s %s\n", $label, $value;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub kv_status {
|
||
|
|
my ($label, $ok, $ok_text, $fail_text) = @_;
|
||
|
|
$ok_text = 'yes' unless defined $ok_text;
|
||
|
|
$fail_text = 'no' unless defined $fail_text;
|
||
|
|
if ($ok) {
|
||
|
|
printf " %-22s %s%s%s\n", $label, $GREEN, $ok_text, $RESET;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
printf " %-22s %s%s%s\n", $label, $RED, $fail_text, $RESET;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_report {
|
||
|
|
my ($data) = @_;
|
||
|
|
my $health = $data->{health} // {};
|
||
|
|
my $grade_letter = defined $health->{grade} ? $health->{grade} : '?';
|
||
|
|
my $grade_colour = $GRADE_COLOURS{$grade_letter} // $RESET;
|
||
|
|
my $health_score_text = !defined $health->{score}
|
||
|
|
? 'not assessed'
|
||
|
|
: '(' . ($health->{score} // '?') . '/' . ($health->{max_score} // 100) . ')';
|
||
|
|
|
||
|
|
# Sections in canonical order; the numbers adapt to --section subsets.
|
||
|
|
my @order = grep { exists $data->{$_} } @ALL_SECTIONS;
|
||
|
|
my %position;
|
||
|
|
$position{ $order[$_] } = $_ for 0 .. $#order;
|
||
|
|
|
||
|
|
my $bar = "═" x $WIDTH;
|
||
|
|
|
||
|
|
# Header
|
||
|
|
print "\n";
|
||
|
|
print "${BOLD}${bar}$RESET\n";
|
||
|
|
my $overview = $data->{overview} // {};
|
||
|
|
print " ${BOLD}System Diagnostics v$VERSION$RESET\n";
|
||
|
|
print "${BOLD}${bar}$RESET\n";
|
||
|
|
print ' Hostname: ' . ($overview->{hostname} // 'unknown') . "\n";
|
||
|
|
my @now = localtime(time());
|
||
|
|
printf " Date: %04d-%02d-%02d %02d:%02d:%02d\n",
|
||
|
|
$now[5] + 1900, $now[4] + 1, $now[3], $now[2], $now[1], $now[0];
|
||
|
|
print " Health: ${grade_colour}${BOLD}${grade_letter}$RESET $health_score_text\n";
|
||
|
|
|
||
|
|
# System overview
|
||
|
|
if (exists $data->{overview}) {
|
||
|
|
section_header(($position{overview} + 1) . '. System Overview');
|
||
|
|
my $o = $data->{overview};
|
||
|
|
kv('OS', $o->{os} // 'unknown');
|
||
|
|
kv('Kernel', $o->{kernel} // 'unknown');
|
||
|
|
kv('Uptime', $o->{uptime_human} // 'unknown');
|
||
|
|
kv('Boot time', $o->{boot_time} // 'unknown');
|
||
|
|
|
||
|
|
my $load1 = $o->{load_1min} // 0;
|
||
|
|
my $load5 = $o->{load_5min} // 0;
|
||
|
|
my $load15 = $o->{load_15min} // 0;
|
||
|
|
my $cores = $o->{cpu_cores} // 1;
|
||
|
|
my $load_col = $load1 < $cores ? $GREEN : $load1 < $cores * 2 ? $YELLOW : $RED;
|
||
|
|
kv('Load avg (1/5/15m)',
|
||
|
|
sprintf('%s%.2f / %.2f / %.2f%s', $load_col, $load1, $load5, $load15, $RESET));
|
||
|
|
kv('Users logged in', $o->{users_logged} // 0);
|
||
|
|
}
|
||
|
|
|
||
|
|
# CPU
|
||
|
|
if (exists $data->{cpu}) {
|
||
|
|
section_header(($position{cpu} + 1) . '. CPU');
|
||
|
|
my $c = $data->{cpu};
|
||
|
|
kv('Model', $c->{model} // 'unknown');
|
||
|
|
kv('Architecture', $c->{architecture} // 'unknown');
|
||
|
|
kv('Cores / Threads', ($c->{physical_cores} // 0) . ' physical / '
|
||
|
|
. ($c->{threads} // 0) . ' logical');
|
||
|
|
kv('Frequency', $c->{frequency} // 'unknown');
|
||
|
|
kv('Temperature', $c->{temperature} // 'unknown');
|
||
|
|
my $usage = $c->{usage_pct} // 0;
|
||
|
|
my $usage_col = $usage < 80 ? $GREEN : $usage < 90 ? $YELLOW : $RED;
|
||
|
|
kv('CPU usage', "$usage_col$usage%$RESET " . _bar($usage));
|
||
|
|
|
||
|
|
my $per_core = $c->{per_core} // [];
|
||
|
|
if (@$per_core) {
|
||
|
|
print " ${BOLD}Per-core usage:$RESET\n";
|
||
|
|
for my $core (@$per_core) {
|
||
|
|
my $core_usage = $core->{usage_pct};
|
||
|
|
my $core_col = $core_usage < 80 ? $GREEN : $core_usage < 90 ? $YELLOW : $RED;
|
||
|
|
printf " cpu%-4s %s%5.1f%%%s %s\n",
|
||
|
|
$core->{cpu}, $core_col, $core_usage, $RESET, _bar($core_usage);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Memory
|
||
|
|
if (exists $data->{memory}) {
|
||
|
|
section_header(($position{memory} + 1) . '. Memory');
|
||
|
|
my $m = $data->{memory};
|
||
|
|
kv('Total', ($m->{total_mb} // 0) . ' MiB');
|
||
|
|
kv('Used', ($m->{used_mb} // 0) . ' MiB ' . _bar($m->{usage_pct} // 0));
|
||
|
|
kv('Available', ($m->{available_mb} // 0) . ' MiB');
|
||
|
|
kv('Buffers', ($m->{buffers_mb} // 0) . ' MiB');
|
||
|
|
kv('Cached', ($m->{cached_mb} // 0) . ' MiB');
|
||
|
|
|
||
|
|
my $swap_total = $m->{swap_total_mb} // 0;
|
||
|
|
my $swap_used = $m->{swap_used_mb} // 0;
|
||
|
|
my $swap_pct = $m->{swap_usage_pct} // 0;
|
||
|
|
my $swap_col = $swap_pct < 50 ? $GREEN : $swap_pct < 75 ? $YELLOW : $RED;
|
||
|
|
kv('Swap', "${swap_col}$swap_used / $swap_total MiB$RESET " . _bar($swap_pct));
|
||
|
|
|
||
|
|
my $top_mem = $m->{top_processes} // [];
|
||
|
|
if (@$top_mem) {
|
||
|
|
print "\n ${BOLD}Top 5 memory consumers:$RESET\n";
|
||
|
|
printf " %-8s %-10s %8s COMMAND\n", 'PID', 'USER', 'RSS';
|
||
|
|
for my $proc (@$top_mem) {
|
||
|
|
printf " %-8d %-10s %6.1fM %s\n",
|
||
|
|
$proc->{pid}, $proc->{user}, $proc->{rss_mb}, $proc->{command};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Disk
|
||
|
|
if (exists $data->{disk}) {
|
||
|
|
section_header(($position{disk} + 1) . '. Disk');
|
||
|
|
my $d = $data->{disk};
|
||
|
|
kv('Total space', sprintf('%.1f GiB', $d->{total_gb} // 0));
|
||
|
|
kv('Used', sprintf('%.1f GiB ', $d->{used_gb} // 0) . _bar($d->{usage_pct} // 0));
|
||
|
|
|
||
|
|
my $fss = $d->{filesystems} // [];
|
||
|
|
if (@$fss) {
|
||
|
|
print "\n ${BOLD}Filesystems:$RESET\n";
|
||
|
|
my $header = sprintf(' %-20s %-18s %7s %7s %s', 'Device', 'Mount', 'Size', 'Used', 'Use%');
|
||
|
|
print "$header\n";
|
||
|
|
print ' ' . ('-' x (length($header) - 2)) . "\n";
|
||
|
|
for my $fs (@$fss) {
|
||
|
|
my $use_pct = $fs->{use_pct};
|
||
|
|
my $pct_col = $use_pct < 80 ? $GREEN : $use_pct < 90 ? $YELLOW : $RED;
|
||
|
|
my $dev = length($fs->{device}) > 19 ? substr($fs->{device}, 0, 19) : $fs->{device};
|
||
|
|
my $mnt = length($fs->{mountpoint}) > 17 ? substr($fs->{mountpoint}, 0, 17) : $fs->{mountpoint};
|
||
|
|
printf " %-20s %-18s %6.0fG %6.0fG %s%4.1f%%%s\n",
|
||
|
|
$dev, $mnt, $fs->{size_gb}, $fs->{used_gb}, $pct_col, $use_pct, $RESET;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if (!@$fss && $d->{container}) {
|
||
|
|
print " ${DIM}(container detected, overlay root filesystem not shown)$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $critical = $d->{critical_fs} // [];
|
||
|
|
if (@$critical) {
|
||
|
|
print "\n ${RED}⚠ Warning: " . scalar(@$critical)
|
||
|
|
. " filesystem(s) above 90% usage!$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $io_stats = $d->{io_stats};
|
||
|
|
if ($io_stats) {
|
||
|
|
print "\n ${BOLD}I/O Stats (iostat):$RESET\n";
|
||
|
|
for my $dev (@{ $io_stats->{devices} // [] }) {
|
||
|
|
printf " %-10s tps: %8.1f read: %8.2f MB/s write: %8.2f MB/s\n",
|
||
|
|
$dev->{device}, $dev->{tps}, $dev->{read_mb_s}, $dev->{write_mb_s};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Network
|
||
|
|
if (exists $data->{network}) {
|
||
|
|
section_header(($position{network} + 1) . '. Network');
|
||
|
|
my $n = $data->{network};
|
||
|
|
|
||
|
|
for my $iface (@{ $n->{interfaces} // [] }) {
|
||
|
|
my $state_col = $iface->{state} eq 'UP' ? $GREEN : $RED;
|
||
|
|
my $v6 = @{ $iface->{ipv6} } ? join(', ', @{ $iface->{ipv6} }) : "${DIM}(none)$RESET";
|
||
|
|
my $v4 = @{ $iface->{ipv4} } ? join(', ', @{ $iface->{ipv4} }) : "${DIM}(none)$RESET";
|
||
|
|
printf " %-8s %s%-5s%s speed: %s\n",
|
||
|
|
$iface->{name}, $state_col, $iface->{state}, $RESET,
|
||
|
|
$iface->{speed} // 'unknown';
|
||
|
|
print " IPv6: $v6\n";
|
||
|
|
print " IPv4: $v4\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $conns = $n->{connections} // {};
|
||
|
|
if (%$conns) {
|
||
|
|
kv('TCP established', $conns->{tcp_established} // '?');
|
||
|
|
kv('Total connections', $conns->{total} // '?');
|
||
|
|
}
|
||
|
|
|
||
|
|
my $routes = $n->{routes} // {};
|
||
|
|
kv('Default IPv6 route', $routes->{v6}) if $routes->{v6};
|
||
|
|
kv('Default IPv4 route', $routes->{v4}) if $routes->{v4};
|
||
|
|
|
||
|
|
my $ext_ip = $n->{external_ip} // {};
|
||
|
|
kv('External IPv6', $ext_ip->{v6}) if ($ext_ip->{v6} // 'unknown') ne 'unknown';
|
||
|
|
kv('External IPv4', $ext_ip->{v4}) if ($ext_ip->{v4} // 'unknown') ne 'unknown';
|
||
|
|
}
|
||
|
|
|
||
|
|
# GPU
|
||
|
|
if (exists $data->{gpu}) {
|
||
|
|
section_header(($position{gpu} + 1) . '. GPU');
|
||
|
|
my $g = $data->{gpu};
|
||
|
|
if ($g && $g->{unavailable}) {
|
||
|
|
print " ${DIM}GPU detection unavailable (no rocm-smi/lspci)$RESET\n";
|
||
|
|
}
|
||
|
|
elsif ($g) {
|
||
|
|
print " ${YELLOW}(hardware detected, GPU drivers not loaded)$RESET\n"
|
||
|
|
if $g->{fallback};
|
||
|
|
print ' Vendor: ' . ($g->{vendor} // 'unknown') . "\n";
|
||
|
|
for my $card (@{ $g->{cards} // [] }) {
|
||
|
|
# A card's properties print in the order their source listed them,
|
||
|
|
# which is not recoverable from a Perl hash: a card from
|
||
|
|
# lspci carries model, vendor and driver, one from rocm-smi carries id
|
||
|
|
# followed by the properties rocm-smi printed, so the known keys are
|
||
|
|
# laid out in those two orders and anything unexpected follows,
|
||
|
|
# sorted.
|
||
|
|
my %known = map { $_ => 1 } @CARD_KEY_ORDER;
|
||
|
|
my @keys = grep { exists $card->{$_} } @CARD_KEY_ORDER;
|
||
|
|
push @keys, sort grep { !$known{$_} } keys %$card;
|
||
|
|
for my $key (@keys) {
|
||
|
|
kv(ucfirst($key), $card->{$key});
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my $vram = $g->{vram};
|
||
|
|
if ($vram) {
|
||
|
|
my $total = $vram->{total_mb} // 0;
|
||
|
|
my $used = $vram->{used_mb} // 0;
|
||
|
|
my $free = $vram->{free_mb} // 0;
|
||
|
|
my $pct = $total > 0 ? $used / $total * 100 : 0;
|
||
|
|
my $colour = $pct < 80 ? $GREEN : $pct < 90 ? $YELLOW : $RED;
|
||
|
|
kv('VRAM Used/Total', sprintf('%s%d/%d MiB%s (%.0f%%)', $colour, $used, $total, $RESET, $pct));
|
||
|
|
kv('VRAM Free', "$free MiB");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print " ${DIM}No GPU detected$RESET\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Services
|
||
|
|
if (exists $data->{services}) {
|
||
|
|
section_header(($position{services} + 1) . '. Services');
|
||
|
|
my $s = $data->{services};
|
||
|
|
|
||
|
|
my $failed = $s->{failed_units};
|
||
|
|
if (!defined $failed) {
|
||
|
|
print " ${DIM}Failed units: unavailable (systemctl not installed)$RESET\n";
|
||
|
|
}
|
||
|
|
elsif (@$failed) {
|
||
|
|
print " ${RED}Failed units: " . scalar(@$failed) . "$RESET\n";
|
||
|
|
for my $unit (@$failed) {
|
||
|
|
print " ${RED}✗$RESET $unit->{unit} ($unit->{state})\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print " ${GREEN}No failed units$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
print "\n";
|
||
|
|
my $ks = $s->{key_services} // {};
|
||
|
|
for my $name (sort keys %$ks) {
|
||
|
|
my $status = $ks->{$name}{status} // 'unknown';
|
||
|
|
if ($status eq 'active') {
|
||
|
|
printf " %s●%s %-15s %s%s%s\n", $GREEN, $RESET, $name, $GREEN, $status, $RESET;
|
||
|
|
}
|
||
|
|
elsif ($status eq 'inactive') {
|
||
|
|
printf " %s○%s %-15s %s%s%s\n", $YELLOW, $RESET, $name, $YELLOW, $status, $RESET;
|
||
|
|
}
|
||
|
|
elsif ($status eq 'failed') {
|
||
|
|
printf " %s✗%s %-15s %s%s%s\n", $RED, $RESET, $name, $RED, $status, $RESET;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
printf " %s─%s %-15s %s%s%s\n", $DIM, $RESET, $name, $DIM, $status, $RESET;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Security
|
||
|
|
if (exists $data->{security}) {
|
||
|
|
section_header(($position{security} + 1) . '. Security');
|
||
|
|
my $sc = $data->{security};
|
||
|
|
|
||
|
|
my $selinux = $sc->{selinux} // 'unknown';
|
||
|
|
my $sel_col = $selinux eq 'Enforcing' ? $GREEN
|
||
|
|
: $selinux eq 'Permissive' ? $YELLOW
|
||
|
|
: $selinux eq 'Disabled' ? $RED
|
||
|
|
: $DIM; # unknown: SELinux tooling not installed
|
||
|
|
kv('SELinux', "$sel_col$selinux$RESET");
|
||
|
|
|
||
|
|
my $fw = $sc->{firewalld} // {};
|
||
|
|
if ($fw->{available}) {
|
||
|
|
kv_status('Firewalld active', $fw->{active} ? 1 : 0, 'active', 'inactive');
|
||
|
|
kv('Default zone', $fw->{default_zone}) if $fw->{default_zone};
|
||
|
|
kv('Active zones', join(', ', @{ $fw->{zones} // [] })) if @{ $fw->{zones} // [] };
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kv('Firewalld', "${DIM}not installed$RESET");
|
||
|
|
}
|
||
|
|
|
||
|
|
kv('Failed SSH (today)', $sc->{failed_ssh_attempts} // 0);
|
||
|
|
kv('Open TCP ports', $sc->{open_ports_count} // 0);
|
||
|
|
|
||
|
|
my $logins = $sc->{last_logins} // [];
|
||
|
|
if (@$logins) {
|
||
|
|
print "\n ${BOLD}Last logins:$RESET\n";
|
||
|
|
print " $_\n" for @$logins;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Performance
|
||
|
|
if (exists $data->{performance}) {
|
||
|
|
section_header(($position{performance} + 1) . '. Performance');
|
||
|
|
my $p = $data->{performance};
|
||
|
|
|
||
|
|
kv('Processes total', $p->{processes_total} // 0);
|
||
|
|
my $zombies = $p->{zombies} // 0;
|
||
|
|
my $zombie_col = $zombies == 0 ? $GREEN : $RED;
|
||
|
|
kv('Zombie processes', "$zombie_col$zombies$RESET");
|
||
|
|
|
||
|
|
my $ctxt = $p->{context_switches} // {};
|
||
|
|
kv('Ctxt switches (boot)', $ctxt->{ctxt} // '?');
|
||
|
|
kv('Interrupts (boot)', $ctxt->{intr} // '?');
|
||
|
|
|
||
|
|
my $load_ratio = $p->{load_vs_cores_ratio} // 0;
|
||
|
|
my $ratio_col = $load_ratio < 1 ? $GREEN : $load_ratio < 2 ? $YELLOW : $RED;
|
||
|
|
kv('Load / cores ratio', sprintf('%s%.2f%s', $ratio_col, $load_ratio, $RESET));
|
||
|
|
|
||
|
|
my $top_cpu = $p->{top_cpu_processes} // [];
|
||
|
|
if (@$top_cpu) {
|
||
|
|
print "\n ${BOLD}Top 5 CPU consumers (lifetime average):$RESET\n";
|
||
|
|
printf " %-8s %-10s %6s COMMAND\n", 'PID', 'USER', 'CPU%';
|
||
|
|
for my $proc (@$top_cpu) {
|
||
|
|
printf " %-8d %-10s %5.1f%% %s\n",
|
||
|
|
$proc->{pid}, $proc->{user}, $proc->{cpu_pct}, $proc->{command};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Recent issues
|
||
|
|
if (exists $data->{issues}) {
|
||
|
|
section_header(($position{issues} + 1) . '. Recent Issues');
|
||
|
|
my $i = $data->{issues};
|
||
|
|
|
||
|
|
my $errors = $i->{recent_errors} // [];
|
||
|
|
if (@$errors) {
|
||
|
|
print " ${BOLD}Last " . scalar(@$errors) . " errors from journal:$RESET\n";
|
||
|
|
for my $line (@$errors) {
|
||
|
|
my $display = length($line) > 120 ? substr($line, 0, 120) . "…" : $line;
|
||
|
|
print " ${DIM}$display$RESET\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print " ${GREEN}No recent errors in journal$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $oops = $i->{kernel_oops} // [];
|
||
|
|
if (@$oops) {
|
||
|
|
print "\n ${RED}⚠ Kernel OOPS / panic messages:$RESET\n";
|
||
|
|
for my $line (@$oops) {
|
||
|
|
my $display = length($line) > 120 ? substr($line, 0, 120) . "…" : $line;
|
||
|
|
print " ${RED}$display$RESET\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print "\n ${GREEN}No kernel OOPS detected$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $oom = $i->{oom_events} // [];
|
||
|
|
if (@$oom) {
|
||
|
|
print "\n ${RED}⚠ OOM events:$RESET\n";
|
||
|
|
for my $line (@$oom) {
|
||
|
|
my $display = length($line) > 120 ? substr($line, 0, 120) . "…" : $line;
|
||
|
|
print " ${RED}$display$RESET\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print "\n ${GREEN}No OOM events in kernel log$RESET\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Health score
|
||
|
|
section_header((scalar(@order) + 1) . '. Health Score');
|
||
|
|
my $bd = $health->{breakdown} // {};
|
||
|
|
my @labels = (
|
||
|
|
['cpu_usage', 'CPU usage < 80%'],
|
||
|
|
['memory_usage', 'Memory usage < 85%'],
|
||
|
|
['disk_usage', 'No disk > 90%'],
|
||
|
|
['selinux', 'SELinux enforcing'],
|
||
|
|
['services', 'No failed services'],
|
||
|
|
['load', 'Load < cores'],
|
||
|
|
['zombies', 'No zombie processes'],
|
||
|
|
['swap', 'Swap usage < 50%'],
|
||
|
|
['firewall', 'Firewall active'],
|
||
|
|
);
|
||
|
|
my %label_for = map { $_->[0] => $_->[1] } @labels;
|
||
|
|
my $maxima = $health->{maxima} // {};
|
||
|
|
for my $item (@labels) {
|
||
|
|
my ($key, $label) = @$item;
|
||
|
|
next unless exists $bd->{$key};
|
||
|
|
my $points = $bd->{$key};
|
||
|
|
my $max_points = $maxima->{$key} // 10;
|
||
|
|
my $bar_line = ("█" x ($points > 0 ? $points : 0))
|
||
|
|
. ("░" x ($max_points - ($points > 0 ? $points : 0)));
|
||
|
|
printf " %-24s %s %s/%s\n", $label, $bar_line, $points, $max_points;
|
||
|
|
}
|
||
|
|
my $skipped = $health->{factors_skipped} // [];
|
||
|
|
if (@$skipped) {
|
||
|
|
my $names = join(', ', map { $label_for{$_} // $_ } @$skipped);
|
||
|
|
print " ${DIM}Not assessed (data unavailable, score renormalised):$RESET\n";
|
||
|
|
print " ${DIM}$names$RESET\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
# Footer
|
||
|
|
print "\n";
|
||
|
|
print "${BOLD}${bar}$RESET\n";
|
||
|
|
# An absent score prints the string None: the key exists with a null value,
|
||
|
|
# so no defined-or default would apply and the text is what shows.
|
||
|
|
my $score_text = defined $health->{score} ? $health->{score} : 'None';
|
||
|
|
print " ${BOLD}Health Score: ${grade_colour}${grade_letter}$RESET "
|
||
|
|
. '(' . $score_text . '/' . ($health->{max_score} // 100) . ")\n";
|
||
|
|
print "${BOLD}${bar}$RESET\n";
|
||
|
|
print "\n";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Collection, in forked children
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub perl_literal {
|
||
|
|
my ($value) = @_;
|
||
|
|
return 'undef' unless defined $value;
|
||
|
|
if (ref $value eq 'HASH') {
|
||
|
|
return '{ ' . join(', ', map { perl_literal($_) . ' => ' . perl_literal($value->{$_}) }
|
||
|
|
sort keys %$value) . ' }';
|
||
|
|
}
|
||
|
|
if (ref $value eq 'ARRAY') {
|
||
|
|
return '[' . join(', ', map { perl_literal($_) } @$value) . ']';
|
||
|
|
}
|
||
|
|
# A whole number stays a number, so the collector hashes keep their integers and
|
||
|
|
# their boolean flags usable. Everything else is quoted: a value rounded to
|
||
|
|
# a decimal has to survive this round trip as the text it is, or 18.0
|
||
|
|
# would come back as 18 and be written to JSON as an integer. A leading zero
|
||
|
|
# must be quoted too, because unquoted it would read back as octal: 010 comes
|
||
|
|
# back as 8 and 08 fails to parse at all.
|
||
|
|
return $value if !ref $value && $value =~ /^(?:0|-?[1-9][0-9]*)$/;
|
||
|
|
my $text = $value;
|
||
|
|
$text =~ s/([\\'])/\\$1/g;
|
||
|
|
return "'$text'";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub read_literal {
|
||
|
|
my ($file) = @_;
|
||
|
|
return (undef, 'result file was not written') unless -f $file;
|
||
|
|
open(my $fh, '<', $file) or return (undef, "cannot read the result: $!");
|
||
|
|
my $text = do { local $/ = undef; <$fh> };
|
||
|
|
close($fh);
|
||
|
|
return (undef, 'empty result') unless defined $text && length $text;
|
||
|
|
my $value = eval $text;
|
||
|
|
return (undef, 'unreadable result') if $@;
|
||
|
|
return ($value, '');
|
||
|
|
}
|
||
|
|
|
||
|
|
# The sections are independent and each is dominated by waiting, so they run as
|
||
|
|
# forked children, one per section. A child writes its result as a Perl literal
|
||
|
|
# into the private scratch directory and the parent reads it back after reaping;
|
||
|
|
# progress is reported in completion order.
|
||
|
|
sub collect_all {
|
||
|
|
my ($sections, $external_ip) = @_;
|
||
|
|
my %data = (
|
||
|
|
version => $VERSION,
|
||
|
|
timestamp => timestamp_fields(time()),
|
||
|
|
);
|
||
|
|
|
||
|
|
my @collectors = (
|
||
|
|
['overview', 'system overview', sub { collect_overview() }],
|
||
|
|
['cpu', 'CPU', sub { collect_cpu() }],
|
||
|
|
['memory', 'memory', sub { collect_memory() }],
|
||
|
|
['disk', 'disk', sub { collect_disk() }],
|
||
|
|
['network', 'network', sub { collect_network($external_ip) }],
|
||
|
|
['gpu', 'GPU', sub { collect_gpu() }],
|
||
|
|
['services', 'services', sub { collect_services() }],
|
||
|
|
['security', 'security', sub { collect_security() }],
|
||
|
|
['performance', 'performance', sub { collect_performance() }],
|
||
|
|
['issues', 'recent issues', sub { collect_issues() }],
|
||
|
|
);
|
||
|
|
|
||
|
|
my %seen;
|
||
|
|
my @plan;
|
||
|
|
for my $section (@$sections) {
|
||
|
|
next if $seen{$section}++;
|
||
|
|
for my $entry (@collectors) {
|
||
|
|
push @plan, $entry if $entry->[0] eq $section;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return \%data unless @plan;
|
||
|
|
|
||
|
|
my $dir = scratch_dir();
|
||
|
|
my (%pid_of, %file_of, %label_of);
|
||
|
|
for my $entry (@plan) {
|
||
|
|
my ($section, $label, $code) = @$entry;
|
||
|
|
my $file = "$dir/$section";
|
||
|
|
$file_of{$section} = $file;
|
||
|
|
$label_of{$section} = $label;
|
||
|
|
my $pid = fork();
|
||
|
|
die "cannot fork: $!\n" unless defined $pid;
|
||
|
|
if ($pid == 0) {
|
||
|
|
# A child must not inherit the parent's interrupt handling.
|
||
|
|
$SIG{INT} = 'DEFAULT';
|
||
|
|
$SIG{TERM} = 'DEFAULT';
|
||
|
|
my $ok = eval {
|
||
|
|
open(my $fh, '>', $file) or die "cannot write $file: $!\n";
|
||
|
|
print {$fh} perl_literal($code->()), "\n";
|
||
|
|
close($fh);
|
||
|
|
1;
|
||
|
|
};
|
||
|
|
if (!$ok) {
|
||
|
|
my $error = $@ || 'unknown error';
|
||
|
|
$error =~ s/\s+\z//;
|
||
|
|
if (open(my $fh, '>', $file)) {
|
||
|
|
print {$fh} perl_literal({ error => $error }), "\n";
|
||
|
|
close($fh);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
exit($ok ? 0 : 1);
|
||
|
|
}
|
||
|
|
$pid_of{$pid} = $section;
|
||
|
|
}
|
||
|
|
|
||
|
|
for (1 .. scalar @plan) {
|
||
|
|
my $pid = waitpid(-1, 0);
|
||
|
|
last if $pid <= 0;
|
||
|
|
my $section = $pid_of{$pid};
|
||
|
|
next unless defined $section;
|
||
|
|
my $exit_status = $? >> 8;
|
||
|
|
my $label = $label_of{$section};
|
||
|
|
my ($result, $read_error) = read_literal($file_of{$section});
|
||
|
|
|
||
|
|
_status("Collecting $label");
|
||
|
|
# A child that exits well and wrote the literal undef collected honestly:
|
||
|
|
# collect_gpu returns undef when there is no GPU, which is a result, not a
|
||
|
|
# failure. Only a nonzero exit or an unreadable file is a failure.
|
||
|
|
if ($exit_status != 0 || (!defined $result && length $read_error)) {
|
||
|
|
my $message = $read_error;
|
||
|
|
$message = $result->{error} if ref $result eq 'HASH' && $result->{error};
|
||
|
|
$message = 'collection failed' unless defined $message && length $message;
|
||
|
|
$data{$section} = { error => $message };
|
||
|
|
_status_done('error');
|
||
|
|
print STDERR " [$label] $message\n";
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
$data{$section} = $result;
|
||
|
|
_status_done();
|
||
|
|
}
|
||
|
|
|
||
|
|
remove_scratch();
|
||
|
|
return \%data;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Command line
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub usage {
|
||
|
|
my $name = $0;
|
||
|
|
$name =~ s{.*/}{};
|
||
|
|
return <<"USAGE";
|
||
|
|
Usage: $name [options]
|
||
|
|
|
||
|
|
System diagnostics: CPU, memory, disk, network, GPU, services, security, performance
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--section LIST Comma-separated sections to run. Available: @{[ join(', ', @ALL_SECTIONS) ]} [default: all]
|
||
|
|
--external-ip Also detect external IP addresses via icanhazip.com (sends a request to a third-party service)
|
||
|
|
--json Output machine-readable JSON to stdout
|
||
|
|
--version Show the version and exit
|
||
|
|
-h, --help Show this help and exit
|
||
|
|
USAGE
|
||
|
|
}
|
||
|
|
|
||
|
|
sub parse_args {
|
||
|
|
my %opt = (section => '', external_ip => 0, json => 0);
|
||
|
|
my @argv = @ARGV;
|
||
|
|
while (defined(my $arg = shift @argv)) {
|
||
|
|
if ($arg eq '--section') {
|
||
|
|
my $value = shift @argv;
|
||
|
|
if (!defined $value) {
|
||
|
|
print STDERR "argument --section: expected one argument\n";
|
||
|
|
exit 2;
|
||
|
|
}
|
||
|
|
$opt{section} = $value;
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
if ($arg =~ /^--section=(.*)$/s) { $opt{section} = $1; next }
|
||
|
|
if ($arg eq '--external-ip') { $opt{external_ip} = 1; next }
|
||
|
|
if ($arg eq '--json') { $opt{json} = 1; next }
|
||
|
|
if ($arg eq '--help' || $arg eq '-h') { print usage(); exit 0 }
|
||
|
|
if ($arg eq '--version') {
|
||
|
|
my $name = $0;
|
||
|
|
$name =~ s{.*/}{};
|
||
|
|
print "$name $VERSION\n";
|
||
|
|
exit 0;
|
||
|
|
}
|
||
|
|
print STDERR "unrecognised argument: $arg\n";
|
||
|
|
print STDERR usage();
|
||
|
|
exit 2;
|
||
|
|
}
|
||
|
|
return %opt;
|
||
|
|
}
|
||
|
|
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
# Entry point
|
||
|
|
# ---------------------------------------------------------------------------
|
||
|
|
|
||
|
|
sub main {
|
||
|
|
my %opt = parse_args();
|
||
|
|
|
||
|
|
if ($^O ne 'linux') {
|
||
|
|
print STDERR "${RED}Error: system-diag.pl currently supports Linux only "
|
||
|
|
. "(detected platform: $^O).$RESET\n";
|
||
|
|
exit 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my @sections;
|
||
|
|
if (length $opt{section}) {
|
||
|
|
my @requested = map {
|
||
|
|
my $name = $_;
|
||
|
|
$name =~ s/^\s+//;
|
||
|
|
$name =~ s/\s+$//;
|
||
|
|
lc $name;
|
||
|
|
} split /,/, $opt{section};
|
||
|
|
my @invalid = grep {
|
||
|
|
my $name = $_;
|
||
|
|
!grep { $_ eq $name } @ALL_SECTIONS;
|
||
|
|
} @requested;
|
||
|
|
if (@invalid) {
|
||
|
|
print STDERR "${RED}Error: unknown section(s): " . join(', ', @invalid) . "$RESET\n";
|
||
|
|
print STDERR 'Available: ' . join(', ', @ALL_SECTIONS) . "\n";
|
||
|
|
exit 1;
|
||
|
|
}
|
||
|
|
@sections = @requested;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
@sections = @ALL_SECTIONS;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $data = collect_all(\@sections, $opt{external_ip});
|
||
|
|
$data->{health} = compute_health($data);
|
||
|
|
|
||
|
|
if ($opt{json}) {
|
||
|
|
print json_encode($data);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print_report($data);
|
||
|
|
}
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
$SIG{INT} = sub {
|
||
|
|
print STDERR "\nInterrupted.\n";
|
||
|
|
remove_scratch();
|
||
|
|
exit 130;
|
||
|
|
};
|
||
|
|
$SIG{TERM} = sub {
|
||
|
|
remove_scratch();
|
||
|
|
exit 143;
|
||
|
|
};
|
||
|
|
END {
|
||
|
|
remove_scratch();
|
||
|
|
}
|
||
|
|
|
||
|
|
# Only when this file is the program: a test harness may require it and call the
|
||
|
|
# pure functions directly.
|
||
|
|
exit(main()) unless caller;
|