source: trunk/athena/bin/mitmailutils/mitmailexp.pl @ 23913

Revision 23913, 3.0 KB checked in by andersk, 15 years ago (diff)
In mitmailutils: * Replace test for EXCHANGE.MIT.EDU with test for *EXCHANGE*.
Line 
1#!/usr/bin/perl -w
2
3# $Id: mitmailexp.pl,v 1.3 2004-07-29 19:11:53 rbasch Exp $
4
5# Expunge an IMAP folder.
6
7use strict;
8use warnings FATAL => 'all';
9use Cyrus::IMAP;
10use Getopt::Long;
11
12sub usage(;$);
13sub send_command($);
14sub fetch_callback(@);
15sub number_callback(@);
16sub make_msgspecs(@);
17sub close_connection();
18sub errorout($);
19
20my $prog = $0;
21
22sub usage(;$) {
23    print STDERR "$prog: $_[0]\n" if ($_[0] && $_[0] ne "help");
24    print STDERR <<EOF;
25Usage: $prog [<options>]
26  Options:
27    --debug                turn on debugging
28    --help                 print this usage information
29    --host=<name>          query host <name> instead of default POBOX server
30    --mailbox=<name>       examine mailbox <name> instead of INBOX
31EOF
32    exit 1;
33}
34
35# Parse the command line arguments.
36use vars qw($opt_debug $opt_host $opt_mailbox);
37
38GetOptions("debug",
39           "help" => \&usage,
40           "host=s",
41           "mailbox=s") || usage;
42
43usage "Too many arguments" if @ARGV > 0;
44
45$opt_mailbox = 'INBOX' unless $opt_mailbox;
46
47my $username = $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] ||
48    errorout "Cannot determine user name";
49
50unless ($opt_host) {
51    $opt_host = (split(" ", `hesinfo $username pobox`))[1] ||
52        errorout "Cannot find Post Office server for $username";
53}
54errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $opt_host =~ /EXCHANGE/;
55
56# Connect to the IMAP server, and authenticate.
57my $client = Cyrus::IMAP->new($opt_host) ||
58    errorout "Cannot connect to IMAP server on $opt_host";
59unless ($client->authenticate(-authz => $username)) {
60    close_connection();
61    errorout "Cannot authenticate to $opt_host";
62}
63
64# Access the mailbox.  Make sure we have read-write access.
65send_command "SELECT \"$opt_mailbox\"";
66
67# Close the mailbox, thereby expunging deleted messages.
68send_command "CLOSE";
69
70# We are done talking to the IMAP server, close down the connection.
71close_connection();
72
73# Subroutine to send a command to the IMAP server, and wait for the
74# response; any defined callbacks for the response are invoked.
75# If the server response indicates failure, we error out.
76sub send_command($) {
77    print "Sending: $_[0]\n" if $opt_debug;
78    my ($status, $text) = $client->send('', '', $_[0]);
79    print "Response: status $status, text $text\n" if $opt_debug;
80    errorout "Premature end-of-file on IMAP connection to $opt_host"
81        if $status eq 'EOF';
82    if ($status ne 'OK') {
83        close_connection();
84        errorout "IMAP error for $opt_mailbox on $opt_host: $text"
85    }
86}
87
88# Logout from the IMAP server, and close the connection.
89sub close_connection() {
90    $client->send('', '', "LOGOUT");
91    # Set the client reference to undef, so that perl invokes the
92    # destructor, which closes the connection.  Note that if we invoke
93    # the destructor explicitly here, then perl will still invoke it
94    # again when the program exits, thus touching memory which has
95    # already been freed.
96    $client = undef;
97}
98
99sub errorout($) {
100    print STDERR "$prog: $_[0]\n";
101    exit 1;
102}
Note: See TracBrowser for help on using the repository browser.