Merge branch 'master' into debian

7 files changed, 363 insertions, 86 deletions

diff --git a/Changelog b/Changelog
index acd02d2..5b010d2 100644
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,18 @@
+interimap (0.2) upstream
+
+  * Add support for the IMAP COMPRESS extension [RFC4978].  By default
+    enabled for the remote server, and disabled for the local server.
+  * Add traffic statistics after closing the connection to the IMAP
+    server.
+  * Add a configuration option 'null-stderr=YES' to send STDERR to
+    /dev/null for type=tunnel.
+  * Add support for the Binary Content extension [RFC3516].  Enabled by
+    default if both the local and remote servers advertize "BINARY".
+	Can be disabled by adding 'use-binary=NO' to the default section in
+	the configuration file.
+
+ -- Guilhem Moulin <guilhem@guilhem.org>  Wed, 09 Sep 2015 00:44:35 +0200
+
 interimap (0.1) upstream;
 
   * Initial public release.  Development was started in July 2015.
diff --git a/INSTALL b/INSTALL
index 7bc3eef..f27952b 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,8 +1,10 @@
 InterIMAP depends on the following Perl modules:
 
+  - Compress::Zlib (core module)
   - Config::Tiny
   - DBI
   - DBD::SQLite
+  - Errno (core module)
   - Getopt::Long (core module)
   - MIME::Base64 (core module) if authentication is required
   - IO::Select (core module)
diff --git a/README b/README
index 44190f3..2809ccb 100644
--- a/README
+++ b/README
@@ -23,11 +23,14 @@ the last synchronization only gives a phenomenal performance boost and
 drastically reduces the network traffic.
 
 For convenience reasons servers must also support LIST-EXTENDED
-[RFC5258], LIST-STATUS [RFC5819] and UIDPLUS [RFC4315].  Furthermore,
-while InterIMAP can work with servers lacking support for LITERAL+
-[RFC2088] and MULTIAPPEND [RFC3502], these extensions greatly improve
-performance by reducing the number of required round trips hence are
-recommended.
+[RFC5258], LIST-STATUS [RFC5819] and UIDPLUS [RFC4315].  Other supported
+extensions are:
+  * LITERAL+ [RFC2088] non-synchronizing literals (recommended),
+  * MULTIAPPEND [RFC3502] (recommended),
+  * COMPRESS=DEFLATE [RFC4978] (recommended),
+  * SASL-IR [RFC4959] SASL Initial Client Response,
+  * UNSELECT [RFC3691], and
+  * BINARY [RFC3516].
 
 
 #######################################################################
@@ -71,6 +74,13 @@ type=imaps.
     remote: ~user/.ssh/authorized_keys:
       command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-interimap
 
+However for long-lived connections (using the --watch command-line
+option), the TLS overhead becomes negligible hence the advantage offered
+by the OpenSSH ControlPersist feature is not obvious.  Furthermore if
+the remote server supports the IMAP COMPRESS extension [RFC4978], adding
+compress=DEFLATE to the configuration can also greatly reduce bandwidth
+usage with regular INET sockets (type=imaps or type=imap).
+
 
 #######################################################################
 
diff --git a/interimap b/interimap
index af8b7fd..81582f2 100755
--- a/interimap
+++ b/interimap
@@ -74,6 +74,7 @@ my $CONF = read_config( delete $CONFIG{config} // $NAME
                       , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
                       , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/
                       , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
+                      , 'use-binary' => qr/\A(YES|NO)\z/i,
                       );
 my ($DBFILE, $LOCKFILE, $LOGGER_FD);
 
@@ -109,7 +110,9 @@ my ($DBFILE, $LOCKFILE, $LOGGER_FD);
 my $DBH;
 
 # Clean after us
+my ($IMAP, $lIMAP, $rIMAP);
 sub cleanup() {
+    undef $_ foreach grep defined, ($IMAP, $lIMAP, $rIMAP);
     logger(undef, "Cleaning up...") if $CONFIG{debug};
     unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
     close $LOGGER_FD if defined $LOGGER_FD;
@@ -239,13 +242,13 @@ $LIST .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0])
        : ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV;
 
 
