1728 lines
61 KiB
Perl
1728 lines
61 KiB
Perl
#!/usr/bin/env perl
|
|
# Copyright (c) 2026 Petr Balvín <opensource@petrbalvin.org> (https://petrbalvin.org)
|
|
# SPDX-License-Identifier: MIT
|
|
|
|
# Idempotent system cleanup and optimisation for Fedora, CentOS Stream and openEuler.
|
|
#
|
|
# Cleans old kernels, dnf caches, systemd journals, temp files and core dumps.
|
|
# Every operation checks the current state before acting, so running it again
|
|
# produces the same result with no errors and no repeated work. ostree-based
|
|
# (atomic) systems are refused, because package and kernel management there
|
|
# belongs to rpm-ostree.
|
|
#
|
|
# Perl builtins only: no module has to be installed. Three pieces of work that
|
|
# Perl does not carry as builtins are therefore written out here:
|
|
#
|
|
# * the command runner, which forks and keeps stdout and stderr apart in the
|
|
# scratch directory, because the failure messages quote stderr;
|
|
# * RPM's version comparison (rpmvercmp), which decides which kernels are the
|
|
# newest and so must not be approximated;
|
|
# * a JSON decoder, which reads what dnf5 writes for --json.
|
|
#
|
|
# The dnf generation is detected once, and both are driven in their own spelling,
|
|
# because both are current on the systems these scripts run on: Fedora 41 and newer
|
|
# ship dnf 5, while CentOS Stream 10 and openEuler ship dnf 4 (measured on the
|
|
# Stream 10 image: dnf 4.20.0, no dnf5 binary and no libdnf5). Needing dnf 4
|
|
# because that is what the system has is not legacy, so nothing is refused over it.
|
|
# An unreadable version is driven as dnf 4 and said out loud, since the choice
|
|
# decides which cache directory gets measured.
|
|
#
|
|
# External binaries used: dnf, rpm, journalctl, systemctl and find.
|
|
#
|
|
# One optional module, never assumed: Time::HiRes, used only for the elapsed
|
|
# time in the summary. Without it that figure falls back to whole seconds.
|
|
#
|
|
# Usage:
|
|
# system-optimise.pl # full cleanup
|
|
# system-optimise.pl --dry-run # preview without changes
|
|
# system-optimise.pl --skip-dnf # skip DNF cleanup
|
|
# system-optimise.pl --skip-journal # skip journal cleanup
|
|
# system-optimise.pl --skip-tmp # skip temp file cleanup
|
|
# system-optimise.pl --skip-cores # skip core dump cleanup
|
|
# system-optimise.pl --version
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
my $VERSION = '2.0.0';
|
|
|
|
my $BOLD = "\033[1m";
|
|
my $RED = "\033[31m";
|
|
my $GREEN = "\033[32m";
|
|
my $YELLOW = "\033[33m";
|
|
my $DIM = "\033[2m";
|
|
my $RESET = "\033[0m";
|
|
|
|
# Supported systems, in the order the messages list them.
|
|
my @SUPPORTED_ORDER = ('fedora', 'centos', 'openeuler');
|
|
my %SUPPORTED_OS = (
|
|
fedora => 'Fedora',
|
|
centos => 'CentOS Stream',
|
|
openeuler => 'openEuler',
|
|
);
|
|
|
|
# Kernel retention: keep the newest INSTALLONLY_LIMIT kernels plus the running
|
|
# one. dnf forbids installonly_limit=1, a bootable fallback must always remain.
|
|
my $INSTALLONLY_LIMIT = 2;
|
|
|
|
# Temp file retention, matching systemd-tmpfiles defaults on both targets.
|
|
my $TMP_MAX_AGE_DAYS = 10;
|
|
my $VARTMP_MAX_AGE_DAYS = 30;
|
|
|
|
# Core dumps younger than this are kept: a crash under active analysis must never
|
|
# be swept away by a cleanup run.
|
|
my $COREDUMP_MAX_AGE_DAYS = 7;
|
|
|
|
my $JOURNAL_VACUUM_SIZE_MB = 500;
|
|
my $JOURNAL_WARN_BYTES = 1024 * 1024 * 1024;
|
|
my @JOURNAL_DIRS = ('/var/log/journal', '/run/log/journal');
|
|
|
|
# The dnf generation, probed once and then reused, and whether the unreadable case
|
|
# has already been reported.
|
|
my $DNF_MAJOR;
|
|
my $DNF_MAJOR_WARNED = 0;
|
|
|
|
# Unit file types audited for leftovers in /etc/systemd/system/.
|
|
my @UNIT_SUFFIXES = qw(.service .socket .timer .target .path .mount .automount .slice);
|
|
|
|
# The optional clock, loaded once and guarded where it is used.
|
|
my $HAVE_HIRES = eval { require Time::HiRes; 1 } ? 1 : 0;
|
|
|
|
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 helpers, all 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;
|
|
}
|
|
|
|
sub _info {
|
|
my ($msg) = @_;
|
|
print STDERR " ${DIM}$msg$RESET\n";
|
|
return;
|
|
}
|
|
|
|
sub _warn {
|
|
my ($msg) = @_;
|
|
print STDERR " ${YELLOW}⚠ $msg$RESET\n";
|
|
return;
|
|
}
|
|
|
|
sub _ok {
|
|
my ($msg) = @_;
|
|
print STDERR " ${GREEN}✓ $msg$RESET\n";
|
|
return;
|
|
}
|
|
|
|
sub _fail {
|
|
my ($msg) = @_;
|
|
print STDERR " ${RED}✗ $msg$RESET\n";
|
|
return;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Support: the clock, path lookup, scratch files and the command runner
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub now {
|
|
return $HAVE_HIRES ? Time::HiRes::time() : time();
|
|
}
|
|
|
|
# A hand-rolled which(1), so that the lookup itself needs no external binary.
|
|
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;
|
|
}
|
|
|
|
# mkdir is atomic and refuses to follow a symlink, so a hostile entry in a
|
|
# shared /tmp cannot redirect where the runner writes.
|
|
sub scratch_dir {
|
|
return $TMP_DIR if defined $TMP_DIR;
|
|
# an empty TMPDIR would place the scratch directory at the filesystem root
|
|
my $base = defined $ENV{TMPDIR} && length $ENV{TMPDIR} ? $ENV{TMPDIR} : '/tmp';
|
|
for my $attempt (0 .. 9) {
|
|
my $dir = "$base/system-optimise.$$" . ($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 runner forks, 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 child is forked with its two streams sent to separate files in the scratch
|
|
# directory, because the messages quote stderr while the parsers read stdout, and
|
|
# the builtin pipe forms cannot keep them apart. The locale is forced to C so
|
|
# that tool output is parsed in English. Nothing raises: a missing binary, a
|
|
# timeout and a failed exec become rc 127, 124 and 126, which is the contract the
|
|
# callers below were written against.
|
|
sub run {
|
|
my ($cmd, $timeout) = @_;
|
|
$timeout = 120 unless defined $timeout;
|
|
|
|
my $exe = find_exe($cmd->[0]);
|
|
return { rc => 127, out => '', err => "command not found: $cmd->[0]" } 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';
|
|
# a failed exec falls through to the or branch, and stderr is
|
|
# already the file the parent quotes, so the reason travels with it
|
|
exec { $exe } @$cmd
|
|
or print STDERR "cannot execute $exe: $!\n";
|
|
}
|
|
exit 126; # reached only when the redirection or the exec failed
|
|
}
|
|
|
|
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 => $out,
|
|
err => $timed_out ? "timed out after ${timeout}s" : $err,
|
|
};
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# OS detection and the root check
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub parse_os_release {
|
|
my %release;
|
|
open(my $fh, '<', '/etc/os-release') or return \%release;
|
|
while (my $line = <$fh>) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
next unless length $line;
|
|
next if index($line, '#') == 0;
|
|
next unless index($line, '=') >= 0;
|
|
my ($key, $value) = split /=/, $line, 2;
|
|
$value = '' unless defined $value;
|
|
$value =~ s/^\s+//;
|
|
$value =~ s/\s+$//;
|
|
for my $quote ('"', "'") {
|
|
$value =~ s/^\Q$quote\E+//;
|
|
$value =~ s/\Q$quote\E+$//;
|
|
}
|
|
$release{$key} = $value;
|
|
}
|
|
close($fh);
|
|
return \%release;
|
|
}
|
|
|
|
sub detect_os {
|
|
my $release = parse_os_release();
|
|
my $os_id = lc($release->{ID} // '');
|
|
my $version_id = $release->{VERSION_ID} // 'unknown';
|
|
|
|
# An ostree-based (atomic) system reports a normal ID, Silverblue reports
|
|
# ID=fedora, but has no dnf and manages kernels through rpm-ostree.
|
|
if (-e '/run/ostree-booted') {
|
|
print STDERR "${RED}${BOLD}Error:$RESET ostree-based (atomic) system detected "
|
|
. "(/run/ostree-booted present).\n";
|
|
print STDERR " Package and kernel management there belongs to rpm-ostree; "
|
|
. "this script only supports traditional dnf/rpm systems.\n";
|
|
exit 1;
|
|
}
|
|
if (!exists $SUPPORTED_OS{$os_id}) {
|
|
print STDERR "${RED}${BOLD}Error:$RESET Unsupported operating system: "
|
|
. "'" . ($release->{ID} // 'unknown') . "' (detected from /etc/os-release).\n";
|
|
print STDERR " Supported systems: "
|
|
. join(', ', map { $SUPPORTED_OS{$_} } @SUPPORTED_ORDER) . "\n";
|
|
exit 1;
|
|
}
|
|
return ($os_id, $SUPPORTED_OS{$os_id}, $version_id);
|
|
}
|
|
|
|
sub check_root {
|
|
return if $> == 0;
|
|
print STDERR "${RED}${BOLD}Error:$RESET This script must be run as root (UID 0).\n";
|
|
print STDERR " Current UID: $>. Try: sudo perl system-optimise.pl\n";
|
|
exit 1;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Sizes and error text
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub format_size {
|
|
my ($bytes) = @_;
|
|
$bytes = 0 unless defined $bytes;
|
|
return '0 B' if $bytes < 0;
|
|
return sprintf('%.2f GB', $bytes / (1024 * 1024 * 1024)) if $bytes >= 1024 * 1024 * 1024;
|
|
return sprintf('%.1f MB', $bytes / (1024 * 1024)) if $bytes >= 1024 * 1024;
|
|
return sprintf('%.1f KB', $bytes / 1024) if $bytes >= 1024;
|
|
return "$bytes B";
|
|
}
|
|
|
|
# Total size of the files under a directory. Symbolic links to files count,
|
|
# through stat; symbolic links to directories are not followed, and unreadable
|
|
# directories are skipped rather than fatal.
|
|
sub du {
|
|
my ($path) = @_;
|
|
return 0 unless -d $path;
|
|
my $total = 0;
|
|
my @pending = ($path);
|
|
while (defined(my $dir = pop @pending)) {
|
|
opendir(my $dh, $dir) or next;
|
|
for my $entry (readdir($dh)) {
|
|
next if $entry eq '.' || $entry eq '..';
|
|
my $full = "$dir/$entry";
|
|
if (-l $full) {
|
|
my $size = -s $full;
|
|
$total += $size if defined $size && -f $full;
|
|
next;
|
|
}
|
|
if (-d $full) { push @pending, $full; next }
|
|
if (-f $full) {
|
|
my $size = -s $full;
|
|
$total += $size if defined $size;
|
|
}
|
|
}
|
|
closedir($dh);
|
|
}
|
|
return $total;
|
|
}
|
|
|
|
sub last_lines {
|
|
my ($text, $count) = @_;
|
|
$count = 3 unless defined $count;
|
|
$text = '' unless defined $text;
|
|
my @lines;
|
|
for my $line (split /\n/, $text) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
push @lines, $line if length $line;
|
|
}
|
|
return 'no error output' unless @lines;
|
|
my @tail = @lines > $count ? @lines[-$count .. -1] : @lines;
|
|
return join(' | ', @tail);
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# RPM version comparison
|
|
# ---------------------------------------------------------------------------
|
|
|
|
# rpmvercmp, as rpm itself defines it: segments alternate between digits and
|
|
# letters, numeric segments compare numerically and always beat alphabetic
|
|
# ones, "~" sorts before everything including the end of the string, and "^"
|
|
# sorts after the end of the string but before any segment. Comparison is
|
|
# byte oriented, which is what RPM does with ASCII version strings.
|
|
sub rpmvercmp {
|
|
my ($ver_a, $ver_b) = @_;
|
|
return 0 if $ver_a eq $ver_b;
|
|
my $len_a = length $ver_a;
|
|
my $len_b = length $ver_b;
|
|
my ($pos_a, $pos_b) = (0, 0);
|
|
|
|
while ($pos_a < $len_a || $pos_b < $len_b) {
|
|
# separators are skipped, but never a tilde or a caret: both are
|
|
# ordering operators in their own right and stop the skip
|
|
$pos_a++ while $pos_a < $len_a && substr($ver_a, $pos_a, 1) =~ /[^A-Za-z0-9~^]/;
|
|
$pos_b++ while $pos_b < $len_b && substr($ver_b, $pos_b, 1) =~ /[^A-Za-z0-9~^]/;
|
|
|
|
my $char_a = $pos_a < $len_a ? substr($ver_a, $pos_a, 1) : '';
|
|
my $char_b = $pos_b < $len_b ? substr($ver_b, $pos_b, 1) : '';
|
|
|
|
# a tilde sorts before everything, including the end of the string
|
|
if ($char_a eq '~' || $char_b eq '~') {
|
|
return 1 if $char_a ne '~';
|
|
return -1 if $char_b ne '~';
|
|
$pos_a++;
|
|
$pos_b++;
|
|
next;
|
|
}
|
|
# a caret sorts after the end of the string but before any segment
|
|
if ($char_a eq '^' || $char_b eq '^') {
|
|
return -1 if $char_a eq '';
|
|
return 1 if $char_b eq '';
|
|
return 1 if $char_a ne '^';
|
|
return -1 if $char_b ne '^';
|
|
$pos_a++;
|
|
$pos_b++;
|
|
next;
|
|
}
|
|
|
|
last unless length $char_a && length $char_b;
|
|
|
|
my $numeric_a = $char_a =~ /[0-9]/ ? 1 : 0;
|
|
my $numeric_b = $char_b =~ /[0-9]/ ? 1 : 0;
|
|
if ($numeric_a != $numeric_b) {
|
|
return $numeric_a ? 1 : -1;
|
|
}
|
|
|
|
my ($start_a, $start_b) = ($pos_a, $pos_b);
|
|
my ($seg_a, $seg_b);
|
|
if ($numeric_a) {
|
|
$pos_a++ while $pos_a < $len_a && substr($ver_a, $pos_a, 1) =~ /[0-9]/;
|
|
$pos_b++ while $pos_b < $len_b && substr($ver_b, $pos_b, 1) =~ /[0-9]/;
|
|
$seg_a = substr($ver_a, $start_a, $pos_a - $start_a);
|
|
$seg_b = substr($ver_b, $start_b, $pos_b - $start_b);
|
|
$seg_a =~ s/^0+//;
|
|
$seg_b =~ s/^0+//;
|
|
$seg_a = '0' unless length $seg_a;
|
|
$seg_b = '0' unless length $seg_b;
|
|
if (length $seg_a != length $seg_b) {
|
|
return length $seg_a > length $seg_b ? 1 : -1;
|
|
}
|
|
}
|
|
else {
|
|
$pos_a++ while $pos_a < $len_a && substr($ver_a, $pos_a, 1) =~ /[A-Za-z]/;
|
|
$pos_b++ while $pos_b < $len_b && substr($ver_b, $pos_b, 1) =~ /[A-Za-z]/;
|
|
$seg_a = substr($ver_a, $start_a, $pos_a - $start_a);
|
|
$seg_b = substr($ver_b, $start_b, $pos_b - $start_b);
|
|
}
|
|
if ($seg_a ne $seg_b) {
|
|
return $seg_a gt $seg_b ? 1 : -1;
|
|
}
|
|
}
|
|
|
|
# whichever side still has segments left over is the newer version
|
|
return 1 if $pos_a < $len_a;
|
|
return -1 if $pos_b < $len_b;
|
|
return 0;
|
|
}
|
|
|
|
# Split an EVR the way rpm's own parser splits it: an epoch is the leading
|
|
# digits before a colon, and the release is everything after the last dash of
|
|
# what remains. A missing epoch counts as zero; a missing release is undef,
|
|
# which the comparison below keeps apart from an empty one.
|
|
sub parse_evr {
|
|
my ($evr) = @_;
|
|
$evr = '' unless defined $evr;
|
|
my $epoch;
|
|
my $version = $evr;
|
|
if ($version =~ /^([0-9]*):/) {
|
|
$epoch = length $1 ? $1 : '0';
|
|
$version = substr($version, length($1) + 1);
|
|
}
|
|
my $release;
|
|
my $cut = rindex($version, '-');
|
|
if ($cut >= 0) {
|
|
$release = substr($version, $cut + 1);
|
|
$version = substr($version, 0, $cut);
|
|
}
|
|
return ($epoch, $version, $release);
|
|
}
|
|
|
|
# Epoch, then version, then release, each with rpmvercmp: the field by field
|
|
# comparison rpm itself makes, where a version with a release outranks one
|
|
# without. Comparing the whole remainder as one string instead would let a
|
|
# version bleed into a release, so "1.0-2" would wrongly outrank "1.0.1-1".
|
|
sub rpm_evr_cmp {
|
|
my ($evr_a, $evr_b) = @_;
|
|
my ($epoch_a, $version_a, $release_a) = parse_evr($evr_a);
|
|
my ($epoch_b, $version_b, $release_b) = parse_evr($evr_b);
|
|
my $rc = rpmvercmp($epoch_a // '0', $epoch_b // '0');
|
|
return $rc if $rc;
|
|
$rc = rpmvercmp($version_a, $version_b);
|
|
return $rc if $rc;
|
|
return 1 if defined $release_a && !defined $release_b;
|
|
return -1 if !defined $release_a && defined $release_b;
|
|
return 0 unless defined $release_a; # neither side carries a release
|
|
return rpmvercmp($release_a, $release_b);
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Kernels
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub kernel_pkg_name {
|
|
my ($os_id) = @_;
|
|
return $os_id eq 'openeuler' ? 'kernel' : 'kernel-core';
|
|
}
|
|
|
|
# Installed kernel EVRs (epoch:version-release.arch), newest first, or undef when
|
|
# the rpm query itself failed: an empty list and a failed query are different
|
|
# answers. The sort is a version sort because rpm -q lists in install order,
|
|
# which is not version order.
|
|
sub list_kernel_packages {
|
|
my ($os_id) = @_;
|
|
my $p = run([
|
|
'rpm', '-q', kernel_pkg_name($os_id),
|
|
'--qf', "%{EPOCHNUM}:%{VERSION}-%{RELEASE}.%{ARCH}\n",
|
|
], 30);
|
|
return undef if $p->{rc} != 0;
|
|
my @evrs;
|
|
for my $line (split /\n/, $p->{out}) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
push @evrs, $line if length $line;
|
|
}
|
|
@evrs = sort { rpm_evr_cmp($b, $a) } @evrs;
|
|
return \@evrs;
|
|
}
|
|
|
|
sub running_kernel {
|
|
if (open(my $fh, '<', '/proc/sys/kernel/osrelease')) {
|
|
my $line = <$fh>;
|
|
close($fh);
|
|
if (defined $line) {
|
|
$line =~ s/\s+$//;
|
|
return $line;
|
|
}
|
|
}
|
|
return '';
|
|
}
|
|
|
|
# Split the EVRs (newest first) into what is kept and what would go, mirroring
|
|
# dnf's --oldinstallonly: the newest INSTALLONLY_LIMIT versions, and always the
|
|
# running one even when it is not among them, which is the state after an update
|
|
# that has not been rebooted into yet.
|
|
sub select_kernels_to_keep {
|
|
my ($kernels, $running) = @_;
|
|
my $limit = @$kernels < $INSTALLONLY_LIMIT ? scalar @$kernels : $INSTALLONLY_LIMIT;
|
|
my @kept = $limit > 0 ? @$kernels[0 .. $limit - 1] : ();
|
|
|
|
my ($running_evr) = grep {
|
|
my (undef, $rest) = split /:/, $_, 2;
|
|
defined $rest && $rest eq $running;
|
|
} @$kernels;
|
|
if (defined $running_evr && !grep { $_ eq $running_evr } @kept) {
|
|
push @kept, $running_evr;
|
|
}
|
|
my %kept = map { $_ => 1 } @kept;
|
|
my @would_remove = grep { !$kept{$_} } @$kernels;
|
|
return (\@kept, \@would_remove);
|
|
}
|
|
|
|
# The major version of the installed dnf, probed once and reused, or 0 when it
|
|
# cannot be read at all.
|
|
sub dnf_major {
|
|
return $DNF_MAJOR if defined $DNF_MAJOR;
|
|
$DNF_MAJOR = 0;
|
|
my $p = run(['dnf', '--version'], 15);
|
|
if ($p->{rc} == 0 && length $p->{out}) {
|
|
my ($first) = split /\n/, $p->{out};
|
|
$DNF_MAJOR = $1 + 0 if defined $first && $first =~ /(\d+)\.\d+/;
|
|
}
|
|
return $DNF_MAJOR;
|
|
}
|
|
|
|
# The generation to drive, in the spellings that generation understands. Both are
|
|
# current on the systems these scripts run on, so both are driven: Fedora 41 and
|
|
# newer ship dnf 5, while CentOS Stream 10 and openEuler ship dnf 4 (measured on
|
|
# the Stream 10 image: dnf 4.20.0, no dnf5 binary and no libdnf5). Needing dnf 4
|
|
# because that is what the system has is not legacy: the script follows the system
|
|
# rather than the other way round.
|
|
#
|
|
# An unreadable version is driven as dnf 4, and the choice is said out loud,
|
|
# because the choice is not cosmetic: it decides which cache directory gets
|
|
# measured, and a wrong guess would report a saving of zero as though it were true.
|
|
sub dnf_generation {
|
|
my $major = dnf_major();
|
|
return $major if $major > 0;
|
|
if (!$DNF_MAJOR_WARNED) {
|
|
$DNF_MAJOR_WARNED = 1;
|
|
_warn('Could not read the dnf version, driving dnf as version 4');
|
|
}
|
|
return 4;
|
|
}
|
|
|
|
# The cache directories the given generation owns, and those left behind by the
|
|
# other: the first set is measured and cleaned, the second is named and left alone.
|
|
sub dnf_cache_dirs {
|
|
my ($major) = @_;
|
|
return (['/var/cache/libdnf5'], ['/var/cache/dnf', '/var/cache/yum']) if $major >= 5;
|
|
return (['/var/cache/dnf', '/var/cache/yum'], []);
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 1: DNF cleanup
|
|
# ---------------------------------------------------------------------------
|
|
|
|
# The removed-package count from a dnf transaction preview. dnf 4 writes
|
|
# "Remove 12 Packages" in its summary and dnf 5 "Removing: 12 packages"; both
|
|
# generations are current, so both are read. An unparseable preview returns undef
|
|
# rather than zero, so that a failure is never reported as "nothing to remove".
|
|
sub parse_removal_count {
|
|
my ($text) = @_;
|
|
$text = '' unless defined $text;
|
|
return $1 + 0 if $text =~ /^Remove\s+(\d+)\s+Packages?\b/m;
|
|
return $1 + 0 if $text =~ /^\s*Removing:\s+(\d+)\s+packages?\b/m;
|
|
return 0 if index($text, 'Nothing to do') >= 0;
|
|
return undef;
|
|
}
|
|
|
|
sub dnf_cleanup {
|
|
my ($os_id, $dnf_major, %opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $warnings = $opt{warnings};
|
|
my $pkg_name = kernel_pkg_name($os_id);
|
|
my %result = (
|
|
autoremoved => 0,
|
|
autoremoved_count => 0,
|
|
kernels_removed => 0,
|
|
kernels_planned => 0,
|
|
kernels_kept => '',
|
|
space_saved => 0,
|
|
cache_cleaned => 0,
|
|
errors => [],
|
|
);
|
|
|
|
# 1. Autoremove packages nothing needs any more.
|
|
status('Removing unneeded packages (dnf autoremove)');
|
|
if ($dry_run) {
|
|
# --assumeno makes dnf print the transaction and then answer no, so the
|
|
# exit code can be non-zero while stdout still carries the answer.
|
|
my $p = run(['dnf', 'autoremove', '--assumeno'], 300);
|
|
my $count = parse_removal_count($p->{out});
|
|
if (defined $count) {
|
|
$result{autoremoved_count} = $count;
|
|
status_done($count ? "would remove $count package(s)" : 'nothing to remove');
|
|
}
|
|
elsif ($p->{rc} == 0) {
|
|
status_done('would run (package count unavailable)');
|
|
}
|
|
else {
|
|
status_done('failed');
|
|
_warn('dnf autoremove preview failed: ' . last_lines($p->{err}));
|
|
push @{ $result{errors} }, 'dnf autoremove preview failed';
|
|
}
|
|
}
|
|
else {
|
|
my $p = run(['dnf', 'autoremove', '-y'], 300);
|
|
if ($p->{rc} == 0) {
|
|
my $count = parse_removal_count($p->{out});
|
|
$count = 0 unless defined $count;
|
|
$result{autoremoved_count} = $count;
|
|
$result{autoremoved} = $count ? 1 : 0;
|
|
status_done($count ? "removed $count package(s)" : 'nothing to do');
|
|
}
|
|
else {
|
|
status_done('failed');
|
|
_warn('dnf autoremove failed: ' . last_lines($p->{err}));
|
|
push @{ $result{errors} }, 'dnf autoremove failed';
|
|
}
|
|
}
|
|
|
|
# 2. Prune old kernels. dnf decides what to remove, never this script.
|
|
my $kernels = list_kernel_packages($os_id);
|
|
if (!defined $kernels) {
|
|
_warn('Could not query installed kernels (rpm), skipping kernel cleanup');
|
|
push @$warnings, 'Kernel query via rpm failed, kernel cleanup skipped';
|
|
push @{ $result{errors} }, 'rpm kernel query failed';
|
|
$result{kernels_kept} = 'unknown';
|
|
}
|
|
elsif (!@$kernels) {
|
|
_info('No kernel packages found');
|
|
$result{kernels_kept} = 'none';
|
|
}
|
|
else {
|
|
my $running = running_kernel();
|
|
my ($kept, $would_remove) = select_kernels_to_keep($kernels, $running);
|
|
$result{kernels_kept} = join(', ', map { "$pkg_name-$_" } @$kept);
|
|
|
|
if (!@$would_remove) {
|
|
_info('Old kernels: none to remove (' . scalar(@$kernels)
|
|
. ' installed, keeping ' . scalar(@$kept) . ')');
|
|
}
|
|
elsif ($dry_run) {
|
|
status("Pruning old kernels (keeping newest $INSTALLONLY_LIMIT + running)");
|
|
$result{kernels_planned} = scalar @$would_remove;
|
|
status_done('would remove ' . scalar @$would_remove);
|
|
_info("would remove $pkg_name-$_") for @$would_remove;
|
|
}
|
|
else {
|
|
status('Pruning ' . scalar(@$would_remove) . ' old kernel(s) via dnf (keeping '
|
|
. scalar(@$kept) . ')');
|
|
my @cmd = ('dnf', 'remove', '-y', '--oldinstallonly');
|
|
if ($dnf_major >= 5) {
|
|
push @cmd, "--limit=$INSTALLONLY_LIMIT";
|
|
}
|
|
else {
|
|
push @cmd, '--setopt', "installonly_limit=$INSTALLONLY_LIMIT";
|
|
}
|
|
push @cmd, $pkg_name;
|
|
my $p = run(\@cmd, 300);
|
|
if ($p->{rc} == 0) {
|
|
# dnf may keep more than the model allows for, and it protects
|
|
# the running kernel itself, so re-query and report what happened
|
|
# rather than what was planned.
|
|
my $after = list_kernel_packages($os_id);
|
|
if (!defined $after) {
|
|
$result{kernels_removed} = 0;
|
|
status_done('done (post-check failed)');
|
|
push @$warnings, 'Could not verify kernel removal (rpm), removed count unknown';
|
|
}
|
|
else {
|
|
my %still_there = map { $_ => 1 } @$after;
|
|
my @removed_now = grep { !$still_there{$_} } @$kernels;
|
|
my $running_present = grep {
|
|
my (undef, $rest) = split /:/, $_, 2;
|
|
defined $rest && $rest eq $running;
|
|
} @$after;
|
|
if (!$running_present) {
|
|
_fail("Running kernel $running is no longer installed, do not reboot");
|
|
push @{ $result{errors} }, 'running kernel missing after kernel prune';
|
|
}
|
|
$result{kernels_removed} = scalar @removed_now;
|
|
status_done('removed ' . scalar(@removed_now)
|
|
. ' (planned ' . scalar(@$would_remove) . ", running: $running)");
|
|
}
|
|
}
|
|
else {
|
|
status_done('failed');
|
|
_warn('Kernel removal failed: ' . last_lines($p->{err}));
|
|
push @{ $result{errors} }, 'old kernel removal failed';
|
|
}
|
|
}
|
|
}
|
|
|
|
# 3. Clean the cache, measuring only what this generation owns, and name what
|
|
# the other generation left behind without touching it.
|
|
my ($active_caches, $stale_caches) = dnf_cache_dirs($dnf_major);
|
|
for my $stale (@$stale_caches) {
|
|
my $stale_size = du($stale);
|
|
next unless $stale_size > 0;
|
|
my $msg = "Stale dnf4 cache at $stale (" . format_size($stale_size)
|
|
. '), unused by dnf5';
|
|
_info($msg);
|
|
push @$warnings, $msg;
|
|
}
|
|
my $cache_before = 0;
|
|
$cache_before += du($_) for @$active_caches;
|
|
status('Cleaning DNF cache');
|
|
if ($dry_run) {
|
|
$result{space_saved} += $cache_before;
|
|
status_done('would free ~' . format_size($cache_before));
|
|
}
|
|
else {
|
|
my $p = run(['dnf', 'clean', 'all'], 60);
|
|
if ($p->{rc} == 0) {
|
|
my $cache_after = 0;
|
|
$cache_after += du($_) for @$active_caches;
|
|
my $saved = $cache_before - $cache_after;
|
|
$saved = 0 if $saved < 0;
|
|
$result{space_saved} += $saved;
|
|
$result{cache_cleaned} = 1;
|
|
status_done(format_size($saved));
|
|
}
|
|
else {
|
|
status_done('failed');
|
|
_warn('dnf clean all failed: ' . last_lines($p->{err}));
|
|
push @{ $result{errors} }, 'dnf clean all failed';
|
|
}
|
|
}
|
|
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 2: journal cleanup
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub journal_size {
|
|
my $total = 0;
|
|
for my $path (@JOURNAL_DIRS) {
|
|
$total += du($path) if -e $path;
|
|
}
|
|
return $total;
|
|
}
|
|
|
|
sub journal_cleanup {
|
|
my (%opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $warnings = $opt{warnings};
|
|
my %result = (
|
|
vacuumed => 0,
|
|
space_saved => 0,
|
|
journal_size_after => 0,
|
|
persistent_warning => 0,
|
|
errors => [],
|
|
);
|
|
|
|
my $vacuum_arg = "--vacuum-size=${JOURNAL_VACUUM_SIZE_MB}M";
|
|
my $size_before = journal_size();
|
|
status("Vacuuming journal ($vacuum_arg)");
|
|
|
|
my $size_check;
|
|
if ($dry_run) {
|
|
my $estimated = $size_before - $JOURNAL_VACUUM_SIZE_MB * 1024 * 1024;
|
|
$estimated = 0 if $estimated < 0;
|
|
$result{space_saved} = $estimated;
|
|
status_done('would free ~' . format_size($estimated));
|
|
$size_check = $size_before - $estimated;
|
|
}
|
|
else {
|
|
my $p = run(['journalctl', $vacuum_arg], 120);
|
|
if ($p->{rc} == 0) {
|
|
$result{vacuumed} = 1;
|
|
$result{journal_size_after} = journal_size();
|
|
my $saved = $size_before - $result{journal_size_after};
|
|
$result{space_saved} = $saved > 0 ? $saved : 0;
|
|
status_done(format_size($result{space_saved}));
|
|
}
|
|
else {
|
|
status_done('failed');
|
|
_warn('journalctl vacuum failed: ' . last_lines($p->{err}));
|
|
push @{ $result{errors} }, 'journal vacuum failed';
|
|
}
|
|
$size_check = journal_size();
|
|
}
|
|
|
|
# A journal that stays large after a vacuum needs SystemMaxUse rather than
|
|
# another vacuum, so it is reported.
|
|
if ($size_check > $JOURNAL_WARN_BYTES) {
|
|
my $msg = 'Journal still large (' . format_size($size_check)
|
|
. ') after vacuum. Consider setting SystemMaxUse= in /etc/systemd/journald.conf';
|
|
_warn($msg);
|
|
push @$warnings, $msg;
|
|
$result{persistent_warning} = 1;
|
|
}
|
|
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 3: systemd audit, informational only
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub systemd_audit {
|
|
my (%opt) = @_;
|
|
my $warnings = $opt{warnings};
|
|
my %result = (
|
|
failed_units => [],
|
|
disabled_count => 0,
|
|
leftover_files => [],
|
|
errors => [],
|
|
);
|
|
|
|
# 1. Failed units
|
|
status('Checking for failed systemd units');
|
|
my $p = run(['systemctl', '--failed', '--no-legend'], 30);
|
|
if ($p->{rc} != 0 && !length $p->{out}) {
|
|
status_done('unavailable');
|
|
my $msg = 'systemctl --failed unavailable: ' . last_lines($p->{err});
|
|
_warn($msg);
|
|
push @$warnings, $msg;
|
|
}
|
|
else {
|
|
my @failed;
|
|
for my $line (split /\n/, $p->{out}) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
push @failed, $line if length $line;
|
|
}
|
|
$result{failed_units} = \@failed;
|
|
status_done(scalar(@failed) . ' failed');
|
|
_warn("Failed unit: $_") for @failed;
|
|
push @$warnings, scalar(@failed) . ' failed systemd unit(s), see above' if @failed;
|
|
}
|
|
|
|
# 2. Disabled unit files, counted for information only.
|
|
status('Counting disabled unit files');
|
|
my $disabled = run(['systemctl', 'list-unit-files', '--state=disabled', '--no-legend'], 30);
|
|
if ($disabled->{rc} != 0 && !length $disabled->{out}) {
|
|
status_done('unavailable');
|
|
my $msg = 'systemctl list-unit-files --state=disabled unavailable: '
|
|
. last_lines($disabled->{err});
|
|
_warn($msg);
|
|
push @$warnings, $msg;
|
|
}
|
|
else {
|
|
my @disabled_lines;
|
|
for my $line (split /\n/, $disabled->{out}) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
push @disabled_lines, $line if length $line;
|
|
}
|
|
$result{disabled_count} = scalar @disabled_lines;
|
|
status_done($result{disabled_count} . ' disabled (informational only)');
|
|
}
|
|
|
|
# 3. Leftover unit files: regular files systemd does not know about. One
|
|
# listing yields every unit name systemd recognises, so static, disabled and
|
|
# indirect units are all legitimate and only unknown names are leftovers.
|
|
my $etc_systemd = '/etc/systemd/system';
|
|
if (-d $etc_systemd) {
|
|
status('Checking for leftover unit files');
|
|
my $units = run(['systemctl', 'list-unit-files', '--no-legend'], 30);
|
|
if ($units->{rc} != 0) {
|
|
status_done('unavailable');
|
|
my $msg = 'systemctl list-unit-files unavailable: ' . last_lines($units->{err});
|
|
_warn($msg);
|
|
push @$warnings, $msg;
|
|
}
|
|
else {
|
|
my %known;
|
|
for my $line (split /\n/, $units->{out}) {
|
|
my @fields = split ' ', $line;
|
|
$known{ $fields[0] } = 1 if @fields;
|
|
}
|
|
my @leftovers;
|
|
if (opendir(my $dh, $etc_systemd)) {
|
|
for my $entry (sort readdir($dh)) {
|
|
next if $entry eq '.' || $entry eq '..';
|
|
my $full = "$etc_systemd/$entry";
|
|
next if -l $full || !-f $full;
|
|
next unless grep { substr($entry, -length $_) eq $_ } @UNIT_SUFFIXES;
|
|
push @leftovers, $entry unless $known{$entry};
|
|
}
|
|
closedir($dh);
|
|
}
|
|
$result{leftover_files} = \@leftovers;
|
|
if (@leftovers) {
|
|
status_done(scalar(@leftovers) . ' leftover(s)');
|
|
_warn("Leftover unit file: $etc_systemd/$_") for @leftovers;
|
|
push @$warnings, scalar(@leftovers) . " leftover unit file(s) in $etc_systemd/";
|
|
}
|
|
else {
|
|
status_done('none');
|
|
}
|
|
}
|
|
}
|
|
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 4: temp file cleanup
|
|
# ---------------------------------------------------------------------------
|
|
|
|
# Regular files under a directory older than the given number of days. The walk
|
|
# stays on one filesystem (-xdev) and never matches the start directory itself
|
|
# (-mindepth 1). undef means the find command failed, which callers must keep
|
|
# apart from an empty result.
|
|
sub find_old_files {
|
|
my ($directory, $days) = @_;
|
|
my $p = run([
|
|
'find', $directory, '-mindepth', '1', '-xdev',
|
|
'-type', 'f', '-mtime', "+$days", '-print0',
|
|
], 120);
|
|
return undef if $p->{rc} != 0;
|
|
return [ grep { length } split /\0/, $p->{out} ];
|
|
}
|
|
|
|
sub paths_size {
|
|
my ($paths) = @_;
|
|
my $total = 0;
|
|
for my $path (@$paths) {
|
|
my $size = -s $path;
|
|
$total += $size if defined $size;
|
|
}
|
|
return $total;
|
|
}
|
|
|
|
# Split the paths listed before deletion into those the verification pass no
|
|
# longer sees (gone) and those it still sees (left). Only the first group is
|
|
# what this run took away: a file that merely ages into the window between the
|
|
# two passes shows up in the second listing without ever having been listed
|
|
# before, and a count difference would wrongly charge it against the deletions.
|
|
sub split_by_presence {
|
|
my ($before, $after) = @_;
|
|
my %after = map { $_ => 1 } @$after;
|
|
return (
|
|
[ grep { !$after{$_} } @$before ],
|
|
[ grep { $after{$_} } @$before ],
|
|
);
|
|
}
|
|
|
|
# Clean one temp directory, returning (files affected, bytes freed). Files are
|
|
# counted and measured before anything is removed, so the real-mode numbers
|
|
# describe what was actually taken away, while a dry run reports the size of the
|
|
# matching files and removes nothing.
|
|
sub clean_temp_dir {
|
|
my ($directory, $days, %opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $warnings = $opt{warnings};
|
|
my $errors = $opt{errors};
|
|
|
|
my $old_files = find_old_files($directory, $days);
|
|
if (!defined $old_files) {
|
|
status_done('failed');
|
|
_warn("find $directory failed, cannot list old files");
|
|
push @$warnings, "Temp cleanup of $directory failed (find error)";
|
|
push @$errors, "find failed in $directory";
|
|
return (0, 0);
|
|
}
|
|
my $old_size = paths_size($old_files);
|
|
|
|
if ($dry_run) {
|
|
status_done('would remove ' . scalar(@$old_files) . ' file(s) (~'
|
|
. format_size($old_size) . ')');
|
|
return (scalar @$old_files, $old_size);
|
|
}
|
|
|
|
for my $extra (
|
|
['-type', 'f', '-mtime', "+$days"],
|
|
# The same age filter for directories: without it, freshly created empty
|
|
# directories belonging to running applications would be removed.
|
|
['-type', 'd', '-empty', '-mtime', "+$days"],
|
|
) {
|
|
my $p = run(['find', $directory, '-mindepth', '1', '-xdev', @$extra, '-delete'], 120);
|
|
if ($p->{rc} != 0) {
|
|
_warn("find $directory -delete failed: " . last_lines($p->{err}));
|
|
push @$warnings, "Temp cleanup of $directory hit find errors";
|
|
push @$errors, "find -delete failed in $directory";
|
|
}
|
|
}
|
|
|
|
my $remaining = find_old_files($directory, $days);
|
|
if (!defined $remaining) {
|
|
# Success numbers are never fabricated when the verification pass failed.
|
|
_warn("Could not verify deletions in $directory, counts unknown");
|
|
push @$warnings, "Temp cleanup of $directory: post-delete verification failed";
|
|
push @$errors, "find verification failed in $directory";
|
|
return (0, 0);
|
|
}
|
|
my ($gone, $left) = split_by_presence($old_files, $remaining);
|
|
my $removed = scalar @$gone;
|
|
my $freed = $old_size - paths_size($left);
|
|
$freed = 0 if $freed < 0;
|
|
status_done("$removed file(s), freed " . format_size($freed));
|
|
return ($removed, $freed);
|
|
}
|
|
|
|
sub temp_cleanup {
|
|
my (%opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $warnings = $opt{warnings};
|
|
my %result = (
|
|
tmp_files_removed => 0,
|
|
vartmp_files_removed => 0,
|
|
tmp_files_planned => 0,
|
|
vartmp_files_planned => 0,
|
|
space_saved => 0,
|
|
errors => [],
|
|
);
|
|
|
|
status("Cleaning /tmp (files older than $TMP_MAX_AGE_DAYS days)");
|
|
my ($removed, $freed) = clean_temp_dir('/tmp', $TMP_MAX_AGE_DAYS,
|
|
dry_run => $dry_run, warnings => $warnings, errors => $result{errors});
|
|
$result{ $dry_run ? 'tmp_files_planned' : 'tmp_files_removed' } = $removed;
|
|
$result{space_saved} += $freed;
|
|
|
|
if (-d '/var/tmp') {
|
|
status("Cleaning /var/tmp (files older than $VARTMP_MAX_AGE_DAYS days)");
|
|
($removed, $freed) = clean_temp_dir('/var/tmp', $VARTMP_MAX_AGE_DAYS,
|
|
dry_run => $dry_run, warnings => $warnings, errors => $result{errors});
|
|
$result{ $dry_run ? 'vartmp_files_planned' : 'vartmp_files_removed' } = $removed;
|
|
$result{space_saved} += $freed;
|
|
}
|
|
else {
|
|
_info('/var/tmp: directory not found, skipping');
|
|
}
|
|
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 5: core dump cleanup
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub coredump_cleanup {
|
|
my (%opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $warnings = $opt{warnings};
|
|
my %result = (
|
|
cores_removed => 0,
|
|
cores_planned => 0,
|
|
cores_kept_recent => 0,
|
|
space_saved => 0,
|
|
errors => [],
|
|
);
|
|
|
|
my $coredump_dir = '/var/lib/systemd/coredump';
|
|
if (!-d $coredump_dir) {
|
|
_info('No coredump directory found, skipping');
|
|
return \%result;
|
|
}
|
|
|
|
my $cutoff = time() - $COREDUMP_MAX_AGE_DAYS * 86400;
|
|
my @old_dumps; # [name, mtime, size]
|
|
my $recent = 0;
|
|
my $dh;
|
|
if (!opendir($dh, $coredump_dir)) {
|
|
_warn("Cannot list $coredump_dir: $!");
|
|
push @$warnings, "Core dump cleanup skipped, cannot read $coredump_dir";
|
|
push @{ $result{errors} }, 'coredump listdir failed';
|
|
return \%result;
|
|
}
|
|
my @entries = sort readdir($dh);
|
|
closedir($dh);
|
|
for my $entry (@entries) {
|
|
next if $entry eq '.' || $entry eq '..';
|
|
my $full = "$coredump_dir/$entry";
|
|
my @st = stat($full);
|
|
next unless @st;
|
|
next unless -f $full;
|
|
if ($st[9] < $cutoff) {
|
|
push @old_dumps, [$entry, $st[9], $st[7]];
|
|
}
|
|
else {
|
|
$recent++;
|
|
}
|
|
}
|
|
$result{cores_kept_recent} = $recent;
|
|
|
|
if (!@old_dumps) {
|
|
_info("No core dumps older than $COREDUMP_MAX_AGE_DAYS days found");
|
|
_info("Keeping $recent recent core dump(s) (< $COREDUMP_MAX_AGE_DAYS days old)")
|
|
if $recent;
|
|
return \%result;
|
|
}
|
|
|
|
# Every dump is listed with its date and size before anything is removed.
|
|
my $total_size = 0;
|
|
$total_size += $_->[2] for @old_dumps;
|
|
my $heading = $dry_run ? 'Would remove' : 'Removing';
|
|
_info("$heading " . scalar(@old_dumps) . ' core dump(s) older than '
|
|
. "$COREDUMP_MAX_AGE_DAYS days (" . format_size($total_size) . '):');
|
|
for my $dump (@old_dumps) {
|
|
my ($name, $mtime, $size) = @$dump;
|
|
my @t = localtime($mtime);
|
|
my $date = sprintf('%04d-%02d-%02d %02d:%02d',
|
|
$t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1]);
|
|
my $prefix = $dry_run ? 'would remove' : 'remove';
|
|
_info(" $prefix: $name ($date, " . format_size($size) . ')');
|
|
}
|
|
|
|
if ($dry_run) {
|
|
$result{cores_planned} = scalar @old_dumps;
|
|
$result{space_saved} = $total_size;
|
|
return \%result;
|
|
}
|
|
|
|
status('Deleting ' . scalar(@old_dumps) . ' core dump(s)');
|
|
my ($removed, $freed, $failed) = (0, 0, 0);
|
|
for my $dump (@old_dumps) {
|
|
my ($name, undef, $size) = @$dump;
|
|
if (unlink("$coredump_dir/$name")) {
|
|
$removed++;
|
|
$freed += $size;
|
|
}
|
|
else {
|
|
$failed++;
|
|
_warn("Could not remove $name: $!");
|
|
}
|
|
}
|
|
$result{cores_removed} = $removed;
|
|
$result{space_saved} = $freed > 0 ? $freed : 0;
|
|
if ($failed) {
|
|
push @$warnings, "$failed core dump(s) could not be removed, see above";
|
|
push @{ $result{errors} }, 'coredump removal incomplete';
|
|
}
|
|
status_done('removed ' . $removed . ', freed ' . format_size($result{space_saved}));
|
|
_info("Keeping $recent recent core dump(s) (< $COREDUMP_MAX_AGE_DAYS days old)")
|
|
if $recent;
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# JSON decoding, hand-rolled
|
|
# ---------------------------------------------------------------------------
|
|
#
|
|
# dnf5 can describe a package list as JSON, which is steadier to read than its
|
|
# table output, and no JSON module may be assumed to exist. The decoder below
|
|
# covers the grammar the format allows, so another script that has to read JSON
|
|
# can lift it unchanged.
|
|
|
|
sub json_decode {
|
|
my ($text) = @_;
|
|
$text = '' unless defined $text;
|
|
my $pos = 0;
|
|
my $value = json_parse_value($text, \$pos);
|
|
json_skip_space($text, \$pos);
|
|
die "trailing data at offset $pos\n" if $pos < length $text;
|
|
return $value;
|
|
}
|
|
|
|
sub json_skip_space {
|
|
my ($text, $pos_ref) = @_;
|
|
my $length = length $text;
|
|
while ($$pos_ref < $length && substr($text, $$pos_ref, 1) =~ /[ \t\r\n]/) {
|
|
$$pos_ref++;
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub json_parse_value {
|
|
my ($text, $pos_ref) = @_;
|
|
json_skip_space($text, $pos_ref);
|
|
die "unexpected end of input at offset $$pos_ref\n" if $$pos_ref >= length $text;
|
|
my $char = substr($text, $$pos_ref, 1);
|
|
return json_parse_object($text, $pos_ref) if $char eq '{';
|
|
return json_parse_array($text, $pos_ref) if $char eq '[';
|
|
return json_parse_string($text, $pos_ref) if $char eq '"';
|
|
return json_parse_number($text, $pos_ref) if $char =~ /[-0-9]/;
|
|
for my $literal (['true', 1], ['false', 0], ['null', undef]) {
|
|
my ($word, $value) = @$literal;
|
|
if (substr($text, $$pos_ref, length $word) eq $word) {
|
|
$$pos_ref += length $word;
|
|
return $value;
|
|
}
|
|
}
|
|
die "unrecognised token at offset $$pos_ref\n";
|
|
}
|
|
|
|
sub json_parse_object {
|
|
my ($text, $pos_ref) = @_;
|
|
my %object;
|
|
$$pos_ref++; # the opening brace
|
|
json_skip_space($text, $pos_ref);
|
|
if (substr($text, $$pos_ref, 1) eq '}') {
|
|
$$pos_ref++;
|
|
return \%object;
|
|
}
|
|
while (1) {
|
|
json_skip_space($text, $pos_ref);
|
|
die "expected a key at offset $$pos_ref\n" unless substr($text, $$pos_ref, 1) eq '"';
|
|
my $key = json_parse_string($text, $pos_ref);
|
|
json_skip_space($text, $pos_ref);
|
|
die "expected a colon at offset $$pos_ref\n" unless substr($text, $$pos_ref, 1) eq ':';
|
|
$$pos_ref++;
|
|
$object{$key} = json_parse_value($text, $pos_ref);
|
|
json_skip_space($text, $pos_ref);
|
|
my $next = substr($text, $$pos_ref, 1);
|
|
if ($next eq ',') { $$pos_ref++; next }
|
|
if ($next eq '}') { $$pos_ref++; last }
|
|
die "expected a comma or a closing brace at offset $$pos_ref\n";
|
|
}
|
|
return \%object;
|
|
}
|
|
|
|
sub json_parse_array {
|
|
my ($text, $pos_ref) = @_;
|
|
my @items;
|
|
$$pos_ref++; # the opening bracket
|
|
json_skip_space($text, $pos_ref);
|
|
if (substr($text, $$pos_ref, 1) eq ']') {
|
|
$$pos_ref++;
|
|
return \@items;
|
|
}
|
|
while (1) {
|
|
push @items, json_parse_value($text, $pos_ref);
|
|
json_skip_space($text, $pos_ref);
|
|
my $next = substr($text, $$pos_ref, 1);
|
|
if ($next eq ',') { $$pos_ref++; next }
|
|
if ($next eq ']') { $$pos_ref++; last }
|
|
die "expected a comma or a closing bracket at offset $$pos_ref\n";
|
|
}
|
|
return \@items;
|
|
}
|
|
|
|
sub json_parse_string {
|
|
my ($text, $pos_ref) = @_;
|
|
$$pos_ref++; # the opening quote
|
|
my $out = '';
|
|
my $length = length $text;
|
|
my %simple = (
|
|
'"' => '"',
|
|
'\\' => '\\',
|
|
'/' => '/',
|
|
'b' => "\b",
|
|
'f' => "\f",
|
|
'n' => "\n",
|
|
'r' => "\r",
|
|
't' => "\t",
|
|
);
|
|
while ($$pos_ref < $length) {
|
|
my $char = substr($text, $$pos_ref, 1);
|
|
if ($char eq '"') {
|
|
$$pos_ref++;
|
|
return $out;
|
|
}
|
|
if ($char ne '\\') {
|
|
$out .= $char;
|
|
$$pos_ref++;
|
|
next;
|
|
}
|
|
$$pos_ref++;
|
|
my $escape = substr($text, $$pos_ref, 1);
|
|
if (exists $simple{$escape}) {
|
|
$out .= $simple{$escape};
|
|
$$pos_ref++;
|
|
next;
|
|
}
|
|
die "unrecognised escape at offset $$pos_ref\n" unless $escape eq 'u';
|
|
my $hex = substr($text, $$pos_ref + 1, 4);
|
|
die "malformed \\u escape at offset $$pos_ref\n" unless $hex =~ /^[0-9a-fA-F]{4}$/;
|
|
my $code = hex $hex;
|
|
$$pos_ref += 5;
|
|
# a high surrogate is followed by the low half of the pair
|
|
if ($code >= 0xd800 && $code <= 0xdbff && substr($text, $$pos_ref, 2) eq '\\u') {
|
|
my $low_hex = substr($text, $$pos_ref + 2, 4);
|
|
if ($low_hex =~ /^[0-9a-fA-F]{4}$/) {
|
|
my $low = hex $low_hex;
|
|
if ($low >= 0xdc00 && $low <= 0xdfff) {
|
|
$code = 0x10000 + (($code - 0xd800) << 10) + ($low - 0xdc00);
|
|
$$pos_ref += 6;
|
|
}
|
|
}
|
|
}
|
|
my $bytes = pack('U', $code);
|
|
utf8::encode($bytes);
|
|
$out .= $bytes;
|
|
}
|
|
die "unterminated string\n";
|
|
}
|
|
|
|
sub json_parse_number {
|
|
my ($text, $pos_ref) = @_;
|
|
my $length = length $text;
|
|
my $start = $$pos_ref;
|
|
$$pos_ref++ if substr($text, $$pos_ref, 1) eq '-';
|
|
$$pos_ref++ while $$pos_ref < $length && substr($text, $$pos_ref, 1) =~ /[0-9]/;
|
|
if ($$pos_ref < $length && substr($text, $$pos_ref, 1) eq '.') {
|
|
$$pos_ref++;
|
|
$$pos_ref++ while $$pos_ref < $length && substr($text, $$pos_ref, 1) =~ /[0-9]/;
|
|
}
|
|
if ($$pos_ref < $length && substr($text, $$pos_ref, 1) =~ /[eE]/) {
|
|
$$pos_ref++;
|
|
$$pos_ref++ if substr($text, $$pos_ref, 1) =~ /[-+]/;
|
|
$$pos_ref++ while $$pos_ref < $length && substr($text, $$pos_ref, 1) =~ /[0-9]/;
|
|
}
|
|
my $literal = substr($text, $start, $$pos_ref - $start);
|
|
unless ($literal =~ /^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][-+]?[0-9]+)?$/) {
|
|
die "malformed number at offset $start\n";
|
|
}
|
|
return $literal + 0;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Section 6: package audit, informational only
|
|
# ---------------------------------------------------------------------------
|
|
|
|
# The package names in a dnf5 --json answer, as name.arch where an architecture
|
|
# is given, sorted. Returns undef when the text is not JSON this can read, which
|
|
# the caller reports as unavailable rather than as an empty list.
|
|
sub extras_names {
|
|
my ($text) = @_;
|
|
my $data = eval { json_decode($text) };
|
|
return undef unless defined $data && ref $data eq 'HASH';
|
|
my @found;
|
|
for my $section (values %$data) {
|
|
next unless ref $section eq 'ARRAY';
|
|
for my $package (@$section) {
|
|
next unless ref $package eq 'HASH' && $package->{name};
|
|
push @found, $package->{arch}
|
|
? "$package->{name}.$package->{arch}"
|
|
: $package->{name};
|
|
}
|
|
}
|
|
return [ sort @found ];
|
|
}
|
|
|
|
# The package names in a dnf 4 --quiet listing: one per line, above which dnf
|
|
# writes header lines naming cache and section state rather than packages. The
|
|
# order dnf printed them in is kept.
|
|
sub extras_names_text {
|
|
my ($text) = @_;
|
|
my @headers = ('last metadata', 'extra packages', 'available packages', 'installed packages');
|
|
my @names;
|
|
for my $line (split /\n/, ($text // '')) {
|
|
$line =~ s/^\s+//;
|
|
$line =~ s/\s+$//;
|
|
next unless length $line;
|
|
my $lower = lc $line;
|
|
next if grep { index($lower, $_) == 0 } @headers;
|
|
my @fields = split ' ', $line;
|
|
push @names, $fields[0] if @fields;
|
|
}
|
|
return \@names;
|
|
}
|
|
|
|
sub package_audit {
|
|
my ($dnf_major, %opt) = @_;
|
|
my $warnings = $opt{warnings};
|
|
my %result = (
|
|
extras_count => 0,
|
|
extras_packages => [],
|
|
errors => [],
|
|
);
|
|
|
|
status('Checking for packages not in any repo (dnf list --extras)');
|
|
|
|
my ($p, $names);
|
|
if ($dnf_major >= 5) {
|
|
# dnf 5 describes the list as JSON, which does not have to be read out of
|
|
# a table whose columns move between releases.
|
|
$p = run(['dnf', 'list', '--extras', '--json'], 60);
|
|
$names = $p->{rc} == 0 ? extras_names($p->{out}) : undef;
|
|
}
|
|
else {
|
|
# dnf 4 has no --json option, so its quiet listing is read instead.
|
|
$p = run(['dnf', 'list', '--extras', '--quiet'], 60);
|
|
$names = $p->{rc} == 0 ? extras_names_text($p->{out}) : undef;
|
|
}
|
|
|
|
if (!defined $names) {
|
|
status_done('unavailable');
|
|
my $detail = $p->{rc} != 0 ? last_lines($p->{err}) : 'unparseable dnf output';
|
|
my $msg = "dnf list --extras unavailable: $detail";
|
|
_warn($msg);
|
|
push @$warnings, $msg;
|
|
return \%result;
|
|
}
|
|
|
|
$result{extras_count} = scalar @$names;
|
|
$result{extras_packages} = $names;
|
|
if (@$names) {
|
|
status_done(scalar(@$names) . ' package(s)');
|
|
_warn("Extra package: $_") for @$names[0 .. (@$names > 10 ? 9 : $#$names)];
|
|
_warn(' ... and ' . (scalar(@$names) - 10) . ' more') if @$names > 10;
|
|
push @$warnings, scalar(@$names) . ' installed package(s) not found in any repo';
|
|
}
|
|
else {
|
|
status_done('none');
|
|
}
|
|
|
|
return \%result;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Summary
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub print_summary {
|
|
my ($os_display, $version_id, $results, $warnings, $elapsed, %opt) = @_;
|
|
my $dry_run = $opt{dry_run};
|
|
my $bar = "═" x 60;
|
|
|
|
print STDERR "\n${BOLD}── Optimisation Summary ──$RESET\n";
|
|
print STDERR " OS: $os_display $version_id\n";
|
|
if ($dry_run) {
|
|
print STDERR " ${YELLOW}DRY RUN: nothing was changed, every action below is a would-be action$RESET\n";
|
|
}
|
|
|
|
my $dnf = $results->{dnf} // {};
|
|
if (%$dnf) {
|
|
my $count = $dnf->{autoremoved_count} // 0;
|
|
if ($dry_run) {
|
|
if ($count > 0) { _info("DNF autoremove: would remove $count package(s)") }
|
|
else { _info('DNF autoremove: nothing to remove') }
|
|
}
|
|
elsif ($dnf->{autoremoved}) { _ok("DNF autoremove: removed $count package(s)") }
|
|
else { _info('DNF autoremove: nothing to remove') }
|
|
|
|
my $kernels = $dry_run ? ($dnf->{kernels_planned} // 0) : ($dnf->{kernels_removed} // 0);
|
|
if ($kernels > 0) {
|
|
if ($dry_run) { _info("Old kernels: would remove $kernels") }
|
|
else { _ok("Old kernels removed: $kernels") }
|
|
}
|
|
else {
|
|
_info('Old kernels: none to remove');
|
|
}
|
|
_info('Kernels kept: ' . ($dnf->{kernels_kept} // '?'));
|
|
|
|
my $cache_saved = format_size($dnf->{space_saved} // 0);
|
|
if ($dry_run) { _info("DNF cache: would clean (~$cache_saved)") }
|
|
elsif ($dnf->{cache_cleaned}) { _ok("DNF cache: cleaned (freed $cache_saved)") }
|
|
}
|
|
|
|
my $journal = $results->{journal} // {};
|
|
if (%$journal) {
|
|
if ($dry_run) {
|
|
_info("Journal: would vacuum to ${JOURNAL_VACUUM_SIZE_MB}M (est. freed ~"
|
|
. format_size($journal->{space_saved} // 0) . ')');
|
|
}
|
|
elsif ($journal->{vacuumed}) {
|
|
_ok('Journal vacuumed: freed ' . format_size($journal->{space_saved} // 0));
|
|
}
|
|
if ($journal->{persistent_warning}) {
|
|
_warn('Journal storage is still large, check SystemMaxUse= in journald.conf');
|
|
}
|
|
}
|
|
|
|
my $systemd = $results->{systemd} // {};
|
|
if (%$systemd) {
|
|
my $failed = scalar @{ $systemd->{failed_units} // [] };
|
|
if ($failed > 0) { _warn("Failed systemd units: $failed") }
|
|
else { _ok('Failed systemd units: none') }
|
|
_info('Disabled unit files: ' . ($systemd->{disabled_count} // 0) . ' (informational)');
|
|
my $leftovers = scalar @{ $systemd->{leftover_files} // [] };
|
|
if ($leftovers > 0) { _warn("Leftover unit files in /etc/systemd/system/: $leftovers") }
|
|
else { _info('Leftover unit files: none') }
|
|
}
|
|
|
|
my $tmp = $results->{tmp} // {};
|
|
if (%$tmp) {
|
|
my ($tmp_count, $vartmp_count) = $dry_run
|
|
? ($tmp->{tmp_files_planned} // 0, $tmp->{vartmp_files_planned} // 0)
|
|
: ($tmp->{tmp_files_removed} // 0, $tmp->{vartmp_files_removed} // 0);
|
|
if ($tmp_count > 0 || $vartmp_count > 0) {
|
|
my $verb = $dry_run ? 'would remove' : 'removed';
|
|
my $msg = "Temp files: $verb $tmp_count from /tmp, $vartmp_count from /var/tmp";
|
|
$dry_run ? _info($msg) : _ok($msg);
|
|
}
|
|
else {
|
|
_info('Temp files: none to remove');
|
|
}
|
|
}
|
|
|
|
my $cores = $results->{cores} // {};
|
|
if (%$cores) {
|
|
my $count = $dry_run ? ($cores->{cores_planned} // 0) : ($cores->{cores_removed} // 0);
|
|
if ($count > 0) {
|
|
my $verb = $dry_run ? 'would remove' : 'removed';
|
|
my $msg = "Core dumps: $verb $count (older than $COREDUMP_MAX_AGE_DAYS days)";
|
|
$dry_run ? _info($msg) : _ok($msg);
|
|
}
|
|
else {
|
|
_info('Core dumps: none to remove');
|
|
}
|
|
if (($cores->{cores_kept_recent} // 0) > 0) {
|
|
_info('Core dumps kept (recent): ' . $cores->{cores_kept_recent});
|
|
}
|
|
}
|
|
|
|
my $packages = $results->{packages} // {};
|
|
if (%$packages) {
|
|
my $extras = $packages->{extras_count} // 0;
|
|
if ($extras > 0) { _warn("Packages not in any repo: $extras") }
|
|
else { _ok('Package audit: all packages from known repos') }
|
|
}
|
|
|
|
my $total_space = 0;
|
|
$total_space += ($results->{$_} // {})->{space_saved} // 0 for qw(dnf journal tmp cores);
|
|
if ($dry_run) {
|
|
_info('Estimated space to free: ~' . format_size($total_space));
|
|
}
|
|
elsif ($total_space > 0) {
|
|
_ok('Total space freed: ' . format_size($total_space));
|
|
}
|
|
else {
|
|
_info('Total space freed: 0 B');
|
|
}
|
|
|
|
if (@$warnings) {
|
|
print STDERR "\n";
|
|
_warn($_) for @$warnings;
|
|
}
|
|
|
|
print STDERR "\n${BOLD}${bar}$RESET\n";
|
|
printf STDERR " %sTotal time: %.1fs%s\n", $BOLD, $elapsed, $RESET;
|
|
print STDERR "${BOLD}${bar}$RESET\n\n";
|
|
return;
|
|
}
|
|
|
|
# ---------------------------------------------------------------------------
|
|
# Command line
|
|
# ---------------------------------------------------------------------------
|
|
|
|
sub usage {
|
|
my $name = $0;
|
|
$name =~ s{.*/}{};
|
|
return <<"USAGE";
|
|
Usage: $name [options]
|
|
|
|
Idempotent system cleanup and optimisation for Fedora, CentOS Stream and openEuler
|
|
|
|
Options:
|
|
--dry-run Preview without making changes
|
|
--skip-dnf Skip DNF cleanup (autoremove, old kernels, cache)
|
|
--skip-journal Skip journal vacuum
|
|
--skip-tmp Skip temp file cleanup
|
|
--skip-cores Skip core dump cleanup
|
|
--version Show the version and exit
|
|
-h, --help Show this help and exit
|
|
USAGE
|
|
}
|
|
|
|
sub parse_args {
|
|
my %opt = (
|
|
dry_run => 0,
|
|
skip_dnf => 0,
|
|
skip_journal => 0,
|
|
skip_tmp => 0,
|
|
skip_cores => 0,
|
|
);
|
|
my %flag_for = (
|
|
'--dry-run' => 'dry_run',
|
|
'--skip-dnf' => 'skip_dnf',
|
|
'--skip-journal' => 'skip_journal',
|
|
'--skip-tmp' => 'skip_tmp',
|
|
'--skip-cores' => 'skip_cores',
|
|
);
|
|
my @argv = @ARGV;
|
|
while (defined(my $arg = shift @argv)) {
|
|
if (exists $flag_for{$arg}) { $opt{ $flag_for{$arg} } = 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 $start_time = now();
|
|
my @warnings;
|
|
my @failures;
|
|
my %results;
|
|
|
|
my %opt = parse_args();
|
|
check_root();
|
|
my ($os_id, $os_display, $version_id) = detect_os();
|
|
my $dnf_major = dnf_generation();
|
|
|
|
my $bar = "═" x 60;
|
|
print STDERR "\n${BOLD}${bar}$RESET\n";
|
|
print STDERR "${BOLD} System Optimise v$VERSION ($os_display $version_id)$RESET\n";
|
|
print STDERR "${BOLD}${bar}$RESET\n";
|
|
if ($opt{dry_run}) {
|
|
print STDERR "\n ${YELLOW}${BOLD}DRY RUN: no changes will be made$RESET\n";
|
|
}
|
|
print STDERR "\n";
|
|
|
|
my @sections = (
|
|
['dnf', 'DNF Cleanup',
|
|
sub { dnf_cleanup($os_id, $dnf_major, dry_run => $opt{dry_run}, warnings => \@warnings) },
|
|
$opt{skip_dnf} ? '--skip-dnf' : undef],
|
|
['journal', 'Journal Cleanup',
|
|
sub { journal_cleanup(dry_run => $opt{dry_run}, warnings => \@warnings) },
|
|
$opt{skip_journal} ? '--skip-journal' : undef],
|
|
['systemd', 'systemd Audit',
|
|
sub { systemd_audit(warnings => \@warnings) },
|
|
undef],
|
|
['tmp', 'Temp File Cleanup',
|
|
sub { temp_cleanup(dry_run => $opt{dry_run}, warnings => \@warnings) },
|
|
$opt{skip_tmp} ? '--skip-tmp' : undef],
|
|
['cores', 'Core Dump Cleanup',
|
|
sub { coredump_cleanup(dry_run => $opt{dry_run}, warnings => \@warnings) },
|
|
$opt{skip_cores} ? '--skip-cores' : undef],
|
|
['packages', 'Package Audit',
|
|
sub { package_audit($dnf_major, warnings => \@warnings) },
|
|
undef],
|
|
);
|
|
|
|
# Every section is isolated: one that fails or dies is recorded and reported
|
|
# without stopping the rest or the summary.
|
|
for my $section (@sections) {
|
|
my ($key, $title, $code, $skip_flag) = @$section;
|
|
print STDERR "\n${BOLD}── $title ──$RESET\n";
|
|
if (defined $skip_flag) {
|
|
_info("$title: skipped ($skip_flag)");
|
|
next;
|
|
}
|
|
my $result = eval { $code->() };
|
|
if (my $error = $@) {
|
|
$error =~ s/\s+\z//;
|
|
_fail("$title crashed: $error");
|
|
push @failures, "$title: crashed ($error)";
|
|
next;
|
|
}
|
|
$results{$key} = $result;
|
|
push @failures, map { "$title: $_" } @{ $result->{errors} // [] };
|
|
}
|
|
|
|
my $elapsed = now() - $start_time;
|
|
print_summary($os_display, $version_id, \%results, \@warnings, $elapsed,
|
|
dry_run => $opt{dry_run});
|
|
|
|
if (@failures) {
|
|
print STDERR "${RED}${BOLD}Failed operations (" . scalar(@failures) . "):$RESET\n";
|
|
_fail($_) for @failures;
|
|
print STDERR "\n";
|
|
exit 1;
|
|
}
|
|
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;
|