#!/usr/bin/perl
#
# qmHandle
#
# Copyright(c) 1998 -> 2003 Michele Beltrame <mb@italpro.net>
#
# This program is distributed under the GNU GPL.
# For more information have a look at http://www.gnu.org

use strict;
use warnings;
use diagnostics;
use Text::ParseWords;

my $version = '1.2.1';

#################### USER CONFIGURATION BEGIN ####################

#####
# Set this to your qmail queue directory (be sure to include the final slash!)
my ($queue) = '/var/qmail/queue/';

#####
# If your system has got automated command to start/stop qmail, then
# enter them here.
# ### Be sure to uncomment only ONE of each variable declarations ###

# For instance, this is if you have DJB's daemontools
#my ($stopqmail) = '/usr/local/bin/svc -d /service/qmail-send';
#my ($startqmail) = '/usr/local/bin/svc -u /service/qmail-send';

# While this is if you have a Debian GNU/Linux with its qmail package
#my ($stopqmail) = '/etc/init.d/qmail stop';
#my ($startqmail) = '/etc/init.d/qmail start';

# GNU/Linux with /sbin/service
my ($stopqmail) = '/sbin/service qmail stop';
my ($startqmail) = '/sbin/service qmail start';

# If you don't have scripts, leave $stopqmail blank (the process will
# be hunted and killed by qmHandle):
#my ($stopqmail) = '';

# However, you still need to launch qmail in a way or the other. So,
# if you have a standard qmail 1.03 use this:
#my ($startqmail) = "csh -cf '/var/qmail/rc &'";

# While, if you have a standard qmail < 1.03 you should use this:
#my ($startqmail) = '/var/qmail/bin/qmail-start ./Mailbox splogger qmail &';

#####
# Enter here the system command which returns qmail PID. The following
# should work on most Unixes:
my ($pidcmd) = 'pidof qmail-send';

####################  USER CONFIGURATION END  ####################

# Print usage if no arguments
if ($#ARGV == -1) {
    &Usage();
}

# Get command line options

my $color = 0;
my $summary = 0;
my @actions = ();
my $dactions = 0;

foreach my $arg (@ARGV) {
  SWITCH: {
      $arg eq '-a' and do { push @actions, "SendMsgs()"; last SWITCH; };
      $arg eq '-l' and do { push @actions, "ListMsg('A')"; last SWITCH; };
      $arg eq '-R' and do { push @actions, "ListMsg('L')"; last SWITCH; };
      $arg eq '-L' and do { push @actions, "ListMsg('R')"; last SWITCH; };
      $arg eq '-N' and do { $summary = 1; last SWITCH; };
      $arg eq '-c' and do { $color = 1; last SWITCH; };
      $arg eq '-s' and do { push @actions, "Stats()"; last SWITCH; };
      $arg =~ /^-m(.+)/ and do { push @actions, "ViewMsg($1)"; last SWITCH; };
      $arg =~ /^-d(.+)/ and do { push @actions, "DelMsg($1)"; $dactions++; last SWITCH; };
      $arg =~ /^-S(.+)/ and do { push @actions, "DelMsgSubj(\"$1\")"; $dactions++; last SWITCH; };
      $arg =~ /^-T(.+)/ and do { push @actions, "DelMsgTo(\"$1\")"; $dactions++; last SWITCH; };
      $arg =~ /^-F(.+)/ and do { push @actions, "DelMsgFrom(\"$1\")"; $dactions++; last SWITCH; };
      $arg =~ /^-I(.+)/ and do { push @actions, "DelMsgIP(\"$1\")"; $dactions++; last SWITCH; };
      $arg eq '-D' and do { push @actions, "DelAll()"; $dactions++; last SWITCH; };
      $arg eq '-V' and do { push @actions, "Version()"; last SWITCH; };
      $arg eq '-tt' && do { push @actions, "&ListTT()"; last SWITCH; };

      Usage();
  }
}

# Set "global" variables
my ($norestart) = 0;

# Create a message list for local and remote queues
my (@queues) = ("remote", "local");
my (@msglist) = ();
my (%type) = ();

