#!/usr/bin/perl -w

# This program is free software. It comes without any warranty, to the
# extent permitted by applicable law. You can redistribute it and/or
# modify it under the terms of the Do What The Fuck You Want To Public
# License, Version 2, as published by Sam Hocevar.
# See http://sam.zoy.org/wtfpl/COPYING for more details.


use Pod::Usage;
use Mail::IMAPClient;
use IO::Socket::SSL;;
use File::Spec::Functions qw /catfile/;
use Env qw /HOME/;
use strict;


=head1 NAME

imapurge.pl - prune your email accounts

=head1 SYNOPSIS

B<imapurge.pl>

=head1 DESCRIPTION

B<IMAPurge> cleans up your accounts from B<old> B<seen> and B<unflagged> emails
that are B<not drafts>. It connects on the IMAP servers via SSL on port 993.

=head1 CONFIGURATION

B<IMAPurge> reads its configuration from the file I<$HOME/.imapurge.rc>.
This file has to be the content of a Perl hash e.g.,

  account1 => {
     hostname => 'imap.example.com',
     username => 'username',
     password => '******',
     ignore   => [ 'folder1', 'folder2' ],
     only     => [ 'folder3', 'folder4' ],  
     oldest   => 90
  },
   account2 => {
     ...
  }


The fields I<hostname>, I<username>, and I<password> are required, while
I<ignore>, I<only>, and I<oldest> are optional.

If you wish to to filter away some folders, you can fill in the field
I<ignore>. If on the other hand you want to only clean up some folders (hence
ignore all the others), you can fill in the field I<only>. The default
behavior is to explore all the folders on the server.

By setting the field I<oldest>, you can also define a time limit (in
days) for each account; Seen and unflagged emails that are not drafts
and have been sent before the given value (for the server's time!) will
be deleted. Default value: 90.

=head1 AUTHOR

Copyright 2011 Guilhem Moulin. See the source for copying conditions.

=cut


if (@ARGV) {
    pod2usage(-exitstatus => 0, -verbose => 2) if $ARGV[0] eq '--man';
    pod2usage(2);
}

my $confile = catfile ($HOME, '.imapurge.rc');
die "Can't read `" .$confile. "'\n" unless -f $confile;
my %accounts = do $confile;
die "Error in `" .$confile. "'\n" if $@ || not %accounts;


# Remotely delete mails that have been sent >90 days ago
my $oldest = 90;



my $count = 0;
while (my ($account,$config) = each %accounts) {
    my $n = &prune ($config); 
    print $account, ": ", $n, "\n"; 
    $count += $n;
}
print "-----------\n";
print "Total: $count emails have been deleted.\n";


#######################################################################


# Prune the given account
sub prune {
    my $config = $_[0];

    # Create the SSL socket and login to the server
    my $socket = IO::Socket::SSL->new(
        PeerAddr  => $config->{hostname},
        PeerPort  => 993,
    ) or die "Can't create SSL socket: $@\n";

    my $client = Mail::IMAPClient->new(
        Socket   => $socket,
        User     => $config->{username},
        Password => $config->{password},
        SSL      => 1,
        Uid      => 1,
    ) or die "Can't login: $@\n";
    my $count = 0;

    # I'll delete the emails that have a date < $maxdate (on the server)
    my $maxdate = $oldest;
    $maxdate = $config->{oldest} if exists $config->{oldest};
    $maxdate *= 24 * 60 * 60; # Convert seconds to days
    $maxdate = $client->Rfc3501_date(time-$maxdate);
  
    # Browse in the folder list
    my @folders = $client->folders or die "Can't list folders: $@\n";
    foreach my $folder (@folders) {
        # Filter on the (manually set) 'ignore' & 'only' lists
        next if exists $config->{ignore}
                && grep {$_ eq $folder} @{$config->{ignore}};
        next if exists $config->{only}
                && not (grep {$_ eq $folder} @{$config->{only}});

        # Explore the folder
        if ($client->select($folder)) {
            # Search for the mail UIDs I'm gonna delete
            my @msgs = $client->search( \( 'SENTBEFORE', $maxdate
                                         , 'UNDRAFT'
                                         , 'UNFLAGGED'
                                         , 'SEEN' )
                                      );
            if (@msgs) {
                $count += $#msgs+1;
                my $del = $client->delete_message(\@msgs)
                    or die "Can't delete messages: $@\n";
                warn "  Folder `$folder': only $del/" .$#msgs+1
                    ."messages have been deleted.\n"
                    unless $del == $#msgs+1;
            }
            else {
                die "Can't search: $@\n" if $@;
            }
            # Unselect the folder & commit the changes on the server
            $client->close or die "Can't close: $@\n";
        }
    }

    # Logout
    $client->logout();
    die "Can't logout: $@\n" unless $client->IsUnconnected;
    return $count;
}