diff options
-rw-r--r-- | Changelog | 4 | ||||
-rwxr-xr-x | interimap | 16 | ||||
-rw-r--r-- | interimap.1 | 12 | ||||
-rw-r--r-- | interimap.sample | 1 | ||||
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 76 |
5 files changed, 77 insertions, 32 deletions
@@ -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 @@ -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}; |