#!/usr/bin/perl

# vi: sw=4 ts=4

use strict;
use warnings;

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

our $VERSION = 0.02;

my $server;
my $imappattern;
my $perlpattern;

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

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

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

# TODO Support IMAP::Admin.  It must use Authen::SASL first
#if (exists $INC{'IMAP/Admin.pm'}) {
#	$imap = 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

Cyrus::IMAP::Admin

Getopt::Long

POSIX

=head1 SCRIPT CATEGORIES

Mail