-my $IMAP;
 foreach my $name (qw/local remote/) {
     my %config = %{$CONF->{$name}};
     $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/;
     $config{enable} = 'QRESYNC';
     $config{name} = $name;
     $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
+    $config{'compress'} //= ($name eq 'local' ? 'NO' : 'YES');
 
     $IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
     my $client = $IMAP->{$name}->{client};
@@ -268,6 +271,7 @@ foreach my $name (qw/local remote/) {
 
 @{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/;
 
+
 ##############################################################################
 #
 
@@ -507,7 +511,11 @@ sub sync_mailbox_list() {
 }
 
 sync_mailbox_list();
-my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+my $ATTRS = 'MODSEQ FLAGS INTERNALDATE '.
+            (((!defined $CONF->{_} or uc ($CONF->{_}->{'use-binary'} // 'YES') eq 'YES') and
+             !$lIMAP->incapable('BINARY') and !$rIMAP->incapable('BINARY'))
+                ? 'BINARY' : 'BODY').'.PEEK[]';
 
 
 #############################################################################
@@ -589,10 +597,10 @@ sub download_missing($$$@) {
     my ($buff, $bufflen) = ([], 0);
     undef $buff if ($target eq 'local' ? $lIMAP : $rIMAP)->incapable('MULTIAPPEND');
 
-    my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE ENVELOPE BODY.PEEK[]/;
+    my $attrs = $ATTRS.' ENVELOPE';
     ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) {
         my $mail = shift;
-        return unless exists $mail->{RFC822}; # not for us
+        return unless exists $mail->{RFC822} or exists $mail->{BINARY}; # not for us
 
         my $uid = $mail->{UID};
         my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
@@ -961,9 +969,10 @@ sub sync_known_messages($$) {
 # after the FETCH.
 sub callback_new_message($$$$;$$$) {
     my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_;
-    return unless exists $mail->{RFC822}; # not for us
 
-    my $length = length $mail->{RFC822};
+    my $length = defined $mail->{RFC822} ? length($mail->{RFC822})
+               : defined $mail->{BINARY} ? length($mail->{BINARY})
+               : return; # not for us
     if ($length == 0) {
         msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})");
         return;
@@ -1027,7 +1036,7 @@ sub sync_messages($$;$$) {
             my $bufflen = 0;
             my @tUIDs;
 
-            ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages(sub($) {
+            ($source eq 'remote' ? $rIMAP : $lIMAP)->pull_new_messages($ATTRS, sub($) {
                 callback_new_message($idx, $mailbox, $source, shift, \@tUIDs, $buff, \$bufflen)
             }, @{$ignore{$source}});
 
@@ -1215,7 +1224,4 @@ while(1) {
     sync_mailbox_list();
 }
 
-END {
-    $_->logout() foreach grep defined, ($lIMAP, $rIMAP);
-    cleanup();
-}
+END { cleanup(); }
diff --git a/interimap.1 b/interimap.1
index 44235fc..988fa16 100644
--- a/interimap.1
+++ b/interimap.1
@@ -15,10 +15,7 @@ servers.
 Such synchronization is made possible by the QRESYNC extension from
 [RFC7162]; for convenience reasons servers must also support
 LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315].
-Furthermore, while \fBInterIMAP\fR can work with servers lacking support
-for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions
-greatly improve performance by reducing the number of required round
-trips hence are recommended.
+See also the \fBSUPPORTED EXTENSIONS\fR section.
 
 .PP
 Stateful synchronization is only possible for mailboxes supporting
@@ -311,6 +308,49 @@ rely on Certificate Authorities.
 Directory containing the certificate(s) of the trusted Certificate
 Authorities, used for server certificate verification.
 
+.TP
+.I compress
+Whether to use the IMAP COMPRESS extension [RFC4978] for servers
+advertizing it.
+(Default: \(lqNO\(rq for the \(lq[local]\(rq section, \(lqYES\(rq for
+the \(lq[remote]\(rq section.)
+
+.TP
+.I null-stderr
+Whether to redirect \fIcommand\fR's standard error to \(lq/dev/null\(rq
+for type \fItype\fR=tunnel.
+(Default: \(lqNO\(rq.)
+
+.TP
+.I use-binary
+Whether to use the Binary Content extension [RFC3516] in FETCH and
+APPEND commands.
+This is useful for binary attachments for instance, as it avoids the
+overhead caused by base64 encodings.  Moreover if the IMAP COMPRESS
+extension is enabled, full flush points are placed around large non-text
+literals to empty the compression dictionary.
+This option is only available in the default section, and is ignored if
+either server does not advertize \(lqBINARY\(rq in its capability list.
+(Default: \(lqYES\(rq.)
+
+.SH SUPPORTED EXTENSIONS
+
+Performance is better for servers supporting the following extensions to
+the IMAP4rev1 [RFC3501] protocol:
+
+.IP \[bu]
+LITERAL+ [RFC2088] non-synchronizing literals (recommended),
+.IP \[bu]
+MULTIAPPEND [RFC3502] (recommended),
+.IP \[bu]
+COMPRESS=DEFLATE [RFC4978] (recommended),
+.IP \[bu]
+SASL-IR [RFC4959] SASL Initial Client Response,
+.IP \[bu]
+UNSELECT [RFC3691], and
+.IP \[bu]
+BINARY [RFC3516].
+
 .SH KNOWN BUGS AND LIMITATIONS
 
 .IP \[bu]
@@ -329,10 +369,14 @@ a message is moved to another mailbox (using the MOVE command from
 [RFC6851] or COPY + STORE + EXPUNGE), moving a messages causes
 \fBInterIMAP\fR to believe that it was deleted while another one (which
 is replicated again) was added to the other mailbox in the meantime.
-
 .IP \[bu]
 \(lqPLAIN\(rq and \(lqLOGIN\(rq are the only authentication mechanisms
 currently supported.
+.IP \[bu]
+\fBInterIMAP\fR will probably not work with non RFC-compliant servers.
+In particular, no work-around are currently implemented beside the
+tunable in the configuration file.  Morever, few IMAP servers have been
+tested so far.
 
 .SH AUTHOR
 Written by Guilhem Moulin
diff --git a/interimap.sample b/interimap.sample
index 296f766..b0f619a 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -2,10 +2,12 @@
 #list-mailbox = "*"
 list-select-opts = SUBSCRIBED
 ignore-mailbox = ^virtual/
+#use-binary = YES
 
 [local]
 type = tunnel
 command = /usr/lib/dovecot/imap
+null-stderr = YES
 
 [remote]
 # type = imaps
@@ -13,6 +15,7 @@ host = imap.guilhem.org
 # port = 993
 username = guilhem
 password = xxxxxxxxxxxxxxxx
+#compress = YES
 
 # SSL options
 #SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 97756f4..6012049 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,11 +20,13 @@ package Net::IMAP::InterIMAP v0.0.1;
 use warnings;
 use strict;
 
+use Compress::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
 use Config::Tiny ();
+use Errno 'EWOULDBLOCK';
 use IO::Select ();
 use List::Util 'first';
-use Socket 'SO_KEEPALIVE';
 use POSIX ':signal_h';
+use Socket 'SO_KEEPALIVE';
 
 use Exporter 'import';
 BEGIN {
@@ -47,6 +49,8 @@ my %OPTIONS = (
     password => qr/\A([\x01-\x7F]+)\z/,
     auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
     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_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
     SSL_cipher_list => qr/\A(\P{Control}+)\z/,
     SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
@@ -210,10 +214,6 @@ our $IMAP_text;
 #
 #   - 'name': An optional instance name to include in log messages.
 #
-#   - 'extra-attrs': An attribute or list of extra attributes to FETCH
-#     when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
-#     BODY.PEEK[]).
-#
 #   - 'logger-fd': An optional filehandle to use for debug output.
 #
 sub new($%) {
@@ -225,6 +225,11 @@ sub new($%) {
     # (cf RFC 3501 section 3)
     $self->{_STATE} = '';
 
+    # in/out buffer counts and output stream
+    $self->{_INCOUNT}  = $self->{_INRAWCOUNT}  = 0;
+    $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
+    $self->{_OUTBUF} = '';
+
     if ($self->{type} eq 'tunnel') {
         my $command = $self->{command} // $self->fail("Missing tunnel command");
 
@@ -232,7 +237,6 @@ sub new($%) {
         pipe my $rd, $self->{STDIN}  or $self->panic("Can't pipe: $!");
 
         my $pid = fork // $self->panic("Can't fork: $!");
-
         unless ($pid) {
             # children
             foreach (\*STDIN, \*STDOUT, $self->{STDIN}, $self->{STDOUT}) {
@@ -241,12 +245,24 @@ sub new($%) {
             open STDIN,  '<&', $rd or $self->panic("Can't dup: $!");
             open STDOUT, '>&', $wd or $self->panic("Can't dup: $!");
 
+            my $stderr2;
+            if (uc ($self->{'null-stderr'} // 'NO') eq 'YES') {
+                open $stderr2, '>&', *STDERR;
+                open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
+            }
+
             my $sigset = POSIX::SigSet::->new(SIGINT);
             my $oldsigset = POSIX::SigSet::->new();
-
             sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!");
 
-            exec $command or $self->panic("Can't exec: $!");
+            unless (exec $command) {
+                my $err = $!;
+                if (defined $stderr2) {
+                    close STDERR;
+                    open STDERR, '>&', $stderr2;
+                }
+                $self->panic("Can't exec: $err");
+            }
         }
 
         # parent
@@ -282,6 +298,7 @@ sub new($%) {
         $self->{$_} = $socket for qw/STDOUT STDIN/;
     }
     $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
+    binmode $self->{$_} foreach qw/STDIN STDOUT/;
 
     # command counter
     $self->{_TAG} = 0;
@@ -391,8 +408,41 @@ sub new($%) {
             $self->capabilities();
         }
     }
-
     $self->{_STATE} = 'AUTH';
+
+    # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
+    if (uc ($self->{compress} // 'NO') eq 'YES') {
+        my @supported = qw/DEFLATE/; # supported compression algorithms
+        my @algos = grep defined, map { /^COMPRESS=(.+)/ ? uc $1 : undef } @{$self->{_CAPABILITIES}};
+        my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported;
+        if (!defined $algo) {
+            $self->warn("Couldn't find a suitable compression algorithm. Not enabling compression.");
+        }
+        else {
+            my ($d, $i);
+            my $r = $self->_send("COMPRESS $algo");
+            unless ($r eq 'NO' and $IMAP_text =~ /\ANO \[COMPRESSIONACTIVE\] /) {
+                $self->panic($IMAP_text) unless $r eq 'OK';
+
+                if ($algo eq 'DEFLATE') {
+                    my ($status, $d, $i);
+                    my %args = ( -WindowBits => 0 - MAX_WBITS );
+                    ($d, $status) = Compress::Zlib::deflateInit(%args);
+                    $self->panic("Can't create deflation stream: ", $d->msg())
+                        unless defined $d and $status == Z_OK;
+
+                    ($i, $status) = Compress::Zlib::inflateInit(%args);
+                    $self->panic("Can't create inflation stream: ", $i->msg())
+                        unless defined $i and $status == Z_OK;
+                    @$self{qw/_Z_DEFLATE _Z_INFLATE/} = ($d, $i);
+                }
+                else {
+                    $self->fail("Unsupported compression algorithm: $algo");
+                }
+            }
+        }
+    }
+
     my @extensions = !defined $self->{enable} ? ()
                    : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
                    : ($self->{enable});
@@ -411,9 +461,22 @@ sub new($%) {
 # Log out when the Net::IMAP::InterIMAP object is destroyed.
 sub DESTROY($) {
     my $self = shift;
+    $self->{_STATE} = 'LOGOUT';
+
     foreach (qw/STDIN STDOUT/) {
         $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
     }
+
+    unless ($self->{quiet}) {
+        my $msg = "Connection closed";
+        $msg .= " in=$self->{_INCOUNT}";
+        $msg .= " (raw=$self->{_INRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).")"
+          if defined $self->{_INRAWCOUNT} and $self->{_INCOUNT} > 0 and $self->{_INCOUNT} != $self->{_INRAWCOUNT};
+        $msg .= ", out=$self->{_OUTCOUNT}";
+        $msg .= " (raw=$self->{_OUTRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).")"
+          if defined $self->{_OUTRAWCOUNT} and $self->{_OUTCOUNT} > 0 and $self->{_OUTCOUNT} != $self->{_OUTRAWCOUNT};
+        $self->log($msg);
+    }
 }
 
 
@@ -686,7 +749,7 @@ sub remove_message($@) {
     my $self = shift;
     my @set = @_;
     $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
-        if $self->incapable('UIDPLUS');
+        unless $self->_capable('UIDPLUS');
 
     my $set = compact_set(@set);
     $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
@@ -718,15 +781,19 @@ sub remove_message($@) {
 # $self->append($mailbox, $mail, [...])
 #   Issue an APPEND command with the given mails.  Croak if the server
 #   did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list.
-#   Providing multiple mails is only allowed for servers advertising
-#   "MULTIAPPEND" (RFC 3502) in their CAPABILITY list.
+#   Each $mail is a hash reference with key 'RFC822' and optionally
+#   'FLAGS' and 'INTERNALDATE'.  If the server supports the "BINARY"
+#   extension (RFC 3516), the key 'RFC822' can be replaced with 'BINARY'
+#   to send the mail body as a binary literal.
+#   Providing multiple mails is only allowed for servers supporting
+#   "MULTIAPPEND" (RFC 3502).
 #   Return the list of UIDs allocated for the new messages.
 sub append($$@) {
     my $self = shift;
     my $mailbox = shift;
     return unless @_;
     $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
-        if $self->incapable('UIDPLUS');
+        unless $self->_capable('UIDPLUS');
 
     my @appends;
     foreach my $mail (@_) {
@@ -734,11 +801,14 @@ sub append($$@) {
         $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') '
             if defined $mail->{FLAGS};
         $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
-        $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822};
+        my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, '')
+                       : defined $mail->{BINARY} ? ($mail->{BINARY}, '~')
+                       : $self->panic("Missing message body in APPEND");
+        $append .= "$t\{".length($body)."\}\r\n".$body;
         push @appends, $append;
     }
     $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.")
-        if $#appends > 0 and $self->incapable('MULTIAPPEND');
+        unless $#appends == 0 or $self->_capable('MULTIAPPEND');
 
     # dump the cache before issuing the command if we're appending to the current mailbox
     my ($UIDNEXT, $EXISTS, $cache, %vanished);
@@ -803,7 +873,7 @@ sub fetch($$$$) {
 sub notify($@) {
     my $self = shift;
     $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
-        if $self->incapable('NOTIFY');
+        unless $self->_capable('NOTIFY');
     my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
     # Be notified of new messages with EXISTS/RECENT responses, but
     # don't receive unsolicited FETCH responses with a RFC822/BODY[].
@@ -1008,23 +1078,22 @@ sub pull_updates($;$) {
 }
 
 
-# $self->pull_new_messages($callback, @ignore)
+# $self->pull_new_messages($callback, $attrs, @ignore)
 #   FETCH new messages since the UIDNEXT found in the persistent cache
 #   (or 1 in no such UIDNEXT is found), and process each response on the
 #   fly with the callback.
+#   The list of attributes to FETCH, $attr, much contain either BODY or
+#   BINARY.
 #   If an @ignore list is supplied, then these messages are ignored from
 #   the UID FETCH range.
 #   Finally, update the UIDNEXT from the persistent cache to the value
 #   found in the internal cache.
 #   /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ!
-sub pull_new_messages($$@) {
+sub pull_new_messages($$$@) {
     my $self = shift;
+    my $attrs = shift;
     my $callback = shift;
     my @ignore = sort { $a <=> $b } @_;
-    my @attrs = !defined $self->{'extra-attrs'} ? ()
-                   : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}}
-                   : ($self->{'extra-attrs'});
-    my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]';
 
     my $mailbox = $self->{_SELECTED} // $self->panic();
 
@@ -1153,21 +1222,74 @@ sub _fingerprint_match($$$) {
 }
 
 
-# $self->_getline([$msg])
-#   Read a line from the handle and strip the trailing CRLF.
+# $self->_getline([$length])
+#   Read a line from the handle and strip the trailing CRLF, optionally
+#   after reading a literal of the given $length (default: 0).
+#   In list context, return a pair ($literal, $line); otherwise only
+#   return the $line.
 #   /!\ Don't use this method with non-blocking IO!
 sub _getline($;$) {
     my $self = shift;
-    my $msg = shift // '';
+    my $len = shift // 0;
 
-    if ($self->{STDOUT}->opened()) {
-        my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
-        $x =~ s/\r\n\z// or $self->panic($x);
-        $self->logger("S: $msg", $x) if $self->{debug};
-        return $x;
-    }
-    else {
-        undef $self;
+    my $stdout = $self->{STDOUT};
+    $self->fail("Lost connection") unless $stdout->opened();
+
+    my (@lit, @line);
+    while(1) {
+        if ($self->{_OUTBUF} eq '') {
+            # nothing cached: read some more
+            # (read at most 2^14 bytes, the maximum length of an SSL
+            # frame, to ensure to guaranty that there is no pending data)
+            my $n = $stdout->sysread(my $buf,16384,0);
+            unless (defined $n) {
+                next unless $! == EWOULDBLOCK and
+                    (ref $stdout ne 'IO::Socket::SSL' or
+                        # sysread might fail if must finish a SSL handshake first
+                        ($IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_READ() or
+                         $IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_WRITE()));
+                $self->panic("Can't read: $!")
+            }
+            $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
+            $self->{_OUTRAWCOUNT} += $n;
+
+            if (defined (my $i = $self->{_Z_INFLATE})) {
+                my ($out, $status) = $i->inflate($buf);
+                $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK;
+                $buf = $out;
+            }
+            $self->{_OUTBUF} = $buf;
+        }
+        if ($len == 0) { # read a regular line: stop after the first \r\n
+            if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) {
+                # found the EOL, we're done
+                my $lit = join '', @lit;
+                my $line = join '', @line, substr($self->{_OUTBUF}, 0, $idx);
+                $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx);
+
+                $self->{_OUTCOUNT} += length($lit) + length($line);
+                $line =~ s/\r\n\z// or $self->panic($line);
+                $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug};
+
+                return (wantarray ? ($lit, $line) : $line);
+            }
+            else {
+                push @line, $self->{_OUTBUF};
+                $self->{_OUTBUF} = '';
+            }
+        }
+        elsif ($len > 0) { # $len bytes of literal bytes to read
+            if ($len <= length($self->{_OUTBUF})) {
+                push @lit, substr($self->{_OUTBUF}, 0, $len, '');
+                $len = 0;
+            }
+            else {
+                push @lit, $self->{_OUTBUF};
+                $len -= length($self->{_OUTBUF});
+                $self->{_OUTBUF} = '';
+            }
+            next;
+        }
     }
 }
 
@@ -1203,6 +1325,98 @@ sub _update_cache_for($$%) {
 }
 
 
+# $self->_write(@data)
+#   Send the given @data to the IMAP server.
+#   Update the interal raw byte count, but the regular byte count must
+#   have been updated earlier (eg, by _send_cmd).
+sub _write($@) {
+    my $self = shift;
+    foreach (@_) {
+        next if $_ eq '';
+        $self->{STDIN}->write($_) // $self->panic("Can't write: $!");
+        $self->{_INRAWCOUNT} += length($_);
+    }
+}
+
+
+# $self->_z_flush([$type])
+#   Flush the deflation stream, and write the compressed data.
+#   This method is a noop if no compression layer is active.
+sub _z_flush($;$) {
+    my ($self,$t) = @_;
+    my $d = $self->{_Z_DEFLATE} // return;
+    my ($out, $status) = $d->flush($t);
+    $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+    $self->_write($out);
+}
+
+
+# $self->_send_cmd($tag, $command)
+#   Send the given $command to the IMAP server.
+#   If $command contains literals and the server supportes LITERAL+,
+#   non-synchronizing literals are sent instead.
+#   If a compression layer is active, $command is compressed before
+#   being send.
+sub _send_cmd($) {
+    my ($self, $tag, $command) = @_;
+    my $litplus = $self->_capable('LITERAL+') ? 1 : 0;
+    my $d = $self->{_Z_DEFLATE};
+
+    my ($offset, $litlen) = (0, 0);
+    my $z_flush = 0; # whether to flush the dictionary after processing the next literal
+
+    while(1) {
+        my $lit = substr($command, $offset, $litlen) if $litlen > 0;
+        $offset += $litlen;
+
+        my ($line, $z_flush2);
+        my $idx = index($command, "\n", $offset);
+        if ($idx < 0) {
+            $line = substr($command, $offset);
+        }
+        else {
+            $line = substr($command, $offset, $idx-1-$offset);
+            $litlen = $litplus ? ($line =~ s/\{([0-9]+)\}\z/{$1+}/ ? $1 : $self->panic())
+                               : ($line =~  /\{([0-9]+)\}\z/       ? $1 : $self->panic());
+            $z_flush2 = ($litlen > 4096 and                     # large literal
+                (uc ($self->{'use-binary'} // 'YES') eq 'NO'
+                        or $line =~ /~\{[0-9]+\}\z/)            # literal8, RFC 3516 BINARY
+            ) ? 1 : 0;
+        }
+        $self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug};
+
+        my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n");
+        $self->{_INCOUNT} += length($_) foreach @data;
+        if (!defined $d) {
+            $self->_write(@data);
+        }
+        else {
+            for (my $i = 0; $i <= $#data; $i++) {
+                $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
+
+                my ($out, $status) = $d->deflate($data[$i]);
+                $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
+                $self->_write($out);
+
+                $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
+            }
+        }
+
+        if (!$litplus or $idx < 0) {
+            $self->_z_flush(Z_SYNC_FLUSH) if defined $d;
+
+            $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
+            last if $idx < 0;
+            my $x = $self->_getline();
+            $x =~ /\A\+ / or $self->panic($x);
+        }
+
+        $z_flush = $z_flush2;
+        $offset = $idx+1;
+    }
+}
+
+
 # $self->_send($command, [$callback])
 #   Send the given $command to the server, then wait for the response.
 #   (The status condition and response text are respectively placed in
@@ -1221,32 +1435,7 @@ sub _send($$;&) {
     # literals, mark literals as such and then the whole command in one
     # go, otherwise send literals one at a time
     my $tag = sprintf '%06d', $self->{_TAG}++;
-    my $litplus;
-    my @command = ("$tag ");
-    my $dbg_cmd = "C: $command[0]";
-    while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
-        my ($str, $len) = ($1, $2);
-        my $lit = substr $command, 0, $len, ''; # consume the literal
-
-        $litplus //= $self->_capable('LITERAL+') ? '+' : '';
-        push @command,       $str, "{$len$litplus}", "\r\n";
-        $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
-        $dbg_cmd = 'C: [...]';
-
-        unless ($litplus) {
-            $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
-            $self->{STDIN}->flush();
-            my $x = $self->_getline();
-            $x =~ /\A\+ / or $self->panic($x);
-            @command = ();
-        }
-        push @command, $lit;
-    }
-    push @command, $command, "\r\n";
-    $self->logger($dbg_cmd, $command) if $self->{debug};
-    $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
-    $self->{STDIN}->flush();
-
+    $self->_send_cmd($tag, $command);
 
     my $r;
     # wait for the answer
@@ -1443,9 +1632,7 @@ sub _string($$) {
     }
     elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
         # literal
-        $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
-        # read a the rest of the response
-        $$stream = $self->_getline('[...]');
+        (my $lit, $$stream) = $self->_getline($1);
         return $lit;
     }
     else {
@@ -1602,6 +1789,14 @@ sub _resp($$;$$$) {
                 elsif (s/\A(?:RFC822|BODY\[\]) //) {
                     $mail{RFC822} = $self->_nstring(\$_);
                 }
+                elsif (s/\ABINARY\[\] //) {
+                    if (s/\A~\{([0-9]+)\}\z//) { # literal8, RFC 3516 BINARY
+                        (my $lit, $_) = $self->_getline($1);
+                        $mail{BINARY} = $lit;
+                    } else {
+                        $mail{RFC822} = $self->_nstring(\$_);
+                    }
+                }
                 elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
                     $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
                 }
@@ -1611,7 +1806,7 @@ sub _resp($$;$$$) {
             my $uid = $mail{UID} // $self->panic(); # sanity check
             $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
 
-            if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
+            if (!exists $mail{RFC822} and !exists $mail{BINARY} and !exists $mail{ENVELOPE} and # ignore new mails
                 (!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};
@@ -1647,8 +1842,10 @@ sub _resp($$;$$$) {
         if (defined $callback and $cmd eq 'AUTHENTICATE') {
             my $x = $callback->($_);
             $self->logger("C: ", $x) if $self->{debug};
-            $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
-            $self->{STDIN}->flush();
+            $x .= "\r\n";
+            $self->{_INCOUNT} += length($x);
+            $self->_write($x);
+            $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
         }
     }
     else {