#!/usr/bin/perl -CSDA
#
# $Id: dirtrim.pl 597 2014-07-03 09:44:29Z james $
#
# Script to delete the oldest files from a directory to satisfy a total size requirement.
#
# Copyright 2014 James Clark. All rights reserved.
# This program is Free software; you can redistribute it and/or modify it under the same terms as Perl itself.

use warnings;
use strict;
use utf8;
use File::Find;
use File::Copy;
use File::Basename;
use Getopt::Long;

my %opts;
GetOptions(\%opts, 'help!', 'delete!', 'move=s', 'size=s', 'atime!', 'mtime!', 'ctime!', 'basename!', 'pathname!', 'verbose!');

my @FILES;	# list of hashrefs, {name, size, atime, mtime, ctime}. Populated by find_callback.
my $TIME_ATTR = "mtime";	# What to sort by. Affects the by_time_attr() sorting sub.


sub help
{
	print STDERR <<EOF;
Usage: $0 --size <size>{K,M,G} dirname/ --delete
       $0 --size <size>{K,M,G} dirname/ --move destdir/
       
       Omitting --delete and --move does a dry-run.

       --atime    : Sort by last access time
       --mtime    : Sort by last modified time (default)
       --ctime    : Sort by last inode change time
       --basename : Sort by file basename
       --pathname : Sort by file pathname
       
       --verbose : Show the list of files with timestamps

Sorts files contained in the given directory according to age, and deletes
the oldest files until the total size of the directory is under the given
size limit.
EOF
	return 1;
}


sub main
{
	# We accept exactly one argument not covered by Getopt::Long : which dir to operate on.
	my $dir = shift @ARGV;
	die "Need to supply a directory name!" unless (defined $dir && -d $dir);
	die "Need to supply a --size!" unless (defined $opts{size});
	die "--move option needs a directory to move to!" if ($opts{move} && ! -d $opts{move});
		
	# Adjust options based on command line.
	my $size = parse_size($opts{size});
	$TIME_ATTR = "atime" if ($opts{atime});
	$TIME_ATTR = "mtime" if ($opts{mtime});
	$TIME_ATTR = "ctime" if ($opts{ctime});
	$TIME_ATTR = "basename" if ($opts{basename});
	$TIME_ATTR = "pathname" if ($opts{pathname});
	
	# Collate file info. This fills in @FILES.
	find({ wanted => \&find_callback, no_chdir => 1 }, $dir);
	
	# Sort by mtime (or whatever was set in $TIME_ATTR)
	my @sorted_files = reverse sort by_time_attr @FILES;	# highest mtime first (oldest last)
	
	# Make a cut if you go above the limit.
	my ($keep_files, $cull_files) = split_files_after_limit($size, @sorted_files);
		
	print "Keeping ", scalar @$keep_files, " files:-\n" if ($opts{verbose});
	print_files(@$keep_files) if ($opts{verbose});
	
	if ($opts{move}) {
		print "\nMoving ", scalar @$cull_files, " files:-\n" if ($opts{verbose});
		print_files(@$cull_files) if ($opts{verbose});
		move_files(@$cull_files);
		
	} elsif ($opts{delete}) {
		print "\nDeleting ", scalar @$cull_files, " files:-\n" if ($opts{verbose});
		print_files(@$cull_files) if ($opts{verbose});
		delete_files(@$cull_files);
	
	} else {
		print "\nWould Cull ", scalar @$cull_files, " files:-\n" if ($opts{verbose});
		print_files(@$cull_files) if ($opts{verbose});

	}

}


sub find_callback
{
	# We want to use File::Find's no_chdir option, so we want to figure out the basename by ourselves.
	my $pathname = $File::Find::name;
	utf8::decode($pathname);
	my $basename = basename($pathname);
	
	# Don't match dotfiles.
	return if ($basename =~ /^\./);
	# We only care about files, not dirs.
	return unless (-f $pathname);
	
	# Collect stats.
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = lstat($pathname);
	push @FILES, {
				pathname => $pathname,
				basename => $basename,
				size => $size,
				atime => $atime,
				mtime => $mtime,
				ctime => $ctime,
			};
}


sub by_time_attr
{
	if ($TIME_ATTR eq 'basename' || $TIME_ATTR eq 'pathname') {
		$a->{$TIME_ATTR} cmp $b->{$TIME_ATTR};
	} else {
		$a->{$TIME_ATTR} <=> $b->{$TIME_ATTR};
	}
}


sub print_files
{
	foreach my $file (@_) {
		print $TIME_ATTR =~ /time/ ? scalar localtime($file->{$TIME_ATTR}) : "", 
		      " ", express_size($file->{size}), 
		      " $file->{pathname}\n";
	}
}


sub move_files
{
	foreach my $file (@_) {
		move($file->{pathname}, $opts{move});
	}
}


sub delete_files
{
	foreach my $file (@_) {
		unlink $file->{pathname};
	}
}


sub split_files_after_limit
{
	my ($limit, @files) = @_;
	my (@keep, @cull);
	my $running_total = 0;
	
	foreach my $file (@files) {
		$running_total += $file->{size};
		
		# If this file is the one that puts us over the limit, it and everything afterwards
		# goes in 'cull'.
		if ($running_total > $limit) {
			push @cull, $file;
		} else {
			push @keep, $file;
		}
	}
	
	return (\@keep, \@cull);
}


sub parse_size($)
{
	my ($str) = @_;
	if ($str =~ /^
	              (?<size>       \d+)
	              (?<quantifier> [kKmMgG]?)
	              $
	             /x) {
	   # Because I'm about to do more matching, I need to stash the named captures
	   # into real variables.
	   my $size = $+{size};
	   my $quantifier = $+{quantifier};
		$size *= 1024 if ($quantifier =~ /[kKmMgG]/);
		$size *= 1024 if ($quantifier =~ /[mMgG]/);
		$size *= 1024 if ($quantifier =~ /[gG]/);
		return $size;
	} else {
		die "Size parameter '$str' not recognised! Please use a 'k', 'm' or 'g' suffix!\n";
	}
}


sub express_size($)
{
	my ($bytes) = @_;
	if ($bytes > 1024**3) {
		return int($bytes / 1024**3) . "G";
	} elsif ($bytes > 1024**2) {
		return int($bytes / 1024**2) . "M";
	} elsif ($bytes > 1024**1) {
		return int($bytes / 1024**1) . "K";
	} else {
		return $bytes;
	}
}



help() if ($opts{help});
main();
