From f7becde978ab43cc5859a89d82aeb69521967a2d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 11 Mar 2016 20:57:24 +0100 Subject: wibble --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 45253c1..be61cb6 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1000,7 +1000,7 @@ sub idle($;$&) { } -# $self->set_cache( $mailbox, STATE ) +# $self->set_cache($mailbox, STATE) # Initialize or update the persistent cache, that is, associate a # known $mailbox with the last known (synced) state: # * UIDVALIDITY -- cgit v1.2.3 From 5570af137725259a66043bcb747ecbdb3839a2d3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 11 Mar 2016 22:04:17 +0100 Subject: Net::IMAP::InterIMAP: Don't increase UIDNEXT when receiving EXISTS responses. Indeed, if the server sends * n EXISTS * n EXPUNGE meaning a new message is received, and is immediately removed afterwards, the server might have allocated a new UID for the removed message. --- lib/Net/IMAP/InterIMAP.pm | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index be61cb6..cdc5697 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -645,6 +645,7 @@ sub unselect($) { # we'll get back to it $self->{_VANISHED} = []; $self->{_MODIFIED} = {}; + $self->{_NEW} = 0; } @@ -1082,6 +1083,7 @@ sub get_cache($@) { # persistent cache's values. sub is_dirty($$) { my ($self, $mailbox) = @_; + return 1 if $self->{_NEW}; $self->_updated_cache($mailbox, qw/HIGHESTMODSEQ UIDNEXT/); } @@ -1091,6 +1093,7 @@ sub is_dirty($$) { # internal cache's UIDNEXT value differs from its persistent cache's. sub has_new_mails($$) { my ($self, $mailbox) = @_; + return 1 if $self->{_NEW}; $self->_updated_cache($mailbox, 'UIDNEXT'); } @@ -1181,6 +1184,7 @@ sub pull_new_messages($$&@) { my @ignore = sort { $a <=> $b } @_; my $mailbox = $self->{_SELECTED} // $self->panic(); + my $cache = $self->{_CACHE}->{$mailbox}; my $UIDNEXT; do { @@ -1205,19 +1209,20 @@ sub pull_new_messages($$&@) { # 2^32-1: don't use '*' since the highest UID can be known already $range .= "$since:4294967295"; - $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT} // $self->panic(); # sanity check + $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); # sanity check $self->_send("UID FETCH $range ($attrs)", sub($) { my $mail = shift; $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID}; $callback->($mail) if defined $callback; - }) if $first < $UIDNEXT; + }) if $first < $UIDNEXT or $self->{_NEW}; # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ # since there might be pending updates) $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); + $self->{_NEW} = 0; } # loop if new messages were received in the meantime - while ($UIDNEXT < $self->{_CACHE}->{$mailbox}->{UIDNEXT}); + while ($self->{_NEW} or $UIDNEXT < $cache->{UIDNEXT}); } @@ -1993,6 +1998,7 @@ sub _open_mailbox($$) { # we'll get back to it $self->{_VANISHED} = []; $self->{_MODIFIED} = {}; + $self->{_NEW} = 0; $self->{_SELECTED} = $mailbox; $self->{_CACHE}->{$mailbox} //= {}; @@ -2233,12 +2239,12 @@ sub _resp($$;&$$) { # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT if (defined $cache->{EXISTS}) { $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS}; - # the actual UIDNEXT is *at least* that - $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT}; + $self->{_NEW} += $1 - $cache->{EXISTS} if $1 > $cache->{EXISTS}; # new mails } $cache->{EXISTS} = $1; } elsif (/\A([0-9]+) EXPUNGE\z/) { + $self->panic() unless defined $cache->{EXISTS}; # sanity check # /!\ 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 @@ -2270,7 +2276,7 @@ sub _resp($$;&$$) { $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS'; } elsif (s/\A([0-9]+) FETCH \(//) { - $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check + $cache->{EXISTS} = $1 if $1 > $cache->{EXISTS}; my ($seq, $first) = ($1, 1); my %mail; while ($_ ne ')') { -- cgit v1.2.3 From 1b69b4b599d7acf03e426cfbb376e26bdba95c26 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 12 Mar 2016 00:50:26 +0100 Subject: Net::IMAP::InterIMAP optimisation: ignore a new message that's immediately expunged (before we had a chance to sync it) --- lib/Net/IMAP/InterIMAP.pm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index cdc5697..1686448 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -2250,6 +2250,8 @@ sub _resp($$;&$$) { $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check $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; $cache->{EXISTS}--; # explicit EXISTS responses are optional } elsif (/\ASEARCH((?: [0-9]+)*)\z/) { -- cgit v1.2.3 From d4f52ae67f007ceacfc1a3ea2d0678600b0df73d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 12 Mar 2016 00:52:04 +0100 Subject: Net::IMAP::InterIMAP: set binmode on the socket (and our pipe ends) --- lib/Net/IMAP/InterIMAP.pm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 1686448..f3e9c9e 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -313,6 +313,9 @@ sub new($%) { foreach ($rd, $wd) { close $_ or $self->panic("Can't close: $!"); } + foreach (qw/STDIN STDOUT/) { + binmode($self->{$_}) // $self->panic("binmode: $!") + } } else { foreach (qw/host port/) { @@ -338,10 +341,10 @@ sub new($%) { setsockopt($socket, Socket::IPPROTO_TCP, 18, 1000 * $cnt * $intvl) or $self->fail("Can't setsockopt TCP_USER_TIMEOUT: $!"); + binmode($socket) // $self->panic("binmode: $!"); $self->_start_ssl($socket) if $self->{type} eq 'imaps'; $self->{$_} = $socket for qw/STDOUT STDIN/; } - binmode $self->{$_} foreach qw/STDIN STDOUT/; # command counter $self->{_TAG} = 0; -- cgit v1.2.3 From 32ba1586d1c11a25ad1f947329a0edabbcbc340f Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 12 Mar 2016 00:52:42 +0100 Subject: Net::IMAP::InterIMAP: set SO_{RCV,SND}TIMEO on the socket so we can detect dead peers --- lib/Net/IMAP/InterIMAP.pm | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index f3e9c9e..e7a86aa 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -323,23 +323,12 @@ sub new($%) { } my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/}) : $self->_tcp_connect(@$self{qw/host port/}); - my ($cnt, $intvl) = (3, 5); if (defined $self->{keepalive}) { - # detect dead peers and drop the connection after 60 secs + $cnt*$intvl setsockopt($socket, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!"); setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60) or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!"); - setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPCNT, $cnt) - or $self->fail("Can't setsockopt TCP_KEEPCNT: $!"); - setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPINTVL, $intvl) - or $self->fail("Can't setsockopt TCP_KEEPINTVL: $!"); } - # Abort after 15secs if write(2) isn't acknowledged - # XXX Socket::TCP_USER_TIMEOUT isn't defined. - # `grep TCP_USER_TIMEOUT /usr/include/linux/tcp.h` gives 18 - setsockopt($socket, Socket::IPPROTO_TCP, 18, 1000 * $cnt * $intvl) - or $self->fail("Can't setsockopt TCP_USER_TIMEOUT: $!"); binmode($socket) // $self->panic("binmode: $!"); $self->_start_ssl($socket) if $self->{type} eq 'imaps'; @@ -1380,12 +1369,21 @@ sub _tcp_connect($$$) { SOCKETS: foreach my $ai (@res) { socket (my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol}) or $self->panic("connect: $!"); - # TODO: add a connection timeout - # http://devpit.org/wiki/Connect%28%29_with_timeout_%28in_Perl%29 + + # timeout connect/read/write/... after 30s + # XXX we need to pack the struct timeval manually: not portable! + # https://stackoverflow.com/questions/8284243/how-do-i-set-so-rcvtimeo-on-a-socket-in-perl + my $timeout = pack('l!l!', 30, 0); + setsockopt($s, Socket::SOL_SOCKET, Socket::SO_RCVTIMEO, $timeout) + or $self->fail("Can't setsockopt SO_RCVTIMEO: $!"); + setsockopt($s, Socket::SOL_SOCKET, Socket::SO_SNDTIMEO, $timeout) + or $self->fail("Can't setsockopt SO_RCVTIMEO: $!"); + until (connect($s, $ai->{addr})) { next if $! == EINTR; # try again if connect(2) was interrupted by a signal next SOCKETS; } + my $flags = fcntl($s, F_GETFD, 0) or $self->panic("fcntl F_GETFD: $!"); fcntl($s, F_SETFD, $flags | FD_CLOEXEC) or $self->panic("fcntl F_SETFD: $!"); return $s; -- cgit v1.2.3 From 93d2e96fde87cbeb1c32ea556c0b4d3591ec41ba Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 12 Mar 2016 01:10:30 +0100 Subject: Net::IMAP::InterIMAP: quit idling when a time jump of at least 30s is detected This forces a write, so we can better detect detect dead peers after hibernation for instance. --- lib/Net/IMAP/InterIMAP.pm | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index e7a86aa..d2bb130 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -931,14 +931,14 @@ sub notify($@) { } -# $self->slurp([$callback, $cmd]) +# $self->slurp([$callback, $cmd, $timeout]) # See if the server has sent some unprocessed data; try to as many # lines as possible, process them, and return the number of lines # read. # This is mostly useful when waiting for notifications while no # command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY). -sub slurp($;&$) { - my ($self, $callback, $cmd) = @_; +sub slurp($;&$$) { + my ($self, $callback, $cmd, $timeout) = @_; my $ssl = $self->{_SSL}; my $read = 0; @@ -949,10 +949,11 @@ sub slurp($;&$) { # cause select(2) to block/timeout due to the raw socket # not being ready. (defined $ssl and Net::SSLeay::pending($ssl) > 0)) { - my $r = CORE::select($rin, undef, undef, 0); + my $r = CORE::select($rin, undef, undef, $timeout // 0); next if $r == -1 and $! == EINTR; # select(2) was interrupted $self->panic("Can't select: $!") if $r == -1; return $read if $r == 0; # nothing more to read + $timeout = 0; # don't wait during the next select(2) calls } my $x = $self->_getline(); $self->_resp($x, $callback, $cmd); @@ -969,7 +970,7 @@ sub slurp($;&$) { sub idle($;$&) { my ($self, $timeout, $stopwhen) = @_; $timeout //= 1740; # 29 mins - my $callback = sub() {$timeout = -1 if $stopwhen->()}; + my $callback = sub() {undef $timeout if $stopwhen->()}; $self->fail("Server did not advertise IDLE (RFC 2177) capability.") unless $self->_capable('IDLE'); @@ -977,9 +978,14 @@ sub idle($;$&) { my $tag = $self->_cmd_init('IDLE'); $self->_cmd_flush(); - for (; $timeout > 0; $timeout--) { - $self->slurp($callback, 'IDLE'); - sleep 1 if $timeout > 0; + for (my $now = time;;) { + $self->slurp($callback, 'IDLE', 1); + last unless defined $timeout; + my $delta = time - $now; + $timeout -= $delta; + # quit idling when a time jump of at least 30s is detected + last if $timeout <= 0 or $delta >= 30; + $now += $delta; } # done idling @@ -989,7 +995,7 @@ sub idle($;$&) { # untagged responses between the DONE and the tagged response $self->_recv($tag, $callback, 'IDLE'); - return $timeout < 0 ? 1 : 0; + return (defined $timeout) ? 0 : 1; } -- cgit v1.2.3 From 85fd56f6f150dba0d74859a9d5e00f16d6b33955 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 12 Mar 2016 22:14:39 +0100 Subject: Net::IMAP::InterIMAP, interimap: Add support for IMAP NOTIFY [RFC 5465]. Unsollicited LIST responses are currently ignored, hence interimap won't detect mailbox creation/deletion/subcription/unsubscription. --- lib/Net/IMAP/InterIMAP.pm | 135 +++++++++++++++++++++++++--------------------- 1 file changed, 74 insertions(+), 61 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index d2bb130..a899831 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -35,7 +35,8 @@ BEGIN { Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); - our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/; + our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond + slurp is_dirty has_new_mails/; } @@ -909,93 +910,89 @@ sub fetch($$$;&) { } -# $self->notify(@specifications) -# Issue a NOTIFY command with the given mailbox @specifications (cf RFC -# 5465 section 6) to be monitored. Croak if the server did not -# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list. -sub notify($@) { +# $self->notify($arg, %specifications) +# Issue a NOTIFY command with the given $arg ("SET", "SET STATUS" or +# "NONE") and mailbox %specifications (cf RFC 5465 section 6) to be +# monitored. Croak if the server did not advertise "NOTIFY" (RFC +# 5465) in its CAPABILITY list. +sub notify($$@) { my $self = shift; $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.") unless $self->_capable('NOTIFY'); - my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/; - # Be notified of new messages with EXISTS/RECENT responses, but - # don't receive unsolicited FETCH responses with a RFC822/BODY[]. - # It costs us an extra roundtrip, but we need to sync FLAG updates - # and VANISHED responses in batch mode, update the HIGHESTMODSEQ, - # and *then* issue an explicit UID FETCH command to get new message, - # and process each FETCH response with a RFC822/BODY[] attribute as - # they arrive. - my $command = 'NOTIFY '; - $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE'; + my $command = 'NOTIFY '.shift; + while (@_) { + $command .= " (".shift." (".join(' ', @{shift()})."))"; + } $self->_send($command); } -# $self->slurp([$callback, $cmd, $timeout]) -# See if the server has sent some unprocessed data; try to as many -# lines as possible, process them, and return the number of lines -# read. +# slurp($imap, $timeout, $stopwhen) +# Keep reading untagged responses from the @$imap servers until the +# $stopwhen condition becomes true (then return true), or until the +# $timeout expires (then return false). # This is mostly useful when waiting for notifications while no # command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY). -sub slurp($;&$$) { - my ($self, $callback, $cmd, $timeout) = @_; - my $ssl = $self->{_SSL}; - my $read = 0; +sub slurp($$$) { + my ($selfs, $timeout, $stopwhen) = @_; + my $aborted = 0; + + my $rin = ''; + vec($rin, fileno($_->{STDOUT}), 1) = 1 foreach @$selfs; - vec(my $rin, fileno($self->{STDOUT}), 1) = 1; while (1) { - unless ((defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') or - # Unprocessed data within the current TLS record would - # cause select(2) to block/timeout due to the raw socket - # not being ready. - (defined $ssl and Net::SSLeay::pending($ssl) > 0)) { - my $r = CORE::select($rin, undef, undef, $timeout // 0); + # first, consider only unprocessed data without our own output + # buffer, or within the current TLS record: these would cause + # select(2) to block/timeout due to the raw socket not being + # ready. + my @ready = grep { (defined $_->{_OUTBUF} and $_->{_OUTBUF} ne '') or + (defined $_->{_SSL} and Net::SSLeay::pending($_->{_SSL}) > 0) + } @$selfs; + unless (@ready) { + my ($r, $timeleft) = CORE::select(my $rout = $rin, undef, undef, $timeout); next if $r == -1 and $! == EINTR; # select(2) was interrupted - $self->panic("Can't select: $!") if $r == -1; - return $read if $r == 0; # nothing more to read - $timeout = 0; # don't wait during the next select(2) calls + die "select: $!" if $r == -1; + return $aborted if $r == 0; # nothing more to read (timeout reached) + @ready = grep {vec($rout, fileno($_->{STDOUT}), 1)} @$selfs; + $timeout = $timeleft if $timeout > 0; + } + + foreach my $imap (@ready) { + my $x = $imap->_getline(); + $imap->_resp($x, sub($) { + if ($stopwhen->($imap, shift)) { + $aborted = 1; + $timeout = 0; # keep reading the handles while there is pending data + } + }, 'slurp'); } - my $x = $self->_getline(); - $self->_resp($x, $callback, $cmd); - $read++; } } -# $self->idle([$timeout, $stopwhen]) +# $self->idle($timeout, $stopwhen) # Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or # when the callback $stopwhen returns true. -# Return false if the timeout was reached, and true if IDLE was -# stopped due the callback. -sub idle($;$&) { +# Return true if the callback returned true (either aborting IDLE, or +# after the $timeout) and false otherwise. +sub idle($$$) { my ($self, $timeout, $stopwhen) = @_; - $timeout //= 1740; # 29 mins - my $callback = sub() {undef $timeout if $stopwhen->()}; $self->fail("Server did not advertise IDLE (RFC 2177) capability.") unless $self->_capable('IDLE'); my $tag = $self->_cmd_init('IDLE'); $self->_cmd_flush(); - - for (my $now = time;;) { - $self->slurp($callback, 'IDLE', 1); - last unless defined $timeout; - my $delta = time - $now; - $timeout -= $delta; - # quit idling when a time jump of at least 30s is detected - last if $timeout <= 0 or $delta >= 30; - $now += $delta; - } + my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins # 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, $callback, 'IDLE'); + $self->_recv($tag, sub($) { $r = 1 if $stopwhen->($self, shift) }, 'slurp'); - return (defined $timeout) ? 0 : 1; + return $r; } @@ -1920,11 +1917,11 @@ sub _send($$;&) { my $tag = $self->_cmd_init($command); $self->_cmd_flush(); + my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command; if (!defined $callback) { - $self->_recv($tag); + $self->_recv($tag, undef, $cmd); } else { - my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command; my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef; $self->_recv($tag, $callback, $cmd, $set); } @@ -2232,6 +2229,7 @@ sub _resp($$;&$$) { } elsif (s/\A(?:OK|NO|BAD) //) { $self->_resp_text($_); + $callback->($self->{_SELECTED}) if defined $self->{_SELECTED} and defined $callback and $cmd eq 'slurp'; } elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) { $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; @@ -2249,6 +2247,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'; } elsif (/\A([0-9]+) EXPUNGE\z/) { $self->panic() unless defined $cache->{EXISTS}; # sanity check @@ -2281,8 +2280,17 @@ 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") + 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); - $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS'; + if (defined $callback) { + if ($cmd eq 'STATUS') { + $callback->($mailbox, %status); + } elsif ($cmd eq 'slurp') { + $callback->($mailbox); + } + } } elsif (s/\A([0-9]+) FETCH \(//) { $cache->{EXISTS} = $1 if $1 > $cache->{EXISTS}; @@ -2328,8 +2336,13 @@ sub _resp($$;&$$) { my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS}; $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ]; } - $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and - defined $uid and in_set($uid, $set); + if (defined $callback) { + 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()) + } + } } elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE $self->{_ENABLED} //= []; @@ -2353,6 +2366,7 @@ sub _resp($$;&$$) { push @{$self->{_VANISHED}}, ($min .. $max); } } + $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp'; } } elsif (s/\A\+// and ($_ eq '' or s/\A //)) { @@ -2366,7 +2380,6 @@ sub _resp($$;&$$) { else { $self->panic("Unexpected response: ", $_); } - $callback->() if defined $callback and $cmd eq 'IDLE'; } -- cgit v1.2.3