#!/usr/bin/perl -wT
BEGIN { $ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin"; }
use strict;
use Data::Dumper;
use Time::HiRes qw(gettimeofday tv_interval);
eval { require Dpkg::Version; }; if ($@) { print "$0: requires package libdpkg-perl installed.\n"; exit 0; }
sub isNewer ($$); # prototype for sort{} usage

if (-e "/etc/apt/do-not-purgekernel") {
    print "$0: found '/etc/apt/do-not-purgekernel' on this box - obliging.\n";
    exit 0;
}

#
# This now depends on libdpkg-perl:
#   sudo apt-get install libdpkg-perl
#
# Run as apt-get Post-Invoke:
#   $ cat /etc/apt/apt.conf.d/88local
#   DPkg::Post-Invoke { "/usr/local/sbin/purgekernels --debug"; };
#
# Or manual:
#   # /usr/local/sbin/purgekernels --debug
#
# --debug makes it verbose and allows non-root users to toy with this.
#


my $debug = 0; $debug++ if grep(/--debug/, @ARGV);
my $metacheck = 0; $metacheck++ if grep(/--metacheck/, @ARGV);

my @timers = ();

# Test for special conditions we don't want to meddle with
my @supported_archs = ('x86_64', 'i386', 'i686');
my $arch = `/bin/uname -m`; chomp($arch);
my $virt_what = "/usr/sbin/virt-what";
if (-e $virt_what) {
    my $virt = `$virt_what`; chomp($virt);
    if ($virt =~ m#^(?:openvz|lxc)#) {
        print "Not cleaning in container: '$virt'";
        exit 0;
    }
    dprint("Virtualization status: '$virt'");
} else {
    dprint("Could not find 'virt-what' utility, can't check if container or not.");
}
if (not grep /^$arch$/, @supported_archs) {
    print "Purgekernels not supported on this architecture: $arch";
    exit 0;
} else {
    dprint("Detected architecture '$arch' is supported");
}


# Check for multiple linux-image 'meta' packages installed
my ($num_img, $num_hdr, @meta_pkgs) = MultipleLinuxImageMetaPkgsInstalled();
if (($num_img > 1) or ($num_hdr > 1)) {
    print "[EE] Multiple kernel type meta packages are installed!\n";
    print "     Purgekernels will not run!\n\n";
    print "Decide what kernel (and matching headers?) to keep and make sure only\n";
    print "one type of these meta packages are installed, not multiple types.\n\n";
    print "Found $num_img image meta package(s), $num_hdr header meta package(s).\n";
    print "Meta packages found installed:\n";
    foreach my $meta_pkg (@meta_pkgs) {
        print " - $meta_pkg\n";
    }
    print "\nYou can also disable purgekernels by doing:\n";
    print "   touch /etc/apt/do-not-purgekernel\n\n";
    exit 1 if $metacheck;
    exit 0;
}
dprint("Found meta package(s): " . join(", ", @meta_pkgs) . "\n");
exit 0 if $metacheck;


print "$0: Cleaning up kernels.\n";


# Find running kernel package
my ($cur_ker_pkg, $cur_ker_pkg_ver) = findCurrentKernelPackage();
dprint("Running '$cur_ker_pkg' version '$cur_ker_pkg_ver'");


# Find kernel packages
my $kernels = parseDpkgStatus();
die "Parsing failed? no kernels installed?\n" if not scalar(keys(%$kernels));
dprint("Found kernel $_") foreach keys %$kernels;


# Sort kernels by version
my @kernels_to_purge = reverse sort { isNewer($a, $b) } keys %$kernels;


# Strip off the top three, keeping these installed
my $keep1 = shift @kernels_to_purge; # newest kernel should always be installed
my $keep2 = shift @kernels_to_purge; $keep2 ||= "";
print("Reboot to activate newer kernel $keep1\n") if isNewer($keep1, $cur_ker_pkg_ver);
dprint("Keeping $keep1");
dprint("keeping $keep2") if $keep2 ne "";
dprint("Removing $_") foreach @kernels_to_purge;


# Current kernel could be in the remainder of the list.
# Use hash to uniquify packagenames.
my $remove_kernel_packages = {};
foreach my $remove_kernel_version (@kernels_to_purge) {
    if ($remove_kernel_version eq $cur_ker_pkg_ver) {
        dprint("Not removing current kernel '$cur_ker_pkg_ver'");
        next;
    }

    foreach my $pkg (@{$$kernels{$remove_kernel_version}}) {
        next if $$remove_kernel_packages{$pkg}++;
        print "$0: Removing package '$pkg' version '$remove_kernel_version'\n";
    }
}


# Bail if no packages left
if (not scalar keys %$remove_kernel_packages) {
    print "$0: Nothing to do.\n";
    exit 0;
}

# If we get here, actually call dpkg...
my @cmd = ("/usr/bin/dpkg", "--purge");
push @cmd, $_ foreach keys %$remove_kernel_packages;
print "$0: exec: " . join(" ", @cmd) . "\n";
print "\n";
exec { $cmd[0] } @cmd or die "Exec failed: $!\n";
exit 1;


######
######
######
######


sub findCurrentKernelPackage {
    # return value init
    my $cur_ker_pkg = my $cur_ker_pkg_ver = "";

    # find current kernel vmlinuz file
    my $uname = `uname -r`; chomp($uname);
    my $vmlinuz = "/boot/vmlinuz-" . $uname;
    die "$0: Can't find kernel '$vmlinuz'\n" if (not -e $vmlinuz);

    # find file list for packages
    my $dpkg_info_path = "/var/lib/dpkg/info";
    opendir(DIR, $dpkg_info_path) or die "$0: Can't opendir '$dpkg_info_path': $!\n";
    my @files = grep { /^linux-.*\d+\.\d+.*\.list/ } readdir DIR;
    closedir(DIR);

    # Find kernel package name in dpkg info files
    foreach my $file (reverse sort @files) {
        my $data = "";
        my $fqp = $dpkg_info_path ."/". $file;
        open (FD, "<$fqp") or die "$0: Can't read '$fqp': $!\n";
        { local $/ = undef; $data = <FD>; close(FD); }
        if ($data =~ m#^${vmlinuz}$#m) { $file =~ s#\.list$##; $cur_ker_pkg = $file; last; }
    }
    die "$0: Couldn't find package providing '$vmlinuz' :(\n" if $cur_ker_pkg eq "";

    # Look up package version
    my $pkg_ver_tmp = parseDpkgStatus($cur_ker_pkg);
    my $num_results = scalar(keys(%$pkg_ver_tmp));
    die "$0: fetching version of package '$cur_ker_pkg' failed.\nExpected 1 result, but got $num_results.\n" if ($num_results != 1);

    # copy current kernel package version, which is the only key in the result hashref
    $cur_ker_pkg_ver = (keys %$pkg_ver_tmp)[0];

    return ($cur_ker_pkg, $cur_ker_pkg_ver);
}


sub MultipleLinuxImageMetaPkgsInstalled {
    open(FD, "</var/lib/dpkg/status") or die "$0: Can't read '/var/lib/dpkg/status': $!\n";

    my $pkgobj = {};
    my @ret = ();
    my $num_img = my $num_hdr = 0;

    while (my $line = <FD>) {
        if ($line =~ m#^$#) { # Process with each new package.
            if (($$pkgobj{'source'}||"undef") =~ 'linux-meta') {
                $num_img++ if $$pkgobj{'package'} =~ m#^linux-image#;
                $num_hdr++ if $$pkgobj{'package'} =~ m#^linux-headers#;
                push @ret, $$pkgobj{'package'} if ($$pkgobj{'package'} =~ m#^linux-(?:image|headers)-#);
            }
            $pkgobj = {};
            next;
        }

        next if $line !~ m#^(?:Source|Package)#;

        $line =~ m#^(\S+):\s(.*)#;
        my ($key, $value) = (lc($1), $2);
        $$pkgobj{$key} = $value;
    }
    close(FD);

    return ($num_img, $num_hdr, @ret);
}


sub parseDpkgStatus {
    my ($specific_pkgmatch) = @_;
    open(FD, "</var/lib/dpkg/status") or die "$0: Can't read '/var/lib/dpkg/status': $!\n";
    my $pkg = my $ver = ""; my $ret = {};
    while (my $line = <FD>) {
        # Reset with each new package.
        if ($line =~ m#^$#) { $pkg = $ver = ""; next; }

        # Look up version for specific package if requested.
        # Package name still has to match the regexp below...
        next if ($pkg eq "" and defined $specific_pkgmatch and $line !~ m#^Package: $specific_pkgmatch$#);

        # Only look for versioned packages, avoid removing meta packages
        if ($line =~ m#^Package: (linux-(?:hwe-\d+\.\d+-)?(?:backports|headers|image|modules|restricted|tools|ubuntu|main)(?:-(?:unsigned|extra|modules(?:-zfs)?))?-\d+\.\d+.*)#) {
            $pkg = $1;
            next;
        }

        next if $pkg eq "";

        next unless $line =~ m#^Version: (.+?)(?:\+\d+)?$#;
        $ver = $1;
        push @{$$ret{$ver}}, $pkg;
        $pkg = ""; 
    }
    close(FD);
    return $ret;
}


# wrapper sub for sort {} usage needs prototyping
sub isNewer ($$) {
    my ($a, $b) = @_;
    my $v1 = Dpkg::Version->new($a);
    my $v2 = Dpkg::Version->new($b);
    return 1 if ($v1 > $v2);
    return -1 if ($v1 < $v2);
    return 0;
}


sub dprint {
    my ($msg, $level) = @_;
    return if not $debug;
    $level ||= 1;
    $msg =~ s/\n+$//;
    print STDERR $msg . "\n" if $level <= $debug;
}
