diff options
Diffstat (limited to 'lib/Net/IMAP')
| -rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 51 |
1 files changed, 40 insertions, 11 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3270108..67b3ce5 100644 --- 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'; |