petrbalvin/scripts
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
scripts/system-optimise.pl
T

1728 lines
61 KiB
Perl
Raw Permalink Normal View History

feat: initial release of the scripts collection
2026-09-10 04:00:00 +00:00
#!/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;
Reference in New Issue Copy Permalink