aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2018-05-10 03:35:13 +0200
committerGuilhem Moulin <guilhem@fripost.org>2018-05-10 03:40:36 +0200
commit567fc180a3e76716816ea9af5a066bad2ea8c01a (patch)
tree1c8d45bed0da8ca0a5bded4a4cee03949a0d8b33 /lib
parent7c60d18df5a87e9de3ac2baa058308587deee242 (diff)
Improve ESEARCH response parsing for full RFC 4466 compatibility.
Diffstat (limited to 'lib')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm51
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';