Шустрый
Профиль
Группа: Участник
Сообщений: 83
Регистрация: 19.12.2010
Репутация: нет Всего: нет
|
Встал вопрос создания резервных копий одного из почтовых ящиков с доступом по IMAP4. Идет активная переписка и почтовый ящик постоянно забивается по квоте. Приходится вручную чистить. Но удаленные письма с некоторой периодичностью бывают востребованы. Сейчас я написал скрипт на Perl, который вытягивает все письма со всех каталогов IMAP4, раскладывает по каталогам на диске. Потом я все это архивирую. Недостаток: в разных архивах одни и те же письма иногда дублируются. Есть ли какой способ получить или сформировать уникальный идентификатор для каталога и для письма при доступе по IMAP4?Почему и для каталога? Нужно разделить каталоги, которые удалялись, а потом создавались с одинаковыми именами. Возможно кому-то понадобится архивировать почту по IMAP4, делюсь своим скриптом: Код | #!/usr/bin/perl
use strict; use utf8;
use FileHandle; use IO::File; use Mail::IMAPClient; use Mail::IMAPClient::BodyStructure; use IO::Socket; use IO::Socket::SSL; use Data::Dumper; use File::Path; use DateTime::Format::DateParse; use Encode qw/encode decode/;
# Конфиги my $hostname = 'imap4.server.tld'; my $username = 'username'; my $password = 'password'; my $ssl = 1; my $tmp = "X:/Work/imap4-grab/mailbox/$username"; my @toc = ();
select(STDOUT); binmode(STDOUT,':utf8'); $| = 1;
# Открываем сокет почтового сервера my $socket = OpenMailServer($hostname, $username, $password, $ssl) or die "Не могу открыть сокет почтового сервера: $@\n";
# Открываем соединение по IMAP4 my $imap = OpenImap4Connection($socket, $username, $password) or die "Не могу инициализировать IMAP4 соединение: $@\n";
# Проверка авторизации на почтовом IMAP4 сервере $imap->IsAuthenticated() or die "Не могу авторизоваться на IMAP4 сервере: $@\n";
# Получаем список папок на почтовой IMAP4 учетной записи my @folders = $imap->folders->@* or die "Не могу получить список папок в почтовой IMAP4 учетной записи: $@\n"; print "Total IMAP4 dirs: ".scalar(@folders)."\n\n";
# Cоздаем каталог для временных файлов rmtree($tmp); mkpath($tmp, 0, 0777);
# Обрабатываем сообщения в папках my $counter = 0; foreach my $i (@folders) { $counter++; mkdir("$tmp/$counter"); ProcessFolder($imap, $tmp, $counter, $i); }
#Записываем оглавление my $toc_text = "Папка^Кто^Тема^Дата^Время^Файл\n"; for my $i (@toc) { $toc_text .= join("^",@{$i})."\n"; } my $fh = FileHandle->new(); open $fh, ">:utf8", "$tmp/toc.txt" or die "Could not open \"$tmp/toc.txt\": $!\n"; print $fh $toc_text; $fh->close();
print "\nDone.\n";
# Закрываем соединение с почтовым IMAP4 сервером $imap->done();
# Выход exit 0;
############################################################################ # OpenMailServer - открывает сокет почтового сервера ############################################################################ sub OpenMailServer { my ($hostname, $username, $password, $ssl) = @_; my $ret = undef; $ret = ($ssl) ? IO::Socket::SSL->new(PeerAddr => $hostname, PeerPort => 993, Timeout => 15) : IO::Socket::INET->new(PeerAddr => $hostname, PeerPort => 143, Timeout => 15); return $ret; } ############################################################################ # OpenImap4Connection - открывает соединение по IMAP4 ############################################################################ sub OpenImap4Connection { my ($socket, $username, $password) = @_; my $ret = undef; #my $dh = IO::File->new(">debugging.output") or die "Can't open debugging.output: $!\n"; $ret = Mail::IMAPClient->new(Socket => $socket, User => $username, Password => $password, #Debug=> "yes, please", #Debug_fh => $dh, Timeout => 15); return $ret; } ############################################################################ # ProcessFolder - обработка сообщений отдельной папки учетки IMAP4 сервера ############################################################################ sub ProcessFolder { my ($imap, $tmp, $counter, $box) = @_; die "Не могу выбрать папку \"$box\": $@\n" unless($imap->select($box)); my ($cur,$cnt) = (1,$imap->message_count($box)); print " process \"$box\" ($cnt) ... "; foreach my $i ($imap->search('ALL')) { my $dt = DateTime::Format::DateParse->parse_datetime($imap->date($i)); my $date = "1980.01.01"; my $time = "00:00:00"; my $ftime = "00.00.00"; if (defined($dt)) { $date = sprintf("%04d.%02d.%02d",$dt->year(), $dt->month(), $dt->day()); $time = sprintf("%02d:%02d:%02d",$dt->hour(), $dt->minute(), $dt->second()); $ftime = sprintf("%02d.%02d.%02d",$dt->hour(), $dt->minute(), $dt->second()); } my @chars = ("a".."z"); my $name; $name .= $chars[rand @chars] for 1..3; $name = $date."-".$ftime."-".$name.".eml"; my $hashref = $imap->parse_headers($i,"Date","Subject","From","Sender"); my $sender = decode('MIME-Header', ${$hashref}{'From'}[0]); my $subject = decode('MIME-Header', $imap->subject($i)); print "\r process \"$box\" ($cnt) ... $cur"; WriteFile("$tmp/$counter/$name", $i, $imap); $cur++; push @toc,[$box,$sender,$subject,$date,$time,"=ГИПЕРССЫЛКА(\"file://$tmp/$counter/$name\";\"$name\")"]; } print "\r process \"$box\" ($cnt) ... Ok \n"; } ############################################################################ # WriteFile - запись сообщения в файл ############################################################################ sub WriteFile { my ($name, $id, $imap) = @_; my $fh = FileHandle->new("> $name"); die "Ошибка открытия файла на запись" unless(defined $fh); $imap->message_to_file($fh,$id) or die "Не могу записать сообщение в файл: $@\n"; $fh->close; }
|
Может ткнете носом в нужный RFC, где об этом почитать?
|