#!/usr/bin/perl

# vi: sw=4 ts=4

use strict;
use warnings;

use Getopt::Long;
use POSIX;

our $VERSION = 0.03;

my $server;
my $username;
my $password;
my $imappattern;
my $perlpattern;

# FIXME server, imappattern, & perlpattern values remain in ARGV
GetOptions('help|?' => \&Getopt::Long::HelpMessage,
	'server' => \$server,
	'username' => \$username,
	'password' => \$password,
	'imappattern' => \$imappattern,
	'perlpattern' => \$perlpattern);

$server = $server || shift || 'cgi.sfu.ca';
$imappattern = $imappattern || shift || '*';
$perlpattern = $perlpattern || shift || '^(?!.*\\.Archives\\.)';

# Use IMAP::Admin before Cyrus::IMAP::Admin
my $imap;
#if (eval {
	require IMAP::Admin;
#}) {
	$imap = IMAP::Admin->new(Server => $server,
		Login => $username,
		Password => $password);

	if ($imap->{Error}) {
		die "new: $imap->{Error}";
	}
#} elsif (eval {
#	require Cyrus::IMAP::Admin;
#}) {
#	$imap = Cyrus::IMAP::Admin->new($server);
#
#	# Connect to server & authenticate
#	if ($imap->error) {
#		die 'new: ' . $imap->error;
#	}
#
#	$imap->authenticate;
#	if ($imap->error) {
#		die 'authenticate: ' . $imap->error;
#	}
#}

# Get list of mailboxes for archiving
my @mailboxes = $imap->list($imappattern);
if ($imap->error) {
	die 'list: ' . $imap->error;
}

foreach my $reference (@mailboxes) {

	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 ($imap->list($newname));

		# Rename mailbox
		$imap->rename($oldname, $newname);
		if ($imap->error) {
			die 'rename: ' . $imap->error;
		}
	}
}

__END__

=head1 NAME

Archive IMAP Mailboxes -- periodically rename IMAP mailboxes so they don't grow too large

=head1 SYNOPSIS

arcimb [--server] server [--imappattern] imappattern [--perlpattern] perlpattern

=head1 OPTIONS

=over 8

=item B<--server>

IMAP server to connect.  Default: 'cgi.sfu.ca'

=item B<--imappattern>

IMAP pattern of mailboxes to archive.  Default: '*'

=item B<--perlpattern>

Perl pattern of mailboxes to archive.  Default: '^(?!.*\\.Archives\\.)'

=back

=head1 PREREQUISITES

IMAP::Admin|Cyrus::IMAP::Admin

Getopt::Long

POSIX

=head1 SCRIPT CATEGORIES

Mail