Merge branch 'master' into debian

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';
 }