source: trunk/athena/bin/mitmailutils/mitmailmove.pl @ 24300

#!/usr/bin/perl -w

# $Id: mitmailmove.pl,v 1.3 2004-08-31 16:00:16 rbasch Exp $

# Move or copy messages between IMAP folders.

use strict;
use warnings FATAL => 'all';
use Cyrus::IMAP;
use Getopt::Long;

sub usage(;$);
sub send_command($);
sub fetch_callback(@);
sub close_and_errorout($);
sub close_connection();
sub errorout($);

my $prog = $0;
my $copy = ($prog =~ m/copy$/o);

sub usage(;$) {
    print STDERR "$prog: $_[0]\n" if ($_[0] && $_[0] ne "help");
    print STDERR <<EOF;
Usage: $prog [<options>] <message-id> [...] <target-mailbox>
  Options:
    --by-uid               specify message UIDs instead of sequence numbers
    --debug                turn on debugging
    --help                 print this usage information
    --host=<name>          query host <name> instead of default POBOX server
    --mailbox=<name>       examine mailbox <name> instead of INBOX
    --no-create            do not create the target mailbox automatically
EOF
    exit 1;
}

# Parse the command line arguments.
use vars qw($opt_by_uid $opt_debug $opt_host $opt_mailbox $opt_no_create);

GetOptions("by-uid",
           "debug",
           "help" => \&usage,
           "host=s",
           "mailbox=s",
           "no-create") || usage;

usage "Please specify a message number and target mailbox" if @ARGV < 2;
my $target = pop @ARGV;

# Check the validity of message ID arguments.
# The ID can be a number or '*', and we accept a range specification,
# of the form 'n:m'.
foreach (@ARGV) {
    errorout "Invalid message specification $_"
        unless (m/^(?:\d+|\*)(?::(?:\d+|\*))?$/o);
}

$opt_mailbox = 'INBOX' unless $opt_mailbox;

my $username = $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] ||
    errorout "Cannot determine user name";

unless ($opt_host) {
    $opt_host = (gethostbyname("$username.mail.mit.edu"))[0];
    errorout "Cannot find Post Office server for $username" unless $opt_host;
}
errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $opt_host =~ /EXCHANGE/;

# Connect to the IMAP server, and authenticate.
my $client = Cyrus::IMAP->new($opt_host) ||
    errorout "Cannot connect to IMAP server on $opt_host";
$client->authenticate(-authz => $username, -maxssf => 0) ||
    close_and_errorout "Cannot authenticate to $opt_host";

# Select (or examine, if copying only) the mailbox.
my $select_cmd = ($copy ? 'EXAMINE' : 'SELECT');
send_command "$select_cmd \"$opt_mailbox\"";

# Use the correct forms of the COPY and STORE commands, depending on
# whether we are operating on UIDs, or sequence numbers.
my $store_cmd;
my $copy_cmd;
if ($opt_by_uid) {
    $copy_cmd = 'UID COPY';
    $store_cmd = 'UID STORE';
} else {
    $copy_cmd = 'COPY';
    $store_cmd = 'STORE';
}
    
# If we are doing a "move" operation, we will execute a STORE command
# following the copy to set the message's Deleted flag.  Add a callback
# for the FETCH response generated by the STORE.
my $cb_numbered = Cyrus::IMAP::CALLBACK_NUMBERED;
unless ($copy) {
    $client->addcallback({-trigger => 'FETCH', -flags => $cb_numbered,
                          -callback => \&fetch_callback});
}

# Copy each given message ID to the target mailbox, and, if doing a
# "move", mark the source message(s) for deletion.
my $exitcode = 0;
foreach (@ARGV) {
    my ($status, $text) = send_command "$copy_cmd $_ \"$target\"";
    if ($status ne 'OK') {
        if ($text =~ m/\bTRYCREATE\b/io) {
            close_and_errorout "Mailbox $target does not exist"
                if $opt_no_create;
            print "Creating $target\n" if $opt_debug;
            # send_command will error out if either the CREATE fails.
            send_command "CREATE \"$target\"";
            ($status, $text) = send_command "$copy_cmd $_ \"$target\"";
        }
        if ($status ne 'OK') {
            print STDERR "IMAP error copying $_ to $target: $text\n";
            $exitcode = 2;
            next;
        }
    }
    send_command "$store_cmd $_ +FLAGS (\\Deleted)" unless $copy;
}

# We are done talking to the IMAP server, close down the connection.
close_connection();

exit $exitcode;

# Subroutine to send a command to the IMAP server, and wait for the
# response; any defined callbacks for the response are invoked.
# If called in list context, we return the server's response, as
# status and text values.  Otherwise, if the response indicates
# failure, we error out.
sub send_command($) {
    print "Sending: $_[0]\n" if $opt_debug;
    my ($status, $text) = $client->send('', '', $_[0]);
    print "Response: status $status, text $text\n" if $opt_debug;
    errorout "Premature end-of-file on IMAP connection to $opt_host"
        if $status eq 'EOF';
    return ($status, $text) if wantarray;
    close_and_errorout "IMAP error from $opt_host: $text"
        if $status ne 'OK';
}

# Callback subroutine to parse the FETCH response from a STORE command.
# This callback will be invoked for each message.  The "-text" hash
# element contains the text returned by the server.
sub fetch_callback(@) {
    my %cb = @_;
    my ($number, $flags);
    print "In FETCH callback: msgno $cb{-msgno} text $cb{-text}\n"
        if $opt_debug;
    $number = $cb{-msgno};
    foreach (split /\r\n/, $cb{-text}) {
        $number = $1 if /UID\s+(\d+)/io;
        $flags = $1 if /FLAGS\s+\(([^\)]*)\)/io;
    }
    # Warn if the message's state does not include the Deleted flag
    # (should never happen).
    if ($flags !~ m/\\Deleted\b/io) {
        print STDERR "$prog: Warning: Message $number not deleted";
        print STDERR " from $opt_mailbox\n";
    }
}

# Close the connection to the IMAP server, and error out.
sub close_and_errorout($) {
    close_connection();
    errorout $_[0];
}

# Logout from the IMAP server, and close the connection.
sub close_connection() {
    $client->send('', '', "LOGOUT");
    # Set the client reference to undef, so that perl invokes the
    # destructor, which closes the connection.  Note that if we invoke
    # the destructor explicitly here, then perl will still invoke it
    # again when the program exits, thus touching memory which has
    # already been freed.
    $client = undef;
}

sub errorout($) {
    print STDERR "$prog: $_[0]\n";
    exit 1;
}