Задача:
С почтового
ящика gmail.com забирать в автоматическом режиме
файлы из
писем, помеченных меткой 'queue'. В случае, если
файлы из
писем забраны успешно, то переносим (метим)
письмо 'history', иначе 'error'.
Решение:
Написана программка на perl:
#!/usr/bin/perl
# ------------------------------------------------------------------
# @(#)$Id: imap4-ssl.pl,v 1.2 2008/08/29 14:52:55 aam Exp $
# ------------------------------------------------------------------
# Программа читает почтовый
ящик, если есть
письма с аттачем --
# выкладывает полученные
файлы в заданный каталог.
# ------------------------------------------------------------------
use strict;
use warnings;
#use Data::Dumper;
use Mail::IMAPClient;
use IO::Socket::SSL;
use MIME::Base64;
use Getopt::Std;
use vars qw(%opts $basename);
sub usage
{
warn(qq(Usage: $basename -U mailbox -P passwd -s imap-server -p port -o outdir
Описание:
Программа читает почтовый
ящик, если есть
письма с аттачем --
выкладывает полученные
файлы в заданный каталог и удаляет
письмо из
ящика.
Опции:
-U mailbox -- имя почтового
ящика (например, test\@gmail.com)
-P passwd -- пароль для получения доступа с почтовому
ящику-s server -- имя почтового сервера (например, imap.gmail.com)
-p port -- номер порта для imap-сервера (например, 993)
-d dir -- каталог для выкладывания полученных
файлов в
письмах (например, /path/to)
\n));
exit 2;
}
($basename=$0) =~ s#.*/##;
getopts("U:P:s:p:d:", \%opts) || &usage
my $server = $opts{s} || 'imap.gmail.com';
my $port = $opts{p} || 993;
my $username = $opts{U} || &usage
my $pass = $opts{P} || &usage
my $dir = $opts{d} || '.';
my $socket = IO::Socket::SSL->new(
PeerAddr => $server,
PeerPort => $port,
) or error("Cannot create ssl-socket(): $@");
my $client = Mail::IMAPClient->new(
Socket => $socket,
User => $username,
Password => $pass,
) or error("Cannot connect imap: $@");
unless ($client->IsAuthenticated()){
error("Cannot authenticate");
}
$client->select('queue');
my @msgs = $client->messages();
unless (@msgs){
print_debug("No messages. Exit 0.");
exit 0;
}
foreach my $msg (@msgs){
my $struct = $client->get_bodystructure($msg);
#print_debug("Struct: ".Dumper($struct));
my $bs = $struct->bodystructure;
unless (ref($bs) eq 'ARRAY'){
print_debug("Bodystructure is not ARRAY. Skip.");
next;
}
my $p = 0; # Number of part
my $folder = 'history';
my $count = 0; # Count of saved files
foreach my $r (@$bs){
$p ++;
#print_debug("R$p: ".Dumper($r));
my $disp = $r->bodydisp();
unless (defined $disp && ref($disp) eq 'HASH'){
print_debug("Skip #$p part. Undefined body disp");
next;
}
my $fname = $disp->{ATTACHMENT}{FILENAME};
unless (defined $fname){
print_debug("Skip #$p part. Undefined FILENAME");
next;
}
$fname = "$dir/$fname";
if (-f $fname){
print_error("File '$fname' already exists! Skip.");
$folder = 'error';
next;
}
my $data;
my $enc = $r->bodyenc;
my $string = $client->bodypart_string($msg, $p);
print_debug("$p: Fname: $fname Enc: $enc");
if ($enc =~ m/BASE64/i){
$data = decode_base64($string);
}elsif($enc =~ m/QUOT-PRINTED/i){
$data = $string;
}
unless (open(FD, ">", $fname)){
print_error( "Cannot write to file '$fname': $!");
$folder = 'error';
next;
}
binmode(FD);
print FD $data;
close(FD);
$count ++;
}
unless ($count){
print_error("Email doesn't contain files");
$folder = 'error';
}
print_debug("Move message to '$folder'");
$client->move($folder, $msg);
}
# Say bye
$client->logout();
exit 0;
sub print_debug
{
my $msg = shift;
warn("D> $msg\n") if ($ENV{DEBUG});
}
sub print_error
{
my $msg = shift;
warn("E-$$> $msg\n");
}
sub error
{
print_error(@_);
exit 1;
}
P.S. Возможны проблемы с
файлами, в названиях которых встречаются буквы отличные от английских.
P.P.S. Программу для отсылки прикрепленных
файлов через gmail можно найти здесь.
Современная 
автор: Владимир Авденин,
Нежная и смешная 
