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

Revision 23913, 6.7 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: mailusage.pl,v 1.4 2004-09-03 20:40:31 rbasch Exp $
4
5# Get the total size of, and number of messages in, mailboxes on an
6# IMAP server.
7
8use strict;
9use warnings FATAL => 'all';
10use Cyrus::IMAP;
11use Getopt::Std;
12
13sub usage(;$);
14sub get_usage($);
15sub send_command(@);
16sub list_callback(@);
17sub fetch_callback(@);
18sub number_callback(@);
19sub close_and_errorout($);
20sub close_connection();
21sub errorout($);
22
23sub usage(;$) {
24    print STDERR "mailusage: $_[0]\n" if $_[0];
25    print STDERR <<EOF;
26Usage: mailusage [<options>] [<user>]
27  Options:
28    -h <host>     query <host> instead of default post office server
29    -m <mailbox>  query for <mailbox> only (default is all)
30    -n            suppress the header line
31    -r            query recursively for all mailbox descendents
32    -s            display only subscribed mailboxes
33    -d            turn on debugging
34EOF
35    exit 1;
36}
37
38# Parse the command line arguments.
39my %opts;
40getopts('dh:m:nrs', \%opts) || usage;
41my $username = shift @ARGV || $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] ||
42        errorout "Cannot determine user name";
43
44usage "Too many arguments" if @ARGV > 0;
45my $debug = $opts{'d'};
46my $host = $opts{'h'} || (split(" ", `hesinfo $username pobox`))[1] ||
47    errorout "Cannot find Post Office server for $username";
48errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $host =~ /EXCHANGE/;
49my $mbox = $opts{'m'} || '*';
50my $noheader = $opts{'n'};
51my $recurse = $opts{'r'};
52my $list_cmd = ($opts{'s'} ? 'LSUB' : 'LIST');
53
54# Connect to the IMAP server, and authenticate.
55my $client = Cyrus::IMAP->new($host) ||
56    errorout "Cannot connect to IMAP server on $host";
57unless ($client->authenticate(-authz => $username)) {
58    close_connection();
59    errorout "Cannot authenticate to $host";
60}
61
62# Get all mailboxes of interest.  %mailboxes is a hash whose keys are
63# the mailbox names; the values are hashes with "attributes" and
64# "delimiter" keys.
65my %mailboxes = ();
66$client->addcallback({-trigger => $list_cmd,
67                      -callback => \&list_callback,
68                      -rock => \%mailboxes});
69
70# First list the given mailbox.
71send_command("$list_cmd %s %s", '', $mbox);
72
73# If recursing, also list all descendents of the mailbox, unless the
74# given name contains a trailing wildcard.
75send_command("$list_cmd %s %s%s*", '', $mbox, $mailboxes{$mbox}{delimiter})
76    if ($recurse && $mailboxes{$mbox} && $mailboxes{$mbox}{delimiter} &&
77        $mbox !~ m/\*$/o);
78
79if (%mailboxes) {
80    # We now have all of the mailboxes of interest.  Get and display
81    # the total size and number of messages for each one.
82    foreach my $name (sort keys %mailboxes) {
83        # Skip any mailbox that cannot be selected.
84        next if $mailboxes{$name}{attributes} =~ m/\\Noselect\b/;
85        my ($size, $nmsgs) = get_usage($name);
86        unless ($noheader) {
87            print "Size in KB   #Messages  Mailbox\n";
88            $noheader = 1;
89        }
90        printf("%10d  %10d  %s\n", int(($size + 1023) / 1024), $nmsgs, $name);
91    }
92} else {
93    close_and_errorout "No such mailbox \"$mbox\"";
94}
95
96# We are done talking to the IMAP server; close down the connection.
97close_connection();
98
99# Subroutine to obtain the usage for a given mailbox name.  It returns
100# the total size, i.e. a sum of sizes of all messages in the mailbox,
101# and the number of messages.
102sub get_usage($) {
103    my $mbox = $_[0];
104    my %usage = (totalsize => 0, msgcount => 0);
105    my $exists = 0;
106    my $cb_numbered = Cyrus::IMAP::CALLBACK_NUMBERED;
107    $client->addcallback({-trigger => 'EXISTS', -flags => $cb_numbered,
108                          -callback => \&number_callback,
109                          -rock => \$exists});
110    # Select the mailbox for read-only operations.
111    send_command("EXAMINE %s", $mbox);
112    # If this mailbox has messages, fetch their size.
113    if ($exists) {
114        # The fetch callback will update the values for totalsize and
115        # msgcount in the %usage hash.
116        $client->addcallback({-trigger => 'FETCH', -flags => $cb_numbered,
117                              -callback => \&fetch_callback,
118                              -rock => \%usage});
119        send_command("FETCH 1:* RFC822.SIZE");
120    }
121    return ($usage{totalsize}, $usage{msgcount});
122}
123
124# Subroutine to send a command to the IMAP server, and wait for the
125# response; any defined callbacks for the response are invoked.
126# If the server response indicates failure, we error out.
127sub send_command(@) {
128    my ($fmt, @args) = @_;
129    printf("Sending: $fmt\n", @args) if $debug;
130    my ($status, $text) = $client->send('', '', $fmt, @args);
131    print "Response: status $status, text $text\n" if $debug;
132    errorout "Premature end-of-file on IMAP connection to $host"
133        if $status eq 'EOF';
134    close_and_errorout "IMAP error from $host: $text"
135        if $status ne 'OK';
136}
137
138# Callback to parse a LIST (or LSUB) response for a mailbox name
139# and its attributes and delimiter.
140#
141# The response contains three elements, of the form:
142#
143#     (<attribute> ...) <delimiter> "<name>"
144#
145# For example:
146#
147#     (\HasChildren) "." "INBOX"
148#
149# The delimiter is either a quoted single character, e.g. ".",
150# or NIL.
151#
152# The "-rock" hash element is a reference to a hash to which we add a
153# key for the mailbox name, with its value being a hash with "attributes"
154# and "delimiter" keys.  For a NIL delimiter, the returned value is undef,
155# indicating a flat name.
156sub list_callback(@) {
157    my %cb = @_;
158    print "In LIST callback: text $cb{-text}\n" if $debug;
159    return unless $cb{-text} =~ m/^\(([^\)]*)\)\s+(?:"(.)"|NIL)\s+"(.+)"/o;
160    ${$cb{-rock}}{$3} = {attributes => $1, delimiter => $2};
161}
162
163# Callback to parse the response from a "FETCH ... RFC822.SIZE"
164# command for one message. The "-rock" element is a reference to a
165# hash containing totalsize and msgcount keys, whose values will be
166# updated accordingly.
167sub fetch_callback(@) {
168    my %cb = @_;
169    print "In FETCH callback: text $cb{-text}\n" if $debug;
170    if ($cb{-text} =~ /RFC822.SIZE\s+(\d+)/io) {
171        ${$cb{-rock}}{totalsize} += $1;
172        ${$cb{-rock}}{msgcount}++;
173    }
174}
175
176# Callback to parse a numeric value.  The "-rock" element is a
177# reference to the scalar in which to store the number.
178sub number_callback(@) {
179    my %cb = @_;
180    print "In number callback: keyword $cb{-keyword}, number $cb{-msgno}\n"
181        if $debug;
182    ${$cb{-rock}} = $cb{-msgno};
183}
184
185# Close the connection to the IMAP server, and error out.
186sub close_and_errorout($) {
187    close_connection();
188    errorout $_[0];
189}
190
191# Logout from the IMAP server, and close the connection.
192sub close_connection() {
193    $client->send('', '', "LOGOUT");
194    # Set the client reference to undef, so that perl invokes the
195    # destructor, which closes the connection.  Note that if we invoke
196    # the destructor explicitly here, then perl will still invoke it
197    # again when the program exits, thus touching memory which has
198    # already been freed.
199    $client = undef;
200}
201
202sub errorout($) {
203    print STDERR "mailusage: $_[0]\n";
204    exit 1;
205}
Note: See TracBrowser for help on using the repository browser.