#! /usr/bin/perl -w # # Copyright (c) 1994-2008 Carnegie Mellon University. All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in # the documentation and/or other materials provided with the # distribution. # # 3. The name "Carnegie Mellon University" must not be used to # endorse or promote products derived from this software without # prior written permission. For permission or any legal # details, please contact # Carnegie Mellon University # Center for Technology Transfer and Enterprise Creation # 4615 Forbes Avenue # Suite 302 # Pittsburgh, PA 15213 # (412) 268-7393, fax: (412) 268-7395 # innovation@andrew.cmu.edu # # 4. Redistributions of any form whatsoever must retain the following # acknowledgment: # "This product includes software developed by Computing Services # at Carnegie Mellon University (http://www.cmu.edu/computing/)." # # CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO # THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY # AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE # FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN # AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING # OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. use Getopt::Long; use Cyrus::IMAP; use Cyrus::IMAP::Admin; sub usage { print "imapcollate - Summerize messages in folders\n"; print " usage:\n"; print " imapcollate [-u user] <server> <criteria>\n"; print "\n"; print "possible <criteria>: from\n"; print "\n"; print " example: \n"; print " imapcollate cyrus.andrew.cmu.edu \"inbox*\" from\n"; print "\n"; exit 0; } GetOptions("u|user=s" => \$user, "m|min=i" => \$min); if (@ARGV) { $server = shift(@ARGV); } else { usage; } if (@ARGV) { $where = shift(@ARGV); } else { usage; } if (@ARGV) { $crit = shift(@ARGV); } else { usage; } if ((!defined $server) || (!defined $where)) { usage; } if (!$crit eq "from") { print "Criteria $crit not allowed\n"; usage; } my $cyrus = Cyrus::IMAP->new($server); $cyrus->authenticate(-user => $user, -maxssf => 0); #xxx hangs when have a security layer #list mailboxes in inbox.* my @info = (); $cyrus->addcallback({-trigger => 'LIST', -callback => sub { my %d = @_; next unless $d{-text} =~ s/^\(([^\)]*)\) //; my $attrs = $1; my $sep = ''; # NIL or (attrs) "sep" "str" if ($d{-text} =~ /^N/) { return if $d{-text} !~ s/^NIL//; } elsif ($d{-text} =~ s/\"\\?(.)\"//) { $sep = $1; } return unless $d{-text} =~ s/^ //; my $mbox; if ($d{-text} =~ /\"(([^\\\"]*\\)*[^\\\"]*)\"/) { ($mbox = $1) =~ s/\\(.)/$1/g; } else { $d{-text} =~ /^([]!\#-[^-~]+)/; $mbox = $1; } push @{$d{-rock}}, $mbox; }, -rock => \@info}); my ($rc, $msg) = $cyrus->send('', '', "LIST * $where"); $cyrus->addcallback({-trigger => 'LIST'}); if ($rc eq 'OK') { } else { die "IMAP Error: $msg "; } my %fromlis; foreach $a (@info) { my %dat = coll($a); foreach $per (sort keys %dat) { if (defined $fromlis{$per}) { $fromlis{$per} += $dat{$per}; } else { $fromlis{$per} = $dat{$per}; } } } @sorted = sort { $fromlis{$b} <=> $fromlis{$a} || length($b) <=> length($a) || $a cmp $b } keys %fromlis; foreach $a (@sorted) { if ((defined $min) && ($fromlis{$a} < $min)) { next; } printf("%40s %d\n", $a, $fromlis{$a}); } sub coll { my ($mb) = @_; my %dat; #select something my ($rc, $msg) = $cyrus->send('', '', "EXAMINE $mb"); if ($rc eq 'OK') { } else { die "Select of $mb failed with $msg"; } #list size of all msgs my $totalsize = 0; $flags = 1; print "fetching in $mb...\n"; $cyrus->addcallback({-trigger => 'FETCH', -flags => $flags, -callback => sub { my %d = @_; my $msgno = 1; $msgno = $d{-msgno}; my $size = 0; if ( $d{-text} =~ /.*(From:)(.*)\<(.*\@.*)\>/i) { $addr = $3; } elsif ( $d{-text} =~ /.*(From:)\s*\".*\"\s*(.*\@.*)/i) { $addr = $2; } elsif ( $d{-text} =~ /.*(From:)\s*(\S+\@\S+)\s*/i) { $addr = $2; } else { #print "no From header found in msgno $msgno ($d{-text})\n"; $addr = "<none>"; } $addr =~ tr/[A-Z]/[a-z]/; if ($addr =~ /(.*)\+.*@(.*)/) { $addr = "$1\@$2"; } ${$d{-rock}}{$addr}++; }, -rock => \%dat}); ($rc, $msg) = $cyrus->send('', '', 'UID FETCH 1:* (BODY[HEADER.FIELDS (FROM)])'); $cyrus->addcallback({-trigger => 'FETCH'}); if ($rc eq 'OK') { } else { die "Fetch in $mb failed with $msg"; } (%dat); }