#!/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;