#!/usr/bin/perl -wT
BEGIN { $ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin"; }
use strict;
use Data::Dumper;
sub isnewer ($$); # prototype for sort{} usage

#
# $Id: purgekernels 1 2016-05-27 12:08:17Z sanders $
#
# Run as Post-Invoke:
# $ cat /etc/apt/apt.conf.d/88local
# DPkg::Post-Invoke { "/usr/local/sbin/purgekernels --debug"; };
#
# Or manual:
# root@host:~# /usr/local/sbin/purgekernels --debug
#
# --debug makes it verbose
#

my $debug = 0; $debug++ if grep(/--debug/, @ARGV);
$ENV{DEBCONF_FRONTEND} = 'noninteractive' if grep(/--non-interactive/, @ARGV);
$ENV{COLUMNS} = 240; # Older dpkg's dont show the entire package/version
                     # for dpkg -l queries even in piped constructs.

die "$0: Run this as root.\n" if ($< != 0 and not $debug);
print "$0: cleaning up kernels ..\n";


my $virt_what = "/usr/sbin/virt-what";
if (-e $virt_what) {
    my $virt = `$virt_what`; chomp($virt);
    if ($virt eq "openvz") {
        dprint("$0: not cleaning in openvz container.");
        exit 0;
    } else {
        dprint("$0: virtualization status: '$virt'");
    }
} else {
    dprint("$0: could not find 'virt-what' utility, can't check if openvz or not.");
}


# Find kernels
my $kernels = {};
my $dpkg = `dpkg -l linux-image-\* linux-headers-\* linux-signed-image-\* linux-restricted-modules-\* linux-ubuntu-modules-\* linux-backports-modules-\* 2>&1`;
#dprint("cmd out: '$dpkg'");
while ($dpkg =~ m#^[pri][ci]\s+(linux\-\S+)\s+(\d+\.\d+\.\d+[\-\.]\S+)\s#gm) {
    push @{$$kernels{$2}}, "$1";
    dprint("found kernel version $2 (package $1)");
}

die "parsing failed? no kernels installed?\n" if not scalar(keys(%$kernels));


# Current kernel
my $uname = `uname -r`; chomp($uname);
#dprint("cmd out: '$uname'");
my ($current_kernel_version) = $uname =~ m#(\d+\.\d+\.\d+\-\d+)\-#;
dprint("currently running $current_kernel_version");


# Rinse dem proper
# Strip off the top three, keeping these installed.
my @sorted_kernels = reverse sort { isnewer($a, $b) } keys %$kernels;
dprint("---- \$kernels ----");         dprint("" . Dumper($kernels));
dprint("---- \@sorted_kernels -----"); dprint("" . Dumper(@sorted_kernels));
my $keep1 = shift @sorted_kernels; # at least one kernel should be installed
my $keep2 = shift @sorted_kernels; $keep2 ||= "";
my $keep3 = shift @sorted_kernels; $keep3 ||= "";
dprint("keeping  [$keep1]  [$keep2]  [$keep3]");
print("reboot to activate newer kernel $keep1\n") if isnewer($keep1, $current_kernel_version);


# Current kernel could be in the remainder of the list!
# Build package hash to uniquify pkgnames
my $pkghash = {};
foreach my $remove_kernel_version (@sorted_kernels) {
    if ($remove_kernel_version eq $current_kernel_version) {
        print "not removing current kernel.\n";
        next;
    }

    foreach my $pkg (@{$$kernels{$remove_kernel_version}}) {
        next if $$pkghash{$pkg}++;
        print "removing $remove_kernel_version ($pkg)\n";
    }
}


# Launch dpkg to purge the kernels and extra packages
my @cmd = ("/usr/bin/dpkg", "--purge");
push @cmd, $_ foreach keys %$pkghash;
do {
    print "\n-- dpkg output --\n\n";
    system(@cmd) == 0 or warn "Forking dpkg failed: $!\n";
    if ($? == -1) {
        print "failed to execute: $!\n";
    } elsif ($? & 127) {
        printf "child died with signal %d, %s coredump\n", ($? & 127),  ($? & 128) ? 'with' : 'without';
    } else {
        printf "child exited with value %d\n", $? >> 8;
    }
} unless ($debug or not scalar keys %$pkghash);


print "$0: done.\n";
exit 0;



##  ##
# ## #
#bwub#
######



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



sub isnewer ($$) {
    my ($astr, $bstr) = @_;

    $astr =~ s/-/./g; my ($aver, $amaj, $amin, $arev) = split /\./, $astr;
    $bstr =~ s/-/./g; my ($bver, $bmaj, $bmin, $brev) = split /\./, $bstr;
    $aver ||= 0; $amaj ||= 0; $amin ||= 0; $arev ||= 0;
    $bver ||= 0; $bmaj ||= 0; $bmin ||= 0; $brev ||= 0;

    return 1 if $aver > $bver; return -1 if $bver > $aver;
    return 1 if $amaj > $bmaj; return -1 if $bmaj > $amaj;
    return 1 if $amin > $bmin; return -1 if $bmin > $amin;
    return 1 if $arev > $brev; return -1 if $brev > $arev;
    return 0;
}
