#!/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 @timers = (); tStart("main");


# 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");
}


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


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


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


# 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";
    tEnd();
    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";
tEnd();
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
    tStart("readdir_dpkg_status");
    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);
    tEnd();

    # Find kernel package name in dpkg info files
    tStart("find_curkerpkgname");
    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 "";
    tEnd();

    # Look up package version
    tStart("find_curkerpkgver");
    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.\n$num_results resukts found != 1 result expected.\n" if ($num_results != 1);
    tEnd();

    # 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 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-(?:backports|headers|image|modules|restricted|tools|ubuntu)(?:-(?:extra|modules))?-\d+\.\d+.*)#) {
            $pkg = $1;
            next;
        }

        next if $pkg eq "";

        next unless $line =~ m#^Version: (.*)$#;
        $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;
}


sub tStart {
    return if not $debug;
    my ($tag) = @_;
    push @timers, $tag;
    push @timers, [gettimeofday];
}

sub tEnd {
    return if not $debug;
    my $tod_stamp = pop @timers;
    my $tag = pop @timers;
    die "$0: tag/tod undefined. internal error in timing system :(\n"
        if not defined $tag or not defined $tod_stamp;
    my $elapsed = tv_interval($tod_stamp);
    printf "[timer] %s %0.3fsec\n", $tag, $elapsed;
}
