#!/usr/bin/perl

#  -F option requested by domineaux - 2006-05-19

use strict;
use Date::Manip;
use Getopt::Std;
use Sys::Hostname;

sub HELP_MESSAGE {

    die <<EOF;

USAGE: $0 [-d time_spec] [-e] [-o] [-n] [-z] [-r number] [-H] [-h] \\
          [-F] [-D domain1,domain2,...,domainN]

-d time_spec: Delete messages that have been around 
              since this date or earlier.  Date
              spec must be one that Date::Manip
              recognizes.

          -e: Delete messages in 'ERR' state.

          -n: Don't actually delete messages, just
              show what would be deleted.

          -o: Delete 'orphaned' transcript or data
              files (no queue file present).

          -z: Delete zero-byte queue messages or 
              zero-byte transcript/data files that have
              no queue file associated with them.

   -r number: Delete messages that have failed to
              be delivered in 'number' or more
              retries.

          -H: Hot clean queues (do not shut down sendmail while
              cleaning): USE WITH CAUTION
          -D: Instead of operating across all domains, just clean the queues
              for the specified domain (separate multiple domains using
              comma)
          -F: If stopping sendmail (no -H), don't worry if sendmail init.d
              stop script throws errors - has no effect if -H is used.
          -h: This screen.

Examples:

#  Delete messages that have been in the queue for 5 or more days
$0 -d '5 days ago'

#  Delete all messages in error state or that failed delivery 15 or more times
$0 -e -r 15

#  Delete zero-byte queue messages and messages in error state
$0 -z -e

#  Hot clean example.com and my.example.com of messages more than 3 days old
$0 -H -d '4 days ago' -D example.com,my.example.com

# Delete orphaned transcript / data files
$0 -o

EOF

}

my %opt;

getopts("enozHhFD:d:r:", \%opt) || HELP_MESSAGE();

HELP_MESSAGE() if $opt{'h'};

HELP_MESSAGE() unless scalar(keys %opt) > 0;

my %DOMAINS = ();

if ($opt{'D'}) {

    my @domains = split(',', $opt{'D'});

    my $me = Sys::Hostname::hostname();

    for my $domain (@domains) {
        next if $domain eq $me;
        unless (-d "/home/virtual/$domain/var/") {
            die "Invalid domain name $domain specified!";
        }
    }

    %DOMAINS = map {$_ => 1} @domains;

}

my $INT = 0;

my $TIME = -1;

if ($opt{'d'}) {
    $TIME = UnixDate($opt{'d'}, "%s");
    die "Invalid time spec $opt{'d'}!\n" unless $TIME;
    if ($TIME > time()) {
       die "$opt{d} is in the future: " . 
           scalar(localtime($TIME)) . "\n";
    }

    $INT = abs(time() - $TIME);
}

my $cmd = "/usr/local/sbin/vmqinfo -v -m ";

if ($opt{'D'}) {
    $cmd .= join(' ', keys %DOMAINS);
}

open(VMQ, "$cmd |")
    || die "Can't open pipe to read from vmqinfo: $!\n";

my $domain;

my @to_delete;

while(<VMQ>) {

    my @f = split(';', $_);

    if ($f[0] ne 'file') {
        $domain = $f[0];
        next;
    }

    if (scalar(keys(%DOMAINS)) > 0) {
        unless (exists $DOMAINS{$domain}) {
            next;
        }
    }

    my $queue_id = $f[1];
    my $age = $f[-1];
    my $tries = $f[2];

    if ($opt{'e'} && ($tries eq 'ERR')) {
        print "$domain: $queue_id in ERR state.\n";
        push(@to_delete, [$queue_id, $domain]);
    } 

    if ($opt{'o'} && ($tries eq 'NQF')) {
        print "$domain: $queue_id is an orphan.\n";
        push(@to_delete, [$queue_id, $domain]);
    } 

    if ($opt{'z'} && is_zero_size($queue_id, $domain)) {
        print "$domain: $queue_id is 0 bytes.\n";
        push(@to_delete, [$queue_id, $domain]);
    } 

    if ($opt{'d'} && ($age >= $INT)) {
        printf "%s %s delivery started on or before %s\n",
               "$domain:", $queue_id, UnixDate($opt{'d'}, "%m/%d %H:%M %p");
        push(@to_delete, [$queue_id, $domain]);
    } 

    if ($opt{'r'} && ($tries >= $opt{'r'})) {
        print "$domain: $queue_id failed delivery >= " .
              "$opt{'r'} times.\n";
        push(@to_delete, [$queue_id, $domain]);
    }

}

close(VMQ);

if ((! $opt{'n'}) && @to_delete) {

    print "Deleting " . scalar(@to_delete) . " message IDs: \n";

    if (! $opt{'H'}) {
        print "    * Stopping sendmail";
        my $ret = system("/sbin/service sendmail stop >/dev/null 2>&1");
        my $err = $!;

        unless ( $opt{'F'}) {
            die "Can't stop sendmail: $err\n" if $ret;
        }

        print "    [OK]\n";
    }

    print "    * Deleting files   ";
    for my $chosen (@to_delete) {
        delete_message(@$chosen);
    }
    print "    [OK]\n";

    if (! $opt{'H'}) {
        print "    * Starting sendmail";
        system("/sbin/service sendmail start >/dev/null 2>&1")
            && die "Can't start sendmail: $!\n";
        print "    [OK]\n";
    }

}

exit 0;

##########
#  SUBS  #
##########

sub make_file_glob {

    my $pat = shift;
    my $domain = shift;

    $pat =~ s/^..//;

    my @files = ();

    if ($domain eq Sys::Hostname::hostname()) {
        @files = glob("/var/spool/mqueue/*${pat}");
    } elsif ($domain eq 'outgoing-mail') {
        @files = glob("/home/virtual/FILESYSTEMTEMPLATE" .  
                      "/services/sendmail/mqueue.scanned/*${pat}");
    } else {
        @files = (
            glob("/home/virtual/$domain/var/spool/mqueue/*${pat}"),
            glob("/home/virtual/$domain/var/spool/mqueue.site/*${pat}")
        );
     
    }

    return @files;

}

sub is_zero_size {

    my $queue_id = shift;
    my $domain = shift;

    my @files = make_file_glob($queue_id, $domain);

    for my $file (@files) {
        if ($file =~ m#/[qQdD]f\w+$# && -z $file) {
            return 1;
        }
    }

    return 0;
     
}

sub delete_message {

    my $queue_id = shift;
    my $domain = shift;

    my @files = make_file_glob($queue_id, $domain);

    unlink(@files);

}