diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 219 |
1 files changed, 170 insertions, 49 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3a6481e..be62a9d 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -16,13 +16,14 @@ # along with this program. If not, see <http://www.gnu.org/licenses/>. #---------------------------------------------------------------------- -package Net::IMAP::InterIMAP v0.0.2; +package Net::IMAP::InterIMAP v0.0.3; use warnings; use strict; use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); -use IO::Select (); +use Errno 'EINTR'; +use Fcntl qw/F_GETFL F_SETFL FD_CLOEXEC/; use Net::SSLeay (); use List::Util qw/all first/; use POSIX ':signal_h'; @@ -43,6 +44,8 @@ my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; +my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-2])/; + # Map each option to a regexp validating its values. my %OPTIONS = ( host => qr/\A(\P{Control}+)\z/, @@ -56,6 +59,7 @@ my %OPTIONS = ( command => qr/\A(\P{Control}+)\z/, 'null-stderr' => qr/\A(YES|NO)\z/i, compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, + SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/, SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/, SSL_cipherlist => qr/\A(\P{Control}+)\z/, SSL_verify => qr/\A(YES|NO)\z/i, @@ -485,11 +489,11 @@ sub stats($) { $msg .= ' recv '._kibi($self->{_OUTCOUNT}); $msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}). ', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')' - if defined $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0; + if exists $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0; $msg .= ' sent '._kibi($self->{_INCOUNT}); $msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}). ', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')' - if defined $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0; + if exists $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0; $self->log($msg); } @@ -520,9 +524,10 @@ sub log($@) { return unless @_; $self->logger(@_) if defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno and $self->{'logger-fd'}->fileno != fileno STDERR; - my $prefix = defined $self->{name} ? $self->{name} : ''; + my $prefix = $self->{name} // ''; $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - print STDERR $prefix, ': ', @_, "\n"; + $prefix .= ': ' unless $prefix eq ''; + print STDERR $prefix, @_, "\n"; } sub logger($@) { my $self = shift; @@ -531,11 +536,13 @@ sub logger($@) { if (defined $self->{'logger-fd'}->fileno and defined $self->{'logger-fd'}->fileno and $self->{'logger-fd'}->fileno != fileno STDERR) { my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; + $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us"; + $prefix .= ' ' if defined $self->{name} or $self->{_STATE} eq 'SELECTED'; } - $prefix .= defined "$self->{name}" ? $self->{name} : ''; + $prefix .= $self->{name} if defined $self->{name}; $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $self->{'logger-fd'}->say($prefix, ': ', @_); + $prefix .= ': ' unless $prefix eq ''; + $self->{'logger-fd'}->say($prefix, @_); } @@ -731,6 +738,7 @@ sub rename($$$;$) { # If $try is set, print a warning but don't crash if the command fails. sub subscribe($$;$) { my ($self, $mailbox, $try) = @_; + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); if ($IMAP_cond eq 'OK') { $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; @@ -743,6 +751,7 @@ sub subscribe($$;$) { } sub unsubscribe($$;$) { my ($self, $mailbox, $try) = @_; + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); if ($IMAP_cond eq 'OK') { $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; @@ -831,6 +840,7 @@ sub append($$@) { # dump the cache before issuing the command if we're appending to the current mailbox my ($UIDNEXT, $EXISTS, $cache, %vanished); + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { $cache = $self->{_CACHE}->{$mailbox}; $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); @@ -925,36 +935,68 @@ sub notify($@) { my $command = 'NOTIFY '; $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE'; $self->_send($command); - $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT}); } -# $self->slurp() +# $self->slurp([$cmd, $callback]) # See if the server has sent some unprocessed data; try to as many # lines as possible, process them, and return the number of lines # read. # This is mostly useful when waiting for notifications while no -# command is progress, cf. RFC 5465 (NOTIFY). -sub slurp($) { - my $self = shift; - +# command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY). +sub slurp($;$$) { + my ($self, $cmd, $callback) = @_; my $ssl = $self->{_SSL}; my $read = 0; + vec(my $rin, fileno($self->{STDOUT}), 1) = 1; while (1) { - # Unprocessed data within the current TLS record would cause - # select(2) to block/timeout due to the raw socket not being - # ready. - unless (defined $ssl and Net::SSLeay::pending($ssl) > 0) { - my ($ok) = $self->{_SEL_OUT}->can_read(0); - return $read unless defined $ok; - } - $self->_resp( $self->_getline() ); + unless ((defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') or + # Unprocessed data within the current TLS record would + # cause select(2) to block/timeout due to the raw socket + # not being ready. + (defined $ssl and Net::SSLeay::pending($ssl) > 0)) { + my $r = CORE::select($rin, undef, undef, 0); + next if $r == -1 and $! == EINTR; # select(2) was interrupted + $self->panic("Can't select: $!") if $r == -1; + return $read if $r == 0; # nothing more to read + } + my $x = $self->_getline(); + $self->_resp($x, $cmd, undef, $callback); $read++; } } +# $self->idle([$timeout, $stopwhen]) +# Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or +# when the callback $stopwhen returns true. +# Return false if the timeout was reached, and true if IDLE was +# stopped due the callback. +sub idle($$$) { + my ($self, $timeout, $stopwhen) = @_; + $timeout //= 1740; # 29 mins + + $self->fail("Server did not advertise IDLE (RFC 2177) capability.") + unless $self->_capable('IDLE'); + + my $tag = $self->_cmd_init('IDLE'); + $self->_cmd_flush(); + + for (; $timeout > 0; $timeout--) { + $self->slurp('IDLE', sub() {$timeout = -1 if $stopwhen->()}); + sleep 1 if $timeout > 0; + } + + # done idling + $self->_cmd_extend('DONE'); + $self->_cmd_flush(); + $self->_recv($tag); + + return $timeout < 0 ? 1 : 0; +} + + # $self->set_cache( $mailbox, STATE ) # Initialize or update the persistent cache, that is, associate a # known $mailbox with the last known (synced) state: @@ -970,6 +1012,7 @@ sub slurp($) { sub set_cache($$%) { my $self = shift; my $mailbox = shift // $self->panic(); + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $cache = $self->{_PCACHE}->{$mailbox} //= {}; my %status = @_; @@ -996,6 +1039,7 @@ sub uidvalidity($;$) { my $self = shift; my $mailbox = shift; if (defined $mailbox) { + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $cache = $self->{_CACHE}->{$mailbox} // return; return $cache->{UIDVALIDITY}; } @@ -1030,21 +1074,21 @@ sub get_cache($@) { # $self->is_dirty($mailbox) -# Return true if there are pending updates for $mailbox, i.e., its -# internal cache is newer than its persistent cache. +# Return true if there are pending updates for $mailbox, i.e., if its +# internal cache's HIGHESTMODSEQ or UIDNEXT values differ from its +# persistent cache's values. sub is_dirty($$) { my ($self, $mailbox) = @_; - my $cache = $self->{_CACHE}->{$mailbox} // return 1; - my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; + $self->_updated_cache($mailbox, qw/HIGHESTMODSEQ UIDNEXT/); +} - if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ} - and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and - defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT} - and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) { - return 0 - } else { - return 1 - } + +# $self->has_new_mails($mailbox) +# Return true if there are new messages in $mailbox, i.e., if its +# internal cache's UIDNEXT value differs from its persistent cache's. +sub has_new_mails($$) { + my ($self, $mailbox) = @_; + $self->_updated_cache($mailbox, 'UIDNEXT'); } @@ -1242,6 +1286,31 @@ sub push_flag_updates($$@) { } +# $self->silent_store($set, $mod, @flags) +# Set / Add / Remove the flags list on the UID $set, depending on the +# value of $mod ('' / '+' / '-'). +# /!\ There is no guaranty that message flags are successfully updated! +sub silent_store($$$@) { + my $self = shift; + my $set = shift; + my $mod = shift; + $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")"); +} + + +# $self->expunge($set) +# Exunge the given UID $set. +# /!\ There is no guaranty that messages are successfully expunged! +sub expunge($$) { + my $self = shift; + my $set = shift; + + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") + unless $self->_capable('UIDPLUS'); + $self->_send("UID EXPUNGE $set"); +} + + ############################################################################# # Private methods @@ -1299,7 +1368,13 @@ sub _tcp_connect($$$) { foreach my $ai (@res) { socket my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol}; - return $s if defined $s and connect($s, $ai->{addr}); + # TODO: add a connection timeout + # http://devpit.org/wiki/Connect%28%29_with_timeout_%28in_Perl%29 + if (defined $s and connect($s, $ai->{addr})) { + my $flags = fcntl($s, F_GETFL, 0) or $self->panic("fcntl F_GETFL: $!"); + fcntl($s, F_SETFL, $flags | FD_CLOEXEC) or $self->panic("fcntl F_SETFL: $!"); + return $s; + } } $self->fail("Can't connect to $host:$port"); } @@ -1460,20 +1535,42 @@ sub _ssl_verify($$$) { return $ok; # 1=accept cert, 0=reject } +my %SSL_proto = ( + 'SSLv2' => Net::SSLeay::OP_NO_SSLv2(), + 'SSLv3' => Net::SSLeay::OP_NO_SSLv3(), + 'TLSv1' => Net::SSLeay::OP_NO_TLSv1(), + 'TLSv1.1' => Net::SSLeay::OP_NO_TLSv1_1(), + 'TLSv1.2' => Net::SSLeay::OP_NO_TLSv1_2() +); # $self->_start_ssl($socket) # Upgrade the $socket to SSL/TLS. sub _start_ssl($$) { my ($self, $socket) = @_; my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!"); + my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE(); + + $self->{SSL_protocols} //= q{!SSLv2 !SSLv3}; + my ($proto_include, $proto_exclude) = (0, 0); + foreach (split /\s+/, $self->{SSL_protocols}) { + my $neg = s/^!// ? 1 : 0; + s/\.0$//; + ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_"); + } + if ($proto_include != 0) { + # exclude all protocols except those explictly included + my $x = 0; + $x |= $_ foreach values %SSL_proto; + $x &= ~ $proto_include; + $proto_exclude |= $x; + } + my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto; + $self->log("Disabling SSL protocol: ".join(', ', sort @proto_exclude)) if $self->{debug}; + $ssl_options |= $SSL_proto{$_} foreach @proto_exclude; + $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION(); # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html - Net::SSLeay::CTX_set_options($ctx, - Net::SSLeay::OP_SINGLE_ECDH_USE() | - Net::SSLeay::OP_SINGLE_DH_USE() | - Net::SSLeay::OP_NO_SSLv2() | - Net::SSLeay::OP_NO_SSLv3() | - Net::SSLeay::OP_NO_COMPRESSION() ); + Net::SSLeay::CTX_set_options($ctx, $ssl_options); # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html Net::SSLeay::CTX_set_mode($ctx, @@ -1625,6 +1722,24 @@ sub _update_cache_for($$%) { } +# $self->_updated_cache($mailbox) +# Return true if there are pending updates for $mailbox, i.e., if one +# of its internal cache's @attrs value differs from the persistent +# cache's value. +sub _updated_cache($$@) { + my ($self, $mailbox, @attrs) = @_; + $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive + my $cache = $self->{_CACHE}->{$mailbox} // return 1; + my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; + + foreach (@attrs) { + return 1 unless $pcache->{$_} and defined $cache->{$_} and + $pcache->{$_} == $cache->{$_}; + } + return 0; +} + + # $self->_cmd_init($command) # Generate a new tag for the given $command, push both the # concatenation to the command buffer. $command can be a scalar or a @@ -1892,11 +2007,11 @@ sub _select_or_examine($$$;$$) { my $mailbox = shift; my ($seqs, $uids) = @_; + $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive my $pcache = $self->{_PCACHE}->{$mailbox} //= {}; my $cache = $self->{_CACHE}->{$mailbox} //= {}; $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY}; - $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive $command .= ' '.quote($mailbox); if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " @@ -2078,7 +2193,7 @@ sub _envelope($$) { return \@envelope; } -# $self->_resp($buf, [$cmd, $callback] ) +# $self->_resp($buf, [$cmd, $set, $callback] ) # Parse an untagged response line or a continuation request line. # (The trailing CRLF must be removed.) The internal cache is # automatically updated when needed. @@ -2119,8 +2234,10 @@ sub _resp($$;$$$) { } elsif (/\A([0-9]+) EXPUNGE\z/) { # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs - $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check - $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC'); + if ($self->_enabled('QRESYNC')) { + $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check + $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled."); + } $cache->{EXISTS}--; # explicit EXISTS responses are optional } elsif (/\ASEARCH((?: [0-9]+)*)\z/) { @@ -2180,16 +2297,18 @@ sub _resp($$;$$$) { undef $first; } - my $uid = $mail{UID} // $self->panic(); # sanity check $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check + my $uid = $mail{UID}; if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails + defined $uid and # /!\ ignore unsolicited FETCH responses without UID, cf RFC 7162 section 3.2.4 (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) { my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS}; $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ]; } - $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set); + $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and + defined $uid and in_set($uid, $set); } elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE $self->{_ENABLED} //= []; @@ -2215,7 +2334,8 @@ sub _resp($$;$$$) { } } } - elsif (s/\A\+ //) { + elsif (s/\A\+// and ($_ eq '' or s/\A //)) { + # Microsoft Exchange Server 2010 violates RFC 3501 by skipping the trailing ' ' for empty resp-text if (defined $callback and $cmd eq 'AUTHENTICATE') { my $x = $callback->($_); $self->_cmd_extend(\$x); @@ -2225,6 +2345,7 @@ sub _resp($$;$$$) { else { $self->panic("Unexpected response: ", $_); } + $callback->() if defined $callback and $cmd eq 'IDLE'; } |