Add support for the Binary Content extension [RFC3516].

Unfortunately as of Debian Wheezy it doesn't work for Dovecot with
COMPRESS=DEFLATE [RFC4978] and non-synchronizing literals.

    perl -e 'use Compress::Raw::Zlib;
             print "a COMPRESS DEFLATE\r\n";
             sleep 1;
             my $d = new Compress::Raw::Zlib::Deflate( -WindowBits => -15 );
             $d->deflate("b APPEND TRASH ~{1+}\r\nx\r\n", my $buf);
             print $buf;
             $d->flush($buf, Z_SYNC_FLUSH);
             print $buf;
             sleep 1;
    ' | /usr/lib/dovecot/imap
    imap(guilhem): Panic: stream doesn't support seeking backwards

Interestingly, it works just fine for non-binary literals:

    perl -e 'use Compress::Raw::Zlib;
             print "a COMPRESS DEFLATE\r\n";
             sleep 1;
             my $d = new Compress::Raw::Zlib::Deflate( -WindowBits => -15 );
             $d->deflate("b APPEND TRASH {1+}\r\nx\r\n", my $buf);
             print $buf;
             $d->flush($buf, Z_SYNC_FLUSH);
             print $buf;
             sleep 1;
    ' | /usr/lib/dovecot/imap

However I can't reproduce the problem Dovecot 2.2.18 and Debian Sid (but
it doesn't help to install Dovecot from testing to my Wheezy box.)

5 files changed, 77 insertions, 32 deletions

diff --git a/Changelog b/Changelog
index 23d2a17..5b010d2 100644
--- a/Changelog
+++ b/Changelog
@@ -6,6 +6,10 @@ interimap (0.2) upstream
     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
 
diff --git a/interimap b/interimap
index af2c510..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);
 
@@ -511,6 +512,10 @@ sub sync_mailbox_list() {
 
 sync_mailbox_list();
 ($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[]';
 
 
 #############################################################################
@@ -592,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];
@@ -964,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;
@@ -1030,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}});
 
diff --git a/interimap.1 b/interimap.1
index dc3b49b..e552351 100644
--- a/interimap.1
+++ b/interimap.1
@@ -324,6 +324,18 @@ 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 KNOWN BUGS AND LIMITATIONS
 
 .IP \[bu]
diff --git a/interimap.sample b/interimap.sample
index 86d41dd..b0f619a 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -2,6 +2,7 @@
 #list-mailbox = "*"
 list-select-opts = SUBSCRIBED
 ignore-mailbox = ^virtual/
+#use-binary = YES
 
 [local]
 type = tunnel
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index db6f484..2821f98 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -214,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($%) {
@@ -753,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)");
@@ -785,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 (@_) {
@@ -801,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);
@@ -870,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[].
@@ -1075,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();
 
@@ -1398,7 +1400,8 @@ sub _send($$;&) {
 
     while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
         my ($str, $len) = ($1, $2);
-        my $lit = substr $command, 0, $len, ''; # consume the literal
+        my $lit = substr $command, 0, $len, '';   # consume the literal
+        my $bin = substr($str,-1) eq '~' ? 1 : 0; # literal8, RFC 3516 BINARY
 
         $litplus //= $self->_capable('LITERAL+') ? '+' : '';
         push @command, $self->_z_deflate($str, "{$len$litplus}", "\r\n");
@@ -1412,15 +1415,26 @@ sub _send($$;&) {
             $x =~ /\A\+ / or $self->panic($x);
             @command = ();
         }
-        if ($len <= 4096) {
-            push @command, $self->_z_deflate($lit);
-        } else {
-            # send a Z_FULL_FLUSH at the start and end of large literals,
-            # as hinted at in RFC 4978 section 4
-            # TODO only do that for non-text literals
-            push @command, $self->_z_flush(Z_FULL_FLUSH);
+        if ($len > 4096 and (!$self->{'use-binary'} or $bin) and defined (my $d = $self->{_Z_DEFLATE})) {
+            my ($status, $buf);
+            # send a Z_FULL_FLUSH at the start and end of large non-text
+            # literals, as hinted at in RFC 4978 section 4
+            $status = $d->flush($buf, Z_FULL_FLUSH);
+            $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+            push @command, $buf if $buf ne '';
+
+            undef $buf;
+            $status = $d->deflate($lit, $buf);
+            $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
+            push @command, $buf if $buf ne '';
+
+            undef $buf;
+            $status = $d->flush($buf, Z_FULL_FLUSH);
+            $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+            push @command, $buf if $buf ne '';
+        }
+        else {
             push @command, $self->_z_deflate($lit);
-            push @command, $self->_z_flush(Z_FULL_FLUSH);
         }
     }
     push @command, $self->_z_deflate($command, "\r\n");
@@ -1779,6 +1793,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 ] : [];
                 }
@@ -1788,7 +1810,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};