foreach my $currentqueue (@queues) {

    # Make list of messages each queue (thanks Franky Van Liedekerke)
    opendir(DIR,"${queue}$currentqueue");
    my (@dirlist) = grep !/\./, readdir DIR;
    closedir DIR;
    foreach my $dir (@dirlist) {
	opendir (SUBDIR,"${queue}${currentqueue}/$dir");
	my (@files) = grep !/\./, map "$dir/$_", readdir SUBDIR;
	foreach my $file (@files) {
	    push @msglist, "$file";
	    ($currentqueue eq "remote") ? ($type{"$file"} = 'R') : ($type{"$file"} = 'L');
	}
	closedir SUBDIR;
    }

}

# In case of deletion actions, stop qmail
if ($dactions) {
    stopQmail() or die "Could not stop qmail: $!";
}

# Execute actions    
foreach my $action(@actions) {
    eval "$action";
}

# In case of deletion actions, restart qmail
if ($dactions) {
    startQmail() or die "Could not stop qmail: $!";
}

# ##### SERVICE FUNCTIONS #####

# Stop qmail
sub stopQmail {
    my ($qmpid) = qmailPid();

    # If qmail is running, we stop it
    if ($qmpid != 0) {

	# If there is a system script available, we use it
	if ($stopqmail ne '') {

	    print "Calling system script to terminate qmail...\n";
	    if (system($stopqmail) > 0) {
		return 0;
	    }

	# Otherwise, we're killers!
	} else {
	    print "Terminating qmail (pid $qmpid)... this might take a while if qmail is working.\n";
	    kill 'TERM', $qmpid;
	    
	    while (qmailPid()){
		sleep 1;
	    }
	}

    # If it isn't, we don't. We also set a flag which assures we don't
    # restart it later either (the user might not want this)
    } else {
	print "Qmail isn't running... no need to stop it.\n";
	$norestart = 1;
    }

    return 1;
}

# Start qmail
sub startQmail {
    my ($qmpid) = qmailPid();

    # If qmail is running, why restart it?
    if ($qmpid != 0) {
	print "Qmail is already running again, so it won't be restarted.\n";

    # If it wasn't running before qmHandle was launched, it's better leave is this way
    } elsif ($norestart == 1) {
	print "Qmail wasn't running when qmHandle was started, so it won't be restarted.\n";

    # In any other case, we restart it
    } else {
	print "Restarting qmail... ";
	system($startqmail);
	print "done (hopefully).\n";
    }

    return 1;
}

# Returns the subject of a message
sub getSubject {
    my $msg = shift;
    my $msgsub;
    open (MSG, "${queue}mess/$msg") or die("cannot open message $msg");
    while (<MSG>) {
	if ( $_ =~ /^Subject: /) {
	    $msgsub = $';
	    chop ($msgsub);
	} elsif ( $_ eq "\n") {
	    last;
	}
    }
    close (MSG);
    return $msgsub;
}

# Check if message was received from IP and 
# return ip back if found
sub getIP {
    my $msg = shift;
    my $ip = shift;
    my $msgip;
    open (MSG, "${queue}mess/$msg") or die("cannot open message $msg");
    while (<MSG>) {
	if ( $_ =~ /^Received: .*($ip)/) {
	    $msgip = $1;
	} elsif ( $_ eq "\n") {
	    last;
	}
    }
    close (MSG);
    return $msgip;
}



# Returns the To: of a message
sub getTo {
    my $msg = shift;
    my $msgto;
    open (MSG, "${queue}mess/$msg") or die("cannot open message $msg");
    while (<MSG>) {
	if ( $_ =~ /^To: /) {
	    $msgto = $';
	    chop ($msgto);
	} elsif ( $_ eq "\n") {
	    last;
	}
    }
    close (MSG);
    return $msgto;
}

# Returns the From: of a message
sub getFrom {
    my $msg = shift;
    my $msgfrom;
    open (MSG, "${queue}mess/$msg") or die("cannot open message $msg");
    while (<MSG>) {
	if ( $_ =~ /^From: /) {
	    $msgfrom = $';
	    chop ($msgfrom);
	} elsif ( $_ eq "\n") {
	    last;
	}
    }
    close (MSG);
    return $msgfrom
}


