#!perl
# © 2006,2007,2016 Heiko Schlittermann <hs@schlittermann.de>
# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)

use constant USAGE => <<'#';

Usage: !ME! --insert item [delay [db]]	# insert an item
       !ME! --remove item               # remove an item
       !ME! --list [db]			# list all items
       !ME! --stat [db* ...]		# print short statistic
       !ME! --clean [days [db* ...]]	# remove items not used since <days> days
       !ME! --purge [days [db* ...]]	# remove items older than <days> days
       !ME! --dbs [db* ...]		# list data base(s)

       db  -- single name of database
       db* -- glob pattern of database

       If the data base name doesn't doesn't start with "./" or "/"
       it is considered to be realtiv to exim_spool_dir/grey/.

#

use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use File::Temp qw/tmpfile/;
use constant ME => basename $0;
use FindBin qw/$Bin/;
use POSIX qw/strftime mktime/;
use if $ENV{DEBUG} => 'Smart::Comments';

use Exim::Grey qw(:all);

my  $VERSION = '$Id$';

my $opt_list;
my $opt_stats;
my $opt_insert;
my $opt_help;
my $opt_clean;
my $opt_purge;
my $opt_dbs;
my $opt_remove;

sub getDBs(@);
sub iterate(\%$);

MAIN: {

    GetOptions(
        "list!"   => \$opt_list,
        "insert!" => \$opt_insert,
	"remove!" => \$opt_remove,
        "stats!"  => \$opt_stats,
        "clean!"  => \$opt_clean,
        "purge!"  => \$opt_purge,
        "dbs!"    => \$opt_dbs,
        "help!"   => \$opt_help,
    ) or die ME . ": Bad usage, try " . ME . " --help.\n";

    if ($opt_help) {
        ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg;
        print;
        exit 0;
    }

    if ($opt_list) {
        foreach (@ARGV = getDBs(@ARGV)) {
            my %h;
            my $db = connectDB(\%h, $_);
            print "# $db\n";
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c, $flag) = @_;
                    printf "$item: $v0 $v1 $c (%s %s)%s\n",
                      strftime("%FT%T", localtime($v0)),
                      strftime("%FT%T", localtime($v1)),
		      $flag ? " $flag" : "";
                }
            );
            print "\n" if @ARGV;
        }
        exit 0;
    }

    if ($opt_stats) {
        foreach (@ARGV = getDBs(@ARGV)) {
            my %h;
            my $db = connectDB(\%h, $_);

            my ($seen, $returned, $oldest_c, $oldest_u, $auto);
            $seen     = $returned = 0;
            $oldest_c = $oldest_u = time();
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c, $flags) = @_;
		    if ($flags//'' eq 'auto') {
			++$auto;
			return;
		    }
		    ++$seen;
		    ++$returned if $v0 != $v1;    # soon it can be $c
		    $oldest_c = $v0 if $v0 < $oldest_c;
		    $oldest_u = $v1 if $v1 < $oldest_u;
		    return;
                }
            );

            $_ = <<__;
 	     date: %s
 	       db: $db (ls: %.1f MB / du: %.1f MB)
 	    total: $seen (100%%)
         returned: %*d (%3d%%)
     not returned: %*d (%3d%%)
auto white listed: %*d
 oldest (created): %.1f days (%s)
    oldest (used): %.1f days (%s)
__
            printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
              ((stat $db)[12] * 512) / (1024 * 1024), 
              length($seen), $returned,	int(0.5 + 100 * ($returned / $seen)),                 # returned
              length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned
	      length($seen), $auto,							      # auto white
              ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
              ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
            print "\n" if @ARGV;

        }
        exit 0;
    }

    if ($opt_clean or $opt_purge) {

        my $cut = time() - (86400 * (@ARGV ? shift: 7));
        foreach (getDBs(@ARGV)) {
            my %h;
            my $tmp = tmpfile();
            my $db = connectDB(\%h, $_);
            iterate(
                %h,
                sub {
                    my ($item, $v0, $v1, $c) = @_;
                    my $rv = defined $opt_purge ? \$v0 : \$v1;
                    print $tmp "$item\0" if $$rv <= $cut;
                }
            );

            seek($tmp, 0, 0) or die "Can't seek tmpfile";

            $/ = "\0";
            delete $h{$_} while <$tmp>;
            printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";

            close($tmp);

        }
        exit 0;
    }

    if ($opt_dbs) {
        print join("\n", getDBs(@ARGV)), "\n";
        exit 0;
    }

    if ($opt_insert) {
        print unseen(@ARGV);
        exit 0;
    }

    if ($opt_remove) {
	my %default = getDefault();
	my $item = shift;
	my $db = shift // $default{db};

	my $key = "$item\0";

	connectDB(\my %h, $db);
	if (not exists $h{$key}) {
	    warn "$0: key `$key' not found\n";
	}
	else {
	    $_ = $h{$key};	# delete from tied hashes
	    delete $h{$key};	# doesn't return anything always
	    chop;
	    print "$key: $_\n";
	}
	exit 0;
    }
}

sub getDBs(@) {
    grep { !/\.lock$/ } grep { -f -s }
      map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
}

# Helper to iterate over our hash and call the passed
# "callback" function (item, v0, v1, count, flags)
sub iterate(\%$) {
    my ($hash, $sub) = @_;
    while (my ($k, $v) = each %$hash) {
        chop($k, $v);
### $k
### $v
        &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]);    # 0 for filling
    }
}

# vim:ft=perl aw sts=4 sw=4:
