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 | |
---|
8 | use strict; |
---|
9 | use warnings FATAL => 'all'; |
---|
10 | use Cyrus::IMAP; |
---|
11 | use Getopt::Std; |
---|
12 | |
---|
13 | sub usage(;$); |
---|
14 | sub get_usage($); |
---|
15 | sub send_command(@); |
---|
16 | sub list_callback(@); |
---|
17 | sub fetch_callback(@); |
---|
18 | sub number_callback(@); |
---|
19 | sub close_and_errorout($); |
---|
20 | sub close_connection(); |
---|
21 | sub errorout($); |
---|
22 | |
---|
23 | sub usage(;$) { |
---|
24 | print STDERR "mailusage: $_[0]\n" if $_[0]; |
---|
25 | print STDERR <<EOF; |
---|
26 | Usage: 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 |
---|
34 | EOF |
---|
35 | exit 1; |
---|
36 | } |
---|
37 | |
---|
38 | # Parse the command line arguments. |
---|
39 | my %opts; |
---|
40 | getopts('dh:m:nrs', \%opts) || usage; |
---|
41 | my $username = shift @ARGV || $ENV{'ATHENA_USER'} || $ENV{'USER'} || getlogin || (getpwuid($<))[0] || |
---|
42 | errorout "Cannot determine user name"; |
---|
43 | |
---|
44 | usage "Too many arguments" if @ARGV > 0; |
---|
45 | my $debug = $opts{'d'}; |
---|
46 | my $host = $opts{'h'} || (split(" ", `hesinfo $username pobox`))[1] || |
---|
47 | errorout "Cannot find Post Office server for $username"; |
---|
48 | errorout "Exchange accounts are not supported yet. Try http://owa.mit.edu/." if $host =~ /EXCHANGE/; |
---|
49 | my $mbox = $opts{'m'} || '*'; |
---|
50 | my $noheader = $opts{'n'}; |
---|
51 | my $recurse = $opts{'r'}; |
---|
52 | my $list_cmd = ($opts{'s'} ? 'LSUB' : 'LIST'); |
---|
53 | |
---|
54 | # Connect to the IMAP server, and authenticate. |
---|
55 | my $client = Cyrus::IMAP->new($host) || |
---|
56 | errorout "Cannot connect to IMAP server on $host"; |
---|
57 | unless ($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. |
---|
65 | my %mailboxes = (); |
---|
66 | $client->addcallback({-trigger => $list_cmd, |
---|
67 | -callback => \&list_callback, |
---|
68 | -rock => \%mailboxes}); |
---|
69 | |
---|
70 | # First list the given mailbox. |
---|
71 | send_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. |
---|
75 | send_command("$list_cmd %s %s%s*", '', $mbox, $mailboxes{$mbox}{delimiter}) |
---|
76 | if ($recurse && $mailboxes{$mbox} && $mailboxes{$mbox}{delimiter} && |
---|
77 | $mbox !~ m/\*$/o); |
---|
78 | |
---|
79 | if (%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. |
---|
97 | close_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. |
---|
102 | sub 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. |
---|
127 | sub 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. |
---|
156 | sub 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. |
---|
167 | sub 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. |
---|
178 | sub 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. |
---|
186 | sub close_and_errorout($) { |
---|
187 | close_connection(); |
---|
188 | errorout $_[0]; |
---|
189 | } |
---|
190 | |
---|
191 | # Logout from the IMAP server, and close the connection. |
---|
192 | sub 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 | |
---|
202 | sub errorout($) { |
---|
203 | print STDERR "mailusage: $_[0]\n"; |
---|
204 | exit 1; |
---|
205 | } |
---|