#! /usr/bin/perl -w

# vim: set sw=4 ts=4

use strict;
use Cyrus::IMAP::Admin;
use Getopt::Long;
use POSIX;

my $VERSION = 0.1;

my $server;
GetOptions('server:s' => \$server);
if (!$server) {
	$server = shift @ARGV;

	if (!$server) {
		$server = 'cgi.sfu.ca';
	}
}

my $imappattern;
GetOptions('imappattern:i' => \$imappattern);
if (!$imappattern) {
	$imappattern = shift @ARGV;

	if (!$imappattern) {
		$imappattern = '*';
	}
}

my $perlpattern;
#GetOptions('perlpattern:p' => \$perlpattern);
#if (!$perlpattern) {
#	$perlpattern = shift @ARGV;
#
#	if (!$perlpattern) {
		$perlpattern = '^(?!.*\\.Archives\\.)';
#	}
#}

my $connection = Cyrus::IMAP::Admin->new($server);

# Connect to server & authenticate
if ($connection->error) {
	print STDERR 'new: ', $connection->error;
} else {
	$connection->authenticate;
	if ($connection->error) {
		print STDERR 'authenticate: ', $connection->error;
	} else {

		# Get list of mailboxes for archiving.
		my @mailboxes = $connection->list($imappattern);
		if ($connection->error) {
			print STDERR 'list: ', $connection->error;
		} else {
			foreach my $reference (@mailboxes) {

				# $x is a reference to an array -
				# http://krom.meiring.org.uk/sheflug/mailarchive/2003/08/msg00056.html
				my ($oldname) = @$reference;
				if ($oldname =~ $perlpattern) {
					# TODO Add check for mailbox size

					# Find a unique new name for mailbox FIXME The test for a
					# mailbox' existence breaks on nonexistent mailboxes which
					# nonetheless have sub-mailboxes.  How will SquirrelMail
					# solve this?
					# http://s3.invisionfree.com/squirrelmail/index.php?s=2b484becef8805be39ce9e3dc27be936&showtopic=30
					my $i = 0;
					my $newname;
					do {
						$newname = "$oldname.Archives." . (strftime '%Y%m%d', localtime) . $i++;
					} while ($connection->list($newname));

					# Rename mailbox
					$connection->rename($oldname, $newname);
					if ($connection->error) {
						print STDERR 'rename: ', $connection->error;
					}
				}
			}
		}
	}
}

=head1 NAME

Archive IMAP Mailboxes - a perl script to periodically rename IMAP mailboxes so they don't grow too large

=head1 PREREQUISITES

Cyrus::IMAP::Admin
Getopt::Long
POSIX

=head1 SCRIPT CATEGORIES

Mail