# ##### MAIN FUNCTIONS #####

# Tries to send all queued messages now 
# This is achieved by sending an ALRM signal to qmail-send
sub SendMsgs {
    my ($qmpid) = qmailPid();

    # If qmail is running, we force sending of messages
    if ($qmpid != 0) {

	kill 'ALRM', $qmpid;

    } else {

	print "Qmail isn't running, can't send messages!\n";

    }
}


# Delete mesage if Received through ip
sub DelMsgIP {
    my $ip = shift;
    my $msgip;
    my $delnum = 0;

    print "Looking for messages Received through: $ip\n";

    # Search messages
    my ($ok) = 0;
    foreach my $msg (@msglist) {
	$msgip = getIP($msg,$ip);

	if ($msgip and $msgip =~ /$ip/) {
	    $ok = 1;
	    print "Deleting message: $msg\n";
	    unlink "${queue}mess/$msg";
	    unlink "${queue}info/$msg";
	    if ($type{$msg} eq 'R') {
		unlink "${queue}remote/$msg";
	    } else {
		unlink "${queue}local/$msg";
	    }
	    $delnum++;
	}

    }

    # If no messages are found, print a notice
    if ($ok == 0) {
	print "No messages Received through \"$ip\" found in the queue!\n";
    } else {
	print "$delnum messages deleted\n";
    }

}


