path: root/archiveIMAP.pl

#!/usr/bin/perl

use strict;
use warnings;
use Mail::IMAPClient;
use IO::Socket::SSL;
use Data::Dumper;
use DateTime;
use DateTime::Format::Strptime;
use Config::IniFiles;

# possible values are currently -- zimbra, localhost, pobox
my $account = "localhost";

# How many months before today the cut date should be?
my $howManyMonths = 3;
my $debug = 0;

# get configuration for the account
my $conf = Config::IniFiles->new( -file => "/home/matej/.bugzillarc");
die "No configuration for account $account" unless $conf->SectionExists($account);
my $hostname = $conf->val($account,'host');
my $login = $conf->val($account,'name');
my $password = $conf->val($account,'password');
my $ssl= $conf->val($account,'ssl');

sub getTargetFolder {
	my $source = shift;
	my $year = shift;
	
	$source =~ s/^\/*(.*)\/*$/$1/;
	return "/INBOX/Archiv/" . $year . '/' . $source; 
}

# makes sure that the folder including its parents
# RFC2060 says in 6.3.3 that server SHOULD create
# parents, so just to be sure if it doesn't.
sub assureFolder {
	my $imaphandle = shift;
	my $fullfoldername = shift;
	
	if ($imaphandle->exists($fullfoldername)) {
		return 1;
	}
	
}

our $Strp = new DateTime::Format::Strptime(
	pattern     => '%a, %d %b %Y %H:%M:%S %z'
);
our $StrpNoTZ = new DateTime::Format::Strptime(
	pattern     => '%a, %d %b %Y %H:%M:%S'
);

sub getMessageYear {
	my $msgStr = shift;
	my $msgDt = $Strp->parse_datetime($msgStr);

	if (!$msgDt) {
			$msgDt = $StrpNoTZ->parse_datetime($msgStr); 
	}
	if (!$msgDt) {
		print "Date EMPTY.\n";
		return ""; # TODO: message without Date:
				   # not sure what to do about it
		      	   # Currently just do nothing and
		      	   # return empty string.
		}
	my $year = $msgDt->year;
	if ($debug) {
	    print "\$msgStr = $msgStr, \$msgDt = $msgDt, year = $year\n";
	}
		
	return $year;
}

my $imap = Mail::IMAPClient->new();
if ($ssl) {
	my $sslSocket=IO::Socket::SSL->new("$hostname:imaps");
	die ("Error connecting - $@") unless defined $sslSocket;
	$sslSocket->autoflush(1);
	
	$imap = Mail::IMAPClient->new(
		Server => $hostname,
		Socket => $sslSocket,
		User => $login,
		Debug => $debug,
		Password => $password,
		UID => 1
	) or die "Cannot connect to localhost as matej: $@";
} else {
	$imap = Mail::IMAPClient->new(
		Server => $hostname,
		User => $login,
		Debug => $debug,
		Password => $password,
		UID => 1
	) or die "Cannot connect to localhost as matej: $@";	
}

my $cutDate = DateTime->now();
$cutDate->add( months => -$howManyMonths );

my @sourceFolders = grep(!/^INBOX\/Archiv/,$imap->folders());
my %targetedMessages;
my ($msgYear,$msgDateStr,$targetFolder);

foreach my $folder (@sourceFolders) {
	$imap->select($folder);
	 die "Cannot select folder $folder\n" if $@;
	my @msgsProc = $imap->search(" UNDELETED BEFORE " . $cutDate->strftime("%d-%b-%Y"));
	if ($#msgsProc > 0) {
		print "Move $#msgsProc in $folder.\n";
		foreach my $msg (@msgsProc) {
			$msgYear = getMessageYear($imap->date($msg));
			if ($msgYear !~ /^\s*$/) {
				$targetFolder = getTargetFolder($folder,$msgYear);
				if ($debug) {
					print "Move message $msg from the folder $folder to $targetFolder.\n";
				}
				push ( @{ $targetedMessages{$folder} } , $msg); 
			}
		}
	}
	foreach my $tFolder (keys %targetedMessages) {
		# FIXME: check the situation when the parent folder(s) don't exist
		# what about different folder separators? (i.e., can we put
		# "Archiv/2007/Pratele/PCF" as an argument of $imap->create?)
		# RFC says (in 6.3.3) that server SHOULD create parent folders
		# 
		if (!($imap->exists($tFolder))) {
			$imap->create($tFolder)
	        	or die "Could not create $tFolder: $@\n";
		}
		$imap->move($tFolder,$targetedMessages{$tFolder});
	}
} 
$imap->close();