use strict;

#!/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