Merge branch 'master' into debian

1 files changed, 77 insertions, 65 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index bb27009..02ae65f 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -17,7 +17,7 @@
 #----------------------------------------------------------------------
 
 package Net::IMAP::InterIMAP v0.0.5;
-use v5.10.0;
+use v5.20.0;
 use warnings;
 use strict;
 
@@ -36,7 +36,7 @@ BEGIN {
     Net::SSLeay::SSLeay_add_ssl_algorithms();
     Net::SSLeay::randomize();
 
-    our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond
+    our @EXPORT_OK = qw/xdg_basedir read_config compact_set
                         slurp is_dirty has_new_mails/;
 }
 
@@ -61,7 +61,7 @@ my %OPTIONS = (
     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/,
+    compress => qr/\A(YES|NO)\z/i,
     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/,
@@ -203,6 +203,21 @@ sub compact_list(@) {
     return $set;
 }
 
+# with_set($set, $cmd)
+#   Split long commands over multiple subsets to avoid exceeding the server limit
+sub with_set($&) {
+    my ($set, $cmd) = @_;
+    my $max_length = 4096;
+    for (my $length = length($set); $length > $max_length;) {
+        my $l = rindex($set, ',', $max_length);
+        die unless $l > 0; # sanity check
+        $cmd->(substr($set, 0, $l));
+        $set = substr($set, ++$l);
+        $length -= $l;
+    }
+    return $cmd->($set);
+}
+
 
 # in_set($x, $set)
 #   Return true if the UID or sequence number $x belongs to the set $set.
@@ -215,7 +230,7 @@ sub in_set($$) {
             return 1 if $x == $1;
         }
         elsif ($r eq '*' or $r eq '*:*') {
-            warn "Assuming $x belongs to set $set!  (Dunno what \"*\" means.)";
+            warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
             return 1;
         }
         elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
@@ -398,7 +413,8 @@ sub new($%) {
         if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # RFC 2595 section 5.1
             $self->fail("Server did not advertise STARTTLS capability.")
                 unless grep {$_ eq 'STARTTLS'} @caps;
-            $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps';
+            $self->_send('STARTTLS');
+            $self->_start_ssl($self->{S});
 
             # refresh the previous CAPABILITY list since the previous one could have been spoofed
             delete $self->{_CAPABILITIES};
@@ -840,9 +856,10 @@ sub remove_message($@) {
     $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
         unless $self->_capable('UIDPLUS');
 
-    my $set = compact_set(@set);
-    $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
-    $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS
+    with_set(compact_set(@set), sub($) {
+        $self->_send("UID STORE $_[0] +FLAGS.SILENT (\\Deleted)");
+        $self->_send("UID EXPUNGE $_[0]"); # RFC 4315 UIDPLUS
+    });
 
     my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
 
@@ -959,7 +976,9 @@ sub append($$@) {
 #   optional $callback.
 sub fetch($$$;&) {
     my ($self, $set, $flags, $callback) = @_;
-    $self->_send("UID FETCH $set $flags", $callback);
+    return with_set($set, sub($) {
+        $self->_send("UID FETCH $_[0] $flags", $callback);
+    });
 }
 
 
@@ -1196,16 +1215,15 @@ sub pull_updates($;$) {
     my $mailbox = $self->{_SELECTED} // $self->panic();
     my $pcache = $self->{_PCACHE}->{$mailbox};
 
-    my %modified;
     $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)")
         if $full and ($pcache->{UIDNEXT} // 1) > 1;
 
-    my @missing;
+    my %modified;
     while (%{$self->{_MODIFIED}}) {
+        my @missing;
         while (my ($uid,$v) = each %{$self->{_MODIFIED}}) {
-            # don't filter on the fly (during FETCH responses) because
-            # FLAG updates can arrive while processing pull_new_messages
-            # for instance
+            # don't filter on the fly (during FETCH responses) because FLAG updates
+            # can arrive while processing pull_new_messages() for instance
             if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH
                 next unless $uid              < ($pcache->{UIDNEXT} // 1)         # out of bounds
                         and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen
@@ -1215,8 +1233,11 @@ sub pull_updates($;$) {
             }
         }
         $self->{_MODIFIED} = {};
-        $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing;
-        @missing = ();
+        # non-empty @missing indicates a discouraged (but allowed) CONDSTORE server behavior,
+        # cf. RFC 7162 sec. 3.1.3 ex. 8 and the comment in push_flag_updates() below
+        with_set(compact_set(@missing), sub($) {
+            $self->_send("UID FETCH $_[0] (MODSEQ FLAGS)")
+        }) if @missing;
     }
 
     # do that afterwards since the UID FETCH command above can produce VANISHED responses
@@ -1278,7 +1299,7 @@ sub pull_new_messages($$&@) {
         $range .= "$since:4294967295";
 
         $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); # sanity check
-        $self->_send("UID FETCH $range ($attrs)", sub($) {
+        $self->fetch($range, "($attrs)", sub($) {
             my $mail = shift;
             $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID};
             $callback->($mail) if defined $callback;
@@ -1306,57 +1327,48 @@ sub push_flag_updates($$@) {
 
     my $mailbox = $self->{_SELECTED} // $self->panic();
     my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic();
-    my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)";
-
-    my %listed;
-    $self->_send($command, sub($){ $listed{shift->{UID}}++; });
 
     my %failed;
-    if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) {
-        foreach (split /,/, $1) {
-            if (/\A([0-9]+)\z/) {
-                $failed{$1} = 1;
-            }
-            elsif (/\A([0-9]+):([0-9]+)\z/) {
-                my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
-                $failed{$_} = 1 foreach ($min .. $max);
-            }
-            else {
-                $self->panic($_);
+    with_set(compact_set(@set), sub($) {
+        $self->_send("UID STORE $_[0] (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)");
+        if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) {
+            foreach (split /,/, $1) {
+                if (/\A([0-9]+)\z/) {
+                    $failed{$1} = 1;
+                } elsif (/\A([0-9]+):([0-9]+)\z/) {
+                    my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
+                    $failed{$_} = 1 foreach ($min .. $max);
+                } else {
+                    $self->panic($_);
+                }
             }
         }
-    }
+    });
 
     my @ok;
     foreach my $uid (@set) {
+        my $modified = $self->{_MODIFIED};
         if ($failed{$uid}) {
-            # $uid was listed in the MODIFIED response code
-            $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates
-            delete $self->{_MODIFIED}->{$uid} if
-                # got a FLAG update for $uid; ignore it if it's $flags
-                defined $self->{_MODIFIED}->{$uid}->[1] and
-                $self->{_MODIFIED}->{$uid}->[1] eq $flags;
-        }
-        else {
-            # $uid wasn't listed in the MODIFIED response code
-            next unless defined $self->{_MODIFIED}->{$uid}; # already stored
-            $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check
-            if ($listed{$uid} == 1) {
-                # ignore succesful update
-                delete $self->{_MODIFIED}->{$uid};
+            # $uid was listed in the MODIFIED response code from RFC 7162; will FETCH
+            # again in pull_updates(); per RFC 7162 sec. 3.1.3 $modified->{$uid} might not
+            # be defined ("nice" servers send an untagged FETCH response, cf. example 10,
+            # but they might omit it - allowed but discouraged CONDSTORE server behavior -
+            # cf. example 8)
+            $modified->{$uid} //= [ 0, undef ];
+        } elsif (defined (my $m = $modified->{$uid})) {
+            # received an untagged FETCH response, remove from the list of pending changes
+            # if the flag list was up to date (either implicitely or explicitely)
+            if (!defined $m->[1] or $m->[1] eq $flags) {
+                delete $modified->{$uid};
+                push @ok, $uid;
             }
-            elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) {
-                # got multiple FETCH responses for $uid, the last one with $flags
-                delete $self->{_MODIFIED}->{$uid};
-            }
-            push @ok, $uid;
         }
     }
 
     unless ($self->{quiet}) {
         $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok;
         $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '.
-                   "trying again later") if %failed;
+                   "will try again later") if %failed;
     }
     return keys %failed;
 }
@@ -1369,8 +1381,9 @@ sub push_flag_updates($$@) {
 sub silent_store($$$@) {
     my $self = shift;
     my $set = shift;
-    my $mod = shift;
-    $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")");
+    my $subcmd = shift . "FLAGS.SILENT";
+    my $flags = join(' ', @_);
+    with_set($set, sub($) { $self->_send("UID STORE $_[0] $subcmd ($flags)") });
 }
 
 
@@ -1383,7 +1396,7 @@ sub expunge($$) {
 
     $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
         unless $self->_capable('UIDPLUS');
-    $self->_send("UID EXPUNGE $set");
+    with_set($set, sub($) { $self->_send("UID EXPUNGE $_[0]") });
 }
 
 
@@ -1408,10 +1421,10 @@ sub _ssl_error($$@) {
 # RFC 3986 appendix A
 my $RE_IPv4 = do {
     my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/;
-    qr/$dec(?:\.$dec){3}/o };
+    qr/$dec(?:\.$dec){3}/ };
 my $RE_IPv6 = do {
     my $h16  = qr/[0-9A-Fa-f]{1,4}/;
-    my $ls32 = qr/$h16:$h16|$RE_IPv4/o;
+    my $ls32 = qr/$h16:$h16|$RE_IPv4/;
     qr/                                  (?: $h16 : ){6} $ls32
       |                               :: (?: $h16 : ){5} $ls32
       | (?:                   $h16 )? :: (?: $h16 : ){4} $ls32
@@ -1421,7 +1434,7 @@ my $RE_IPv6 = do {
       | (?: (?: $h16 : ){0,4} $h16 )? ::                 $ls32
       | (?: (?: $h16 : ){0,5} $h16 )? ::                 $h16
       | (?: (?: $h16 : ){0,6} $h16 )? ::
-      /xo };
+      /x };
 
 
 # Opens a TCP socket to the given $host and $port.
@@ -1429,11 +1442,10 @@ sub _tcp_connect($$$) {
     my ($self, $host, $port) = @_;
 
     my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP);
-    if ($host =~ qr/\A$RE_IPv4\z/o) {
+    if ($host =~ qr/\A$RE_IPv4\z/) {
         $hints{family} = AF_INET;
         $hints{flags} |= AI_NUMERICHOST;
-    }
-    elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) {
+    } elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/) {
         $host = $1;
         $hints{family} = AF_INET6;
         $hints{flags} |= AI_NUMERICHOST;
@@ -1611,7 +1623,7 @@ sub _ssl_verify($$$) {
 
             my $pkey = Net::SSLeay::X509_get_X509_PUBKEY($cert);
             unless (defined $pkey and Net::SSLeay::EVP_Digest($pkey, $type) eq $digest) {
-                $self->warn("Fingerprint doesn't match!  MiTM in action?");
+                $self->warn("Fingerprint doesn't match! MiTM in action?");
                 $ok = 0;
             }
         }
@@ -2356,7 +2368,7 @@ sub _resp($$;&$$) {
             # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
             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.");
+                $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.");
             }
             # the new message was expunged before it was synced
             $self->{_NEW} = 0 if $self->{_NEW} == 1 and $cache->{EXISTS} == $1;
@@ -2407,7 +2419,7 @@ sub _resp($$;&$$) {
             /\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_);
             my %status = split / /, $1;
             $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
-            $self->panic("RFC 5465 violation!  Missing HIGHESTMODSEQ data item in STATUS response")
+            $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response")
                 if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and
                    ($cmd eq 'NOTIFY' or $cmd eq 'slurp');
             $self->_update_cache_for($mailbox, %status);