MailArchiveScript
From Hinterlands
An automatic email archiving script
I get a lot of email. Much of that comes from the various mailing lists I am on for various projects and LUGs that I'm involved with. I also like to keep mail around for later reference as searching my IMAP folder is generally easier than searching mailman archives online. I structure my mailing list mail and mail archives like this:
- INBOX
- lists
- foolist
- otherlist
- thislist
- thatlist
- Archive
- 2009
- foolist
- otherlist
- thislist
- thatlist
- 2010
- foolist
- otherlist
- thislist
- thatlist
- 2009
- lists
I thought it would be useful to write a script to automatically handle transferring mail from the main list folder into the Archive folder. Doing so manually is a bit tedious given the number of lists I have to deal with. Here's a bit of perl that does just this.
#!/usr/bin/perl
use strict;
use warnings;
use Mail::IMAPClient;
use IO::File;
use IO::Socket::SSL;
use DateTime;
use DateTime::Format::Mail;
my $imap = Mail::IMAPClient->new(
Server=> 'localhost',
User => '<username>',
Password => '<password>',
Authmechanism => 'LOGIN',
Socket => IO::Socket::SSL->new(
Proto => 'tcp',
PeerAddr => 'localhost',
PeerPort => 993,
),
);
if (!defined($imap)) { die "IMAP Login Failed"; }
my $sourcefolder="INBOX.lists.";
my $archivefolder="Archive";
my $archivedays=30;
my @folders = $imap->folders;
@folders = grep /^$sourcefolder/,@folders;
foreach my $folder (@folders){
$imap->expunge;
print "$folder: ";
$imap->select($folder);
my @messages=$imap->search('ALL');
print scalar @messages . "\n";
foreach my $i (@messages){
my $msgdate = $imap->get_header($i,"Date");
$msgdate=~s/\(.*\)//;
$msgdate=~s/\s+/ /g;
my $dtfm=DateTime::Format::Mail->new->loose;
my $msgdatetime = $dtfm->parse_datetime($msgdate);
my $year=$msgdatetime->year;
my $destfolder=$folder;
$destfolder=~s/.*\.//;
$destfolder="$archivefolder.$year.$destfolder";
if (!$imap->exists($destfolder)) {
$imap->create($destfolder);
$imap->subscribe($destfolder);
}
if ($msgdatetime < DateTime->now->subtract( days => $archivedays ) ) {
$imap->move($destfolder, $i) || die "Could not move: $@\n";
}
}
$imap->expunge;
}
You can download this script here. Hope it's of use to someone.
Thanks to James Laver, Peter Corlett and Adrian Lai who all helped me understand the DateTime module better.
