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