# Display message list
# pass parameter of queue NOT to list! i.e. if you want remote only, pass L
# if you want local, pass R  if you want all pass anything else eg A
sub ListMsg {
    my ($q) = shift;
    my (%ret, %date, %from, %subj, %to, %cc, %fsize);
    
    if ($summary == 0) {

	foreach my $msg(@msglist) {

	    # Read return path
	    open (MSG, "${queue}info/$msg");
	    $ret{$msg} = <MSG>;
	    substr($ret{$msg}, 0, 1) = '';
	    chop ($ret{$msg});
	    close (MSG);
	    
	    # Get message (file) size
	    $fsize{$msg} = (stat("${queue}mess/$msg"))[7];
	    
	    # Read something from message header (sender, receiver, subject, date)
	    open (MSG, "${queue}mess/$msg");
	    while (<MSG>) {
		if ($_ =~ /^Date: /) {
		    $date{$msg} = $';
		    chop ($date{$msg});
		} elsif ( $_ =~ /^From: /) {
		    $from{$msg} = $';
		    chop ($from{$msg});
		} elsif ( $_ =~ /^Subject: /) {
		    $subj{$msg} = $';
		    chop ($subj{$msg});
		} elsif ( $_ =~ /^To: /) {
		    $to{$msg} = $';
		    chop ($to{$msg});
		} elsif ( $_ =~ /^Cc: /) {
		    $cc{$msg} = $';
		    chop ($cc{$msg});
		} elsif ( $_ eq "\n") {
		    last;
		}
	    }
	}

    }
    
    if ($color == 1) {

	foreach my $msg(@msglist) {
	    unless ($q eq $type{$msg})  {
		my ($dir, $rmsg) = split (/\//, $msg);
		print chr(27)."[01;34m$rmsg ($dir, $type{$msg})\n";
		if ($summary == 0) {
		    defined($ret{$msg})   and print "  \e[01;31mReturn-path\e[00m: $ret{$msg}\n";
		    defined($from{$msg})  and print "  \e[01;31mFrom\e[00m: $from{$msg}\n";
		    defined($to{$msg})    and print "  \e[01;31mTo\e[00m: $to{$msg}\n";
		    defined($cc{$msg})    and print "  \e[01;31mCc\e[00m: $cc{$msg}\n";
		    defined($subj{$msg})  and print "  \e[01;31mSubject\e[00m: $subj{$msg}\n";
		    defined($date{$msg})  and print "  \e[01;31mDate\e[00m: $date{$msg}\n";
		    defined($fsize{$msg}) and print "  \e[01;31mSize\e[00m: $fsize{$msg} bytes\n\n";
		}
	    }
	}

    } else {

	foreach my $msg(@msglist) {
	    unless ($q eq $type{$msg})  {
		my ($dir, $rmsg) = split (/\//, $msg);
		print "$rmsg ($dir, $type{$msg})\n";
		if ($summary == 0) {
		    defined($ret{$msg})   and print "  Return-path: $ret{$msg}\n";
		    defined($from{$msg})  and print "  From: $from{$msg}\n";
		    defined($to{$msg})    and print "  To: $to{$msg}\n";
		    defined($cc{$msg})    and print "  Cc: $cc{$msg}\n";
		    defined($subj{$msg})  and print "  Subject: $subj{$msg}\n";
		    defined($date{$msg})  and print "  Date: $date{$msg}\n";
		    defined($fsize{$msg}) and print "  Size: $fsize{$msg} bytes\n\n";
		}
	    }
	}

    }
    Stats();
}

sub ReadMessage {
    my $message = shift;
    my $filename = shift;
    my $headers = shift;

	# Read something from message header (sender, receiver, subject, date)
    open(MSG,$filename);
	while (<MSG>) {
	    if ($_ =~ /^Date: /i) {
	        chomp($headers->{$message}{'date'} = $');
	    } elsif ( $_ =~ /^From: /i) {
	        chomp($headers->{$message}{'from'} = $');
	    } elsif ( $_ =~ /^Subject: /i) {
	        chomp($headers->{$message}{'subject'} = $');
	    } elsif ( $_ =~ /^To: /i) {
	        chomp($headers->{$message}{'to'} = $');
	    } elsif ( $_ =~ /^Cc: /i) {
	        chomp($headers->{$message}{'cc'} = $');
	    } elsif ( $_ eq "\n") {
	        last;
	    }
	}
    close(MSG);
}

sub TopHash {
    # given a reference to a hash as the single argument
    # with numeric values in the hash, this function returns
    # a list of keys for the hash sorted in descending values
    my $hash = shift;
    # optional second argument provides the key to sort by
    my $key = shift||undef;

    if ( defined $key ) {
        return sort { $hash->{$b}{$key} <=> $hash->{$a}{$key} } keys %$hash;
    } else {
        return sort { $hash->{$b} <=> $hash->{$a} } keys %$hash;
    }
}

sub TopNHash {
    # returns only the top $n of TopHash
    my $n = shift;
    my $hash = shift;
    my $key = shift||undef;
    my $count = 0;
    return grep { $count++ < $n } TopHash($hash,$key);
} 

# Show the Top T{hree,en,wenty,hirty}
sub ListTT {
    &Stats();
    my %Stats = ();
    # the default is to show the top ten senders and recipients, and under
    # each to show the top three senders to or recipients of.
    my $top = shift || 10;
    my $next = shift || 3;

	foreach my $msg (@msglist) {
        my %ret;
        my %fsize;
        my %headers;

	    # Read return path
	    open (MSG, "${queue}info/$msg");
	    $ret{$msg} = <MSG>;
	    substr($ret{$msg}, 0, 1) = '';
	    chop ($ret{$msg});
	    close (MSG);
	    
	    # Get message (file) size
	    $fsize{$msg} = (stat("${queue}mess/$msg"))[7];
	
        # read headers into %headers   
	    ReadMessage($msg,"${queue}mess/$msg",\%headers);
   
    
        my @to = &parse_line(", *",'false',
            join(", ",
                grep { defined } ($headers{$msg}{'cc'},$headers{$msg}{'to'})
            ));
        my @from = &parse_line(", *",'false',$headers{$msg}{'from'});
        foreach my $to ( @to ) {
            foreach my $from ( @from ) {
                $Stats{'to'}{$to}{'from'}{$from}++;
            }
            $Stats{'to'}{$to}{'sum'}++;
        } 
        foreach my $from ( @from ) {
            foreach my $to ( @to ) {
                $Stats{'from'}{$from}{'to'}{$to}++;
            }
            $Stats{'from'}{$from}{'sum'}++;
        }
    }


    my @top_senders = TopNHash( $top, \%{$Stats{'from'}}, "sum" );
    my @top_receivers = TopNHash( $top, \%{$Stats{'to'}}, "sum" );

    printf "%8s%s\n", " ", "Top $top Senders";
    foreach my $sender ( @top_senders ) {
        printf "%8s%4d %s\n", " ", $Stats{'from'}{$sender}{'sum'}, $sender;
        foreach my $recip ( TopNHash( $next, \%{$Stats{'from'}{$sender}{'to'}} ) ) {
            printf "%16s%4d To: %s\n", " ",
                $Stats{'from'}{$sender}{'to'}{$recip},
                $recip;
        }
    }    
    
    printf "%8s%s\n", " ", "Top $top Recipients";
    my $count = 0;
    foreach my $recip ( @top_receivers ) {
        printf "%8s%4d %s\n", " ", $Stats{'to'}{$recip}{'sum'}, $recip;
        foreach my $sender ( TopNHash( $next, \%{$Stats{'to'}{$recip}{'from'}} ) ) {
            printf "%16s%4d From: %s\n", " ",
                $Stats{'to'}{$recip}{'from'}{$sender},
                $sender;
        }
        $count++;
        last if $count > $top;
    }

}

# View a message in the queue
sub ViewMsg {
    my ($rmsg) = shift;
    
    unless ($rmsg =~ /^\d+$/) {
	
	print "$rmsg is not a valid message number!\n";
	
    } else {

	# Search message
	my ($ok) = 0;
	foreach my $msg(@msglist) {
	    if ($msg =~ /\/$rmsg$/) {
		$ok = 1;
		print "\n --------------\nMESSAGE NUMBER $rmsg \n --------------\n"; 
		open (MSG, "${queue}mess/$msg");
		while (<MSG>) {
		    print $_;
		}
		close (MSG);
		last;
	    }
	}
	
	# If the message isn't found, print a notice
	if ($ok == 0) {
	    print "Message $rmsg not found in the queue!\n";
	    
	}
    }
    
}

# Delete a message in the queue
sub DelMsg {
    my ($rmsg) = shift;
    
    unless ($rmsg =~ /^\d+$/) {
	
	print "$rmsg is not a valid message number!\n";
	
    } else {
	
	# Search message
	my ($ok) = 0;
	foreach my $msg(@msglist) {
	    if ($msg =~ /\/$rmsg$/) {
		$ok = 1;
		print "Deleting message $msg...\n";
		unlink "${queue}mess/$msg";
		unlink "${queue}info/$msg";
		if ($type{$msg} eq 'R') {
		    unlink "${queue}remote/$msg";
		} else {
		    unlink "${queue}local/$msg";
		}
		last;
	    }
	}
	
	# If the message isn't found, print a notice
	if ($ok == 0) {
	    print "Message $rmsg not found in the queue!\n";
	}

    }
}

sub DelMsgSubj {
    my $subject = shift;
    my $msgsub;
    my $delnum = 0;

    print "Looking for messages with Subject: $subject\n";

    # Search messages
    my ($ok) = 0;
    foreach my $msg (@msglist) {
	$msgsub = getSubject($msg);

	if ($msgsub and $msgsub =~ /$subject/) {
	    $ok = 1;
	    print "Deleting message: $msg\n";
	    unlink "${queue}mess/$msg";
	    unlink "${queue}info/$msg";
	    if ($type{$msg} eq 'R') {
		unlink "${queue}remote/$msg";
	    } else {
		unlink "${queue}local/$msg";
	    }
	    $delnum++;
	}

    }

    # If no messages are found, print a notice
    if ($ok == 0) {
	print "No messages matching Subject \"$subject\" found in the queue!\n";
    } else {
	print "$delnum messages deleted\n";
    }

}

sub DelMsgTo {
    my $to = shift;
    my $msgto;
    my $delnum = 0;

    print "Looking for messages with To: $to\n";

    # Search messages
    my ($ok) = 0;
    foreach my $msg (@msglist) {
	$msgto = getTo($msg);

	if ($msgto and $msgto =~ /$to/) {
	    $ok = 1;
	    print "Deleting message: $msg\n";
	    unlink "${queue}mess/$msg";
	    unlink "${queue}info/$msg";
	    if ($type{$msg} eq 'R') {
		unlink "${queue}remote/$msg";
	    } else {
		unlink "${queue}local/$msg";
	    }
	    $delnum++;
	}

    }

    # If no messages are found, print a notice
    if ($ok == 0) {
	print "No messages matching To: \"$to\" found in the queue!\n";
    } else {
	print "$delnum messages deleted\n";
    }

}

sub DelMsgFrom {
    my $from = shift;
    my $msgfrom;
    my $delnum = 0;

    print "Looking for messages with From: $from\n";

    # Search messages
    my ($ok) = 0;
    foreach my $msg (@msglist) {
	$msgfrom = getFrom($msg);

	if ($msgfrom and $msgfrom =~ /$from/) {
	    $ok = 1;
	    print "Deleting message: $msg\n";
	    unlink "${queue}mess/$msg";
	    unlink "${queue}info/$msg";
	    if ($type{$msg} eq 'R') {
		unlink "${queue}remote/$msg";
	    } else {
		unlink "${queue}local/$msg";
	    }
	    $delnum++;
	}

    }

    # If no messages are found, print a notice
    if ($ok == 0) {
	print "No messages matching From: \"$from\" found in the queue!\n";
    } else {
	print "$delnum messages deleted\n";
    }

}


# Delete all messages in the queue (thanks Kasper Holtze)
sub DelAll {
    my ($rmsg) = shift;

    # Search messages
    my ($ok) = 0;
    foreach my $msg (@msglist) {
	$ok = 1;
	print "Deleting message: $msg\n";
	unlink "${queue}mess/$msg";
	unlink "${queue}info/$msg";
	if ($type{$msg} eq 'R') {
	    unlink "${queue}remote/$msg";
	} else {
	    unlink "${queue}local/$msg";
	}
    }

    # If no messages are found, print a notice
    if ($ok == 0) {
	print "No messages found in the queue!\n";
    }

}

# Make statistics
sub Stats {
    my ($l) = 0;
    my ($r) = 0;

    foreach my $msg(@msglist) {
	if ($type{$msg} eq 'R') { $r++; }
	else { $l++; }
    }

    if ($color == 1) {
	print chr(27)."[01;31mMessages in local queue".chr(27)."[00m: $l\n";
	print chr(27)."[01;31mMessages in remote queue".chr(27)."[00m: $r\n";
    } else {
	print "Messages in local queue: $l\n";
	print "Messages in remote queue: $r\n";
  }
}

# Retrieve pid of qmail-send
sub qmailPid {
    my $qmpid = `$pidcmd`;
    chomp ($qmpid);
    if ($qmpid =~ /^\d+$/) { return $qmpid; }
    return 0;
}

# Print help
sub Usage {
    print "qmHandle v$version\n";
    print "Copyright 1998-2003 Michele Beltrame\n";
    print "Modified by Stephane aka Kermit\n\n";

    print "Available parameters:\n";
    print "  -a     : try to send queued messages now (qmail must be running)\n";
    print "  -l     : list message queues\n";
    print "  -L     : list local message queue\n";
    print "  -R     : list remote message queue\n";
    print "  -s     : show some statistics\n";
    print "  -mN    : display message number N\n";
    print "  -dN    : delete message number N\n";
    print "  -Stext : delete all messages that have/contain text as Subject\n";
    print "  -Taddress : delete all messages that have/contain address in To:\n";
    print "  -Faddress : delete all messages that have/contain address in From:\n";
    print "  -Iip   : delete all messages Received through ip\n";

    print "  -D     : delete all messages in the queue (local and remote)\n";
    print "  -V     : print program version\n";
    print "  -tt    : display top ten lists\n";
    print "\n";
    print "Additional (optional) parameters:\n";
    print "  -c     : display colored output\n";
    print "  -N     : list message numbers only\n";
    print "           (to be used either with -l, -L or -R)\n";
    print "\n";
    print "You can view/delete multiple message i.e. -d123 -v456 -d567\n\n";
    exit;
}

# Print help
sub Version {
    print "qmHandle v$version\n";
}