aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2018-05-09 01:14:35 +0200
committerGuilhem Moulin <guilhem@fripost.org>2018-05-09 01:14:35 +0200
commit98aa4bf1b7e58a92f069dafc8a58fe4fa8fc738a (patch)
tree897172c72352b013dec3f4594dd089292a258511 /lib/Net
parent4f55cb8d1f8f1ba7fe52e1d0035d13638ff25a00 (diff)
parentc41c280d3a1243ae445311e1ededd1dedc1484c3 (diff)
Merge branch 'master' into debian
Diffstat (limited to 'lib/Net')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm56
1 files changed, 46 insertions, 10 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 6f148b7..4a9ffd9 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -594,12 +594,15 @@ sub incapable($@) {
# $self->search($criterion)
-# Issue an UID SEARCH command with the given $criterion. Return the
-# list of matching UIDs.
+# 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"
+# indicator followed by a hash containing search data pairs.
sub search($$) {
my ($self, $crit) = @_;
my @res;
- $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_});
+ $self->_send('UID SEARCH '.$crit, sub(@) {@res = @_});
return @res
}
@@ -959,14 +962,15 @@ sub slurp($$$) {
foreach my $imap (@ready) {
my $x = $imap->_getline();
- $imap->_resp($x, sub($) {
- if ($stopwhen->($imap, shift)) {
+ $imap->_resp($x, sub($;$$) {
+ if ($stopwhen->(@_)) {
$aborted = 1;
$timeout = 0; # keep reading the handles while there is pending data
}
}, 'slurp');
}
}
+ return $aborted;
}
@@ -977,20 +981,39 @@ sub slurp($$$) {
# after the $timeout) and false otherwise.
sub idle($$$) {
my ($self, $timeout, $stopwhen) = @_;
+ my $tag = $self->idle_start($timeout);
+ my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins
+ $r += $self->idle_stop($tag, $stopwhen);
+ return $r;
+}
+# $self->idle_start()
+# Enter IDLE (RFC 2177).
+# Return the command tag.
+sub idle_start($) {
+ my $self = shift;
$self->fail("Server did not advertise IDLE (RFC 2177) capability.")
unless $self->_capable('IDLE');
my $tag = $self->_cmd_init('IDLE');
$self->_cmd_flush();
- my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins
+ return $tag;
+}
+
+# $self->idle_stop($tag, $callback)
+# Stop a running IDLE (RFC 2177) command $tag.
+# Returns the number of untagged responses received between the DONE
+# the tagged response that are satisfying $callback.
+sub idle_stop($$$) {
+ my ($self, $tag, $callback) = @_;
+ my $r = 0;
# done idling
$self->_cmd_extend('DONE');
$self->_cmd_flush();
# run the callback again to update the return value if we received
# untagged responses between the DONE and the tagged response
- $self->_recv($tag, sub($) { $r = 1 if $stopwhen->($self, shift) }, 'slurp');
+ $self->_recv($tag, sub($;$$) { $r++ if $callback->($self, @_) }, 'slurp');
return $r;
}
@@ -1922,7 +1945,9 @@ sub _send($$;&) {
$self->_recv($tag, undef, $cmd);
}
else {
- my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
+ my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1
+ : $$command =~ /\AUID SEARCH / ? "\"$tag\"" # RFC 4466's tag-string
+ : undef;
$self->_recv($tag, $callback, $cmd, $set);
}
}
@@ -2247,7 +2272,7 @@ sub _resp($$;&$$) {
$self->{_NEW} += $1 - $cache->{EXISTS} if $1 > $cache->{EXISTS}; # new mails
}
$cache->{EXISTS} = $1;
- $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp';
+ $callback->($self->{_SELECTED} // $self->panic(), EXISTS => $1) if defined $callback and $cmd eq 'slurp';
}
elsif (/\A([0-9]+) EXPUNGE\z/) {
$self->panic() unless defined $cache->{EXISTS}; # sanity check
@@ -2263,6 +2288,17 @@ sub _resp($$;&$$) {
elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
$callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
}
+ elsif (s/\AESEARCH \(TAG \Q$set\E\)( UID)?//) {
+ my $uid = $1;
+ my %ret; # RFC 4731
+ 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;
+ }
+ $callback->($uid, %ret) if defined $callback and $cmd eq 'SEARCH';
+ }
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);
my @attrs = defined $attrs ? split(/ /, $attrs) : ();
@@ -2340,7 +2376,7 @@ sub _resp($$;&$$) {
if ($cmd eq 'FETCH' or $cmd eq 'STORE') {
$callback->(\%mail) if defined $uid and in_set($uid, $set);
} elsif ($cmd eq 'slurp') {
- $callback->($self->{_SELECTED} // $self->panic())
+ $callback->($self->{_SELECTED} // $self->panic(), FETCH => $seq)
}
}
}