Improve ESEARCH response parsing for full RFC 4466 compatibility.

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 3270108b18f4bcbdbc07158271733952d3c384da..67b3ce5a91b5c7bb27a93e2cd0f1a48e83601d54 100644 (file)
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -597,7 +597,7 @@ sub incapable($@) {
 #   Issue an UID SEARCH command with the given $criterion.  For the "normal"
 #   UID SEARCH command from RFC 3501, return the list of matching UIDs;
 #   for the extended UID SEARCH command from RFC 4731 (ensuring ESEARCH
-#   capability is the caller's responsibility), return an "UID"
+#   capability is the caller's responsibility), return an optional "UID"
 #   indicator followed by a hash containing search data pairs.
 sub search($$) {
     my ($self, $crit) = @_;
@@ -1946,7 +1946,7 @@ sub _send($$;&) {
     }
     else {
         my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1
-                : $$command =~ /\AUID SEARCH / ? "\"$tag\"" # RFC 4466's tag-string
+                : $$command =~ /\AUID SEARCH / ? $tag # for RFC 4466's tag-string
                 : undef;
         $self->_recv($tag, $callback, $cmd, $set);
     }
@@ -2234,6 +2234,21 @@ sub _envelope($$) {
     return \@envelope;
 }
 
+# Parse and consume an RFC 4466 tagged-ext-comp plus a trailing parenthesis
+sub _tagged_ext_comp($$$) {
+    my ($self, $stream, $ret) = @_;
+    my $v = $$stream =~ s/\A\(// ? $self->_tagged_ext_comp(\$_, [])
+          : $self->_astring(\$_);
+    push @$ret, $v;
+    if ($$stream =~ s/\A\)//) {
+        return $ret;
+    } elsif ($$stream =~ s/\A //) {
+        $self->_tagged_ext_comp(\$_, $ret)
+    } else {
+        $self->panic($$stream);
+    }
+}
+
 # $self->_resp($buf, [$callback, $cmd, $set] )
 #   Parse an untagged response line or a continuation request line.
 #   (The trailing CRLF must be removed.)  The internal cache is
@@ -2288,16 +2303,30 @@ sub _resp($$;&$$) {
         elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
             $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
         }
-        elsif (defined $set and s/\AESEARCH \(TAG \Q$set\E\)( UID)?//) {
-            my $uid = $1;
-            my %ret; # RFC 4731
+        elsif (s/\AESEARCH( |\z)/$1/) {
+            my $tag = $1 if s/\A \(TAG \"($RE_ASTRING_CHAR+)\"\)//;
+            my $uid = s/\A UID// ? "UID" : undef;
+            my @ret;
             while ($_ ne '') {
-                $self->fail("RFC 4731 violation in ESEARCH response")
-                    # XXX RFC 4466's tagged-ext-comp unsupported
-                    unless s/\A ($RE_ATOM_CHAR+) ([0-9,:]+)//;
-                $ret{uc $1} = $2;
+                # RFC 4466 "tagged-ext-label" is a valid RFC 3501 "atom"
+                s/\A ($RE_ATOM_CHAR+) // or $self->panic();
+                my $label = uc($1);
+                my $value;
+                if (s/\A([0-9,:]+)//) {
+                    # RFC 4466 tagged-ext-simple
+                    $value = $1;
+                } elsif (s/\A\(//) {
+                    # RFC 4466 "(" [tagged-ext-comp] ")"
+                    $value = s/\A\)// ? [] : $self->_tagged_ext_comp(\$_, []);
+                } else {
+                    $self->panic();
+                }
+                # don't use a hash since some extensions might give more
+                # than one response for a same key
+                push @ret, $label => $value;
             }
-            $callback->($uid, %ret) if defined $callback and $cmd eq 'SEARCH';
+            $callback->($uid, @ret) if defined $callback and $cmd eq 'SEARCH'
+                and defined $set and $set eq $tag;
         }
         elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) {
             my ($delim, $attrs) = ($2, $1);
@@ -2306,7 +2335,7 @@ sub _resp($$;&$$) {
             $self->panic($_) unless $_ eq '';
             $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
             undef $delim if uc $delim eq 'NIL';
-            $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim;
+            $delim =~ s/\A"(.*)"\z/$1/ if defined $delim;
             $self->_update_cache_for($mailbox, DELIMITER => $delim);
             $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs);
             $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST';