diff options
Diffstat (limited to 'lib/Net')
| -rw-r--r-- | lib/Net/IMAP/Sync.pm | 1495 |
1 files changed, 1495 insertions, 0 deletions
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm new file mode 100644 index 0000000..b952546 --- /dev/null +++ b/lib/Net/IMAP/Sync.pm @@ -0,0 +1,1495 @@ +#---------------------------------------------------------------------- +# A minimal IMAP4 client for QRESYNC-capable servers +# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/>. +#---------------------------------------------------------------------- + +package Net::IMAP::Sync v0.0.1; +use warnings; +use strict; + +use Config::Tiny (); +use List::Util 'first'; +use Socket 'SO_KEEPALIVE'; +use POSIX 'strftime'; + +use Exporter 'import'; +BEGIN { + our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/; +} + + +# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'. +my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; +my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; +my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; + +# Map each option to a regexp validating its values. +my %OPTIONS = ( + host => qr/\A([0-9a-zA-Z:.-]+)\z/, + port => qr/\A([0-9]+)\z/, + type => qr/\A(imaps?|preauth)\z/, + STARTTLS => qr/\A(true|false)\z/i, + username => qr/\A([\x01-\x7F]+)\z/, + password => qr/\A([\x01-\x7F]+)\z/, + auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, + command => qr/\A(\P{Control}+)\z/, + 'read-only' => qr/\A(TRUE|FALSE)\z/i, + SSL_ca_path => qr/\A(\P{Control}+)\z/, + SSL_cipher_list => qr/\A(\P{Control}+)\z/, + SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, +); + + +############################################################################# +# Utilities + +# read_config($conffile, $section, %opts) +# Read $conffile's default section, then $section (which takes +# precedence). %opts extends %OPTIONS and maps each option to a +# regexp validating its values. +sub read_config($$%) { + my $conffile = shift; + my $section = shift; + my %opts = (%OPTIONS, @_); + + die "No such config file $conffile\n" + unless defined $conffile and -f $conffile and -r $conffile; + + my $h = Config::Tiny::->read($conffile); + die "No such section $section\n" unless defined $h->{$section}; + + my $conf = $h->{_}; # default section + $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}}; + + # default values + $conf->{type} //= 'imaps'; + $conf->{host} //= 'localhost'; + $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; + $conf->{auth} //= 'PLAIN LOGIN'; + $conf->{STARTTLS} //= 'TRUE'; + + # untaint and validate the config + foreach my $k (keys %$conf) { + die "Invalid option $k\n" unless defined $opts{$k}; + next unless defined $conf->{$k}; + die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k}; + $conf->{$k} = $1; + } + return %$conf; +} + + +# compact_set(@set). +# Compact the UID or sequence number set @set, which must be +# non-empty and may not contain '*'. (Duplicates are allowed, but +# are removed). +sub compact_set(@) { + my @set = sort {$a <=> $b} @_; + my $min = my $max = shift @set // die 'Empty range'; + my $set; + + while (@set) { + my $k = shift @set; + if ($k < $max) { + die "Non-sorted range: $k < $max"; # sanity check + } + elsif ($k == $max) { # skip duplicates + } + elsif ($k == $max + 1) { + $max++; + } + else { + $set .= ',' if defined $set; + $set .= $min == $max ? $min : "$min:$max"; + $min = $max = $k; + } + } + + $set .= ',' if defined $set; + $set .= $min == $max ? $min : "$min:$max"; + return $set; +} + + +# in_set($x, $set) +# Return true if the UID or sequence number $x belongs to the set $set. +# /!\ The highest number in the mailbox, "*" should not appear by +# itself (other than in a range). +sub in_set($$) { + my ($x, $set) = @_; + foreach my $r (split /,/, $set) { + if ($r =~ /\A([0-9]+)\z/) { + return 1 if $x == $1; + } + elsif ($r eq '*' or $r eq '*:*') { + warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; + return 1; + } + elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) { + return 1 if $1 <= $x; + } + elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) { + my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1); + return 1 if $min <= $x and $x <= $max; + } + } + return 0; +} + + +# quote($str) +# Quote the given string if needed, or make it a (synchronizing) +# literal. The literals will later be made non-synchronizing if the +# server is LITERAL+-capable (RFC 2088). +sub quote($) { + my $str = shift; + if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) { + return $str; + } + elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) { + $str =~ s/([\x22\x5C])/\\$1/g; + return "\"$str\""; + } + else { + return "{".length($str)."}\r\n".$str; + } +} + + + +############################################################################# +# Public interface +# /!\ While this module can be used with non QRESYNC-capable (or non +# QRESYNC-enabled) servers, there is no internal cache mapping sequence +# numbers to UIDs, so EXPUNGE responses are ignored. + +# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status +# ('OK'/'NO'/'BAD') condition for the last command issued. +our $IMAP_cond; + +# The response text for the last command issued (prefixed with the status +# condition but without the tag). +our $IMAP_text; + + +# Create a new Net::IMAP::Sync object. Connect to the server, +# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and +# update the CAPABILITY list. +# In addition to the %OPTIONS above, valid parameters include: +# +# - 'debug': Enable debug messages. +# +# - 'enable': An extension or array reference of extensions to ENABLE +# (RFC 5161) after entering AUTH state. Croak if the server did not +# advertize "ENABLE" in its CAPABILITY list or does not reply with +# an untagged ENABLED response with all the given extensions. +# +# - 'STDERR': Where to log debug and informational messages (default: +# STDERR) +# +# - 'name': An optional instance name to include in log messages. +# +# - 'read-only': Use only commands that don't modify the server state. +# In particular, use EXAMINE in place of SELECT for mailbox +# selection. +# +# - 'extra-attrs': An attribute or list of extra attributes to FETCH +# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE +# BODY.PEEK[]). +# +sub new($%) { + my $class = shift; + my $self = { @_ }; + bless $self, $class; + + if ($self->{type} eq 'preauth') { + require 'IPC/Open2.pm'; + my $command = $self->{command} // $self->fail("Missing preauth command"); + my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, split(/ /, $command)) + or $self->panic("Can't fork: $!"); + } + else { + my %args = (Proto => 'tcp', Blocking => 1); + $args{PeerHost} = $self->{host} // $self->fail("Missing option host"); + $args{PeerPort} = $self->{port} // $self->fail("Missing option port"); + + my $socket; + if ($self->{type} eq 'imap') { + require 'IO/Socket/INET.pm'; + $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@"); + } + else { + my $fpr = delete $self->{SSL_fingerprint}; + $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; + require 'IO/Socket/SSL.pm'; + $socket = IO::Socket::SSL->new(%args) + or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); + + # ensure we're talking to the right server + $self->_fingerprint_match($socket, $fpr) if defined $fpr; + } + + $socket->sockopt(SO_KEEPALIVE, 1); + $self->{$_} = $socket for qw/STDOUT STDIN/; + } + $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!"); + + # command counter + $self->{_TAG} = 0; + + # internal cache, constantly updated to reflect the current server + # state for each mailbox + $self->{_CACHE} = {}; + + # persistent cache, describing the last clean (synced) state + $self->{_PCACHE} = {}; + + # list of UIDs for which the server a VANISHED or VANISHED (EARLIER) + # response. /!\ requires a QRESYNC-capable server! + # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} + # are considered. + $self->{_VANISHED} = []; + + # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH + # response with the FLAGS attribute. The \Recent flag is always + # omitted from the FLAG list. MODSEQ is always present, and the + # value [ MODSEQ, FLAGS ] is updated if another FETCH response with + # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG + # list of the message is considered unknown and should be retrieved + # manually. + # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} + # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} + # are considered. + $self->{_MODIFIED} = {}; + + # whether we're allowed to to use read-write command + $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1; + + # where to log + $self->{STDERR} //= \*STDERR; + + # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' + # (cf RFC 3501 section 3) + $self->{_STATE} = ''; + + # wait for the greeting + my $x = $self->_getline(); + $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x); + $IMAP_cond = $1; + $IMAP_text = $1.' '.$x; + + # try to update the cache (eg, capabilities) + $self->_resp_text($x); + + if ($IMAP_cond eq 'OK') { + # login required + $self->{_STATE} = 'UNAUTH'; + my @caps = $self->capabilities(); + + if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'FALSE') { # RFC 2595 section 5.1 + $self->fail("Server did not advertize STARTTLS capability.") + unless grep {$_ eq 'STARTTLS'} @caps; + + require 'IO/Socket/SSL.pm'; + $self->_send('STARTTLS'); + + my $fpr = delete $self->{SSL_fingerprint}; + my %sslargs = %$self{ grep /^SSL_/, keys %$self }; + IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs) + or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); + + # ensure we're talking to the right server + $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr; + + # refresh the previous CAPABILITY list since the previous one could have been spoofed + delete $self->{_CAPABILITIES}; + @caps = $self->capabilities(); + } + + $self->fail("Logins are disabled.") if grep {$_ eq 'LOGINDISABLED'} @caps; + my @mechs = grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps; + my $mech = (grep defined, map {my $m = $_; grep {$m eq $_} @mechs ? $m : undef} + split(/ /, $self->{auth}))[0]; + $self->fail("Failed to choose an authentication mechanism") unless defined $mech; + + my ($command, $callback); + my ($username, $password) = @$self{qw/username password/}; + + if ($mech eq 'LOGIN') { + $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; + $command = join ' ', 'LOGIN', quote($username), quote($password); + } + elsif ($mech eq 'PLAIN') { + require 'MIME/Base64.pm'; + $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; + $command = "AUTHENTICATE $mech"; + my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); + $callback = sub($) {return $credentials}; + } + else { + $self->fail("Unsupported authentication mechanism: $mech"); + } + + delete $self->{password}; # no need to remember passwords + $self->_send($command, $callback); + unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) { + # refresh the CAPABILITY list since the previous one had only pre-login capabilities + delete $self->{_CAPABILITIES}; + $self->capabilities(); + } + } + + $self->{_STATE} = 'AUTH'; + my @extensions = !defined $self->{enable} ? () + : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} + : ($self->{enable}); + if (@extensions) { + $self->fail("Server did not advertize ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); + $self->_send('ENABLE '.join(' ',@extensions)); + my @enabled = @{$self->{_ENABLED} // []}; + $self->fail("Could not ENABLE $_") foreach + grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; + } + + return $self; +} + + +# Close handles when the Net::IMAP::Sync object is destroyed. +sub DESTROY($) { + my $self = shift; + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } + $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened() + and $self->{STDERR} ne \*STDERR; +} + + +# $self->log($message, [...]) +# Log a $message. +sub log($@) { + my $self = shift; + return unless @_; + my $prefix = strftime "%b %e %H:%M:%S", localtime; + $prefix .= " $self->{name}" if defined $self->{name}; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + $prefix .= ': '; + my $stderr = $self->{STDERR}; + print $stderr $prefix, @_, "\n"; +} + + +# $self->warn($warning, [...]) +# Log a $warning. +sub warn($$@) { + my $self = shift; + $self->log('WARNING: ', @_); +} + + +# $self->fail($error, [...]) +# Log an $error and exit with return value 1. +sub fail($$@) { + my $self = shift; + $self->log('ERROR: ', @_); + exit 1; +} + + +# $self->panic($error, [...]) +# Log a fatal $error including the position of the caller, and exit +# with return value 255. +sub panic($@) { + my $self = shift; + my @loc = caller; + my $msg = "PANIC at line $loc[2] in $loc[1]"; + $msg .= ': ' if @_; + $self->log($msg, @_); + exit 255; +} + + +# $self->capabilities() +# Return the capability list of the IMAP4 server. The list is cached, +# and a CAPABILITY command is only issued if the cache is empty. +sub capabilities($) { + my $self = shift; + $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}}; + $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1'); + return @{$self->{_CAPABILITIES}}; +} + + +# $self->incapable(@capabilities) +# In list context, return the list capabilties from @capabilities +# which were NOT advertized by the server. In scalar context, return +# the length of said list. +sub incapable($@) { + my ($self, @caps) = @_; + my @mycaps = $self->capabilities(); + grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps; +} + + +# $self->search($criterion) +# Issue an UID SEARCH command with the given $criterion. Return the +# list of matching UIDs. +sub search($$) { + my ($self, $crit) = @_; + my @res; + $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_}); + return @res +} + + +# $self->select($mailbox) +# $self->examine($mailbox) +# Issue a SELECT or EXAMINE command for the $mailbox. (Always use +# EXAMINE if the 'read-only' flag is set.) Upon success, change the +# state to SELECTED, otherwise go back to AUTH. +sub select($$) { + my $self = shift; + my $mailbox = shift; + my $cmd = $self->{'read-only'} ? 'EXAMINE' : 'SELECT'; + $self->_select_or_examine($cmd, $mailbox); +} +sub examine($$) { + my $self = shift; + my $mailbox = shift; + $self->_select_or_examine('EXAMINE', $mailbox); +} + + +# $self->logout() +# Issue a LOGOUT command. Change the state to LOGOUT. +sub logout($) { + my $self = shift; + $self->_send('LOGOUT'); + $self->{_STATE} = 'LOGOUT'; + undef $self; +} + + +# $self->noop() +# Issue a NOOP command. +sub noop($) { + shift->_send('NOOP'); +} + + +# $self->create($mailbox) +# $self->delete($mailbox) +# CREATE or DELETE $mailbox. Requires the 'read-only' flag to be unset. +sub create($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("CREATE ".quote($mailbox)); +} +sub delete($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + #$self->_send("DELETE ".quote($mailbox)); + delete $self->{_CACHE}->{$mailbox}; + delete $self->{_PCACHE}->{$mailbox}; +} + + +# $self->rename($oldname, $newname) +# RENAME the mailbox $oldname to $newname. Requires the 'read-only' +# flag to be unset. +sub rename($$$) { + my ($self, $from, $to) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("RENAME ".quote($from).' '.quote($to)); + $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from}; + $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from}; +} + + +# $self->subscribe($mailbox) +# $self->unsubscribe($mailbox) +# SUBSCRIBE or UNSUBSCRIBE $mailbox. Requires the 'read-only' flag to +# be unset. +sub subscribe($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("SUBSCRIBE ".quote($mailbox)); +} +sub unsubscribe($$) { + my ($self, $mailbox) = @_; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->_send("UNSUBSCRIBE ".quote($mailbox)); +} + + +# $self->list($criterion, @parameters) +# Issue a LIST command with the given $criterion and @parameters. +# Return a pair where the first component is a hash reference of +# matching mailboxes and their flags, and the second component is a +# hash reference of matching mailboxes and their hierarchy delimiter +# (or undef for flat mailboxes). +sub list($$@) { + my $self = shift; + my $crit = shift; + my %mailboxes; + my %delims; + $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''), + sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} ); + return (\%mailboxes, \%delims); +} + + +# $self->remove($uid, [...]) +# Remove the given $uid list. Croak if the server did not advertize +# "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Successfully EXPUNGEd UIDs are removed from the pending VANISHED and +# MODIFIED lists. +# Return the list of UIDs that could not be EXPUNGEd. +sub remove($@) { + my $self = shift; + my @set = @_; + $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my $set = compact_set(@set); + $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)"); + $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS + + my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; + + my @failed; + foreach my $uid (@set) { + if (exists $vanished{$uid}) { + # ignore succesfully EXPUNGEd messages + delete $vanished{$uid}; + delete $self->{_MODIFIED}->{$uid}; + } else { + push @failed, $uid; + } + } + $self->{_VANISHED} = [ keys %vanished ]; + + $self->warn("Could not EXPUNGE UID(s) ".compact_set(@failed)) if @failed; + return @failed; +} + + +# $self->append($mailbox, RFC822, [FLAGS, [INTERNALDATE, ...]]) +# Issue an APPEND command with the given mails. Croak if the server +# did not advertize "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Providing multiple mails is only allowed for servers advertizing +# "MULTIAPPEND" (RFC 3502) in their CAPABILITY list. +# Return the list of UIDs allocated for the new messages. +sub append($$$@) { + my $self = shift; + my $mailbox = shift; + $self->fail("Server is read-only.") if $self->{'read-only'}; + $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my @appends; + while (@_) { + my $rfc822 = shift; + my $flags = shift; + my $internaldate = shift; + my $append = ''; + $append .= '('.join(' ',@$flags).') ' if defined $flags; + $append .= '"'.$internaldate.'" ' if defined $internaldate; + $append .= "{".length($rfc822)."}\r\n".$rfc822; + push @appends, $append; + } + $self->fail("Server did not advertize MULTIAPPEND (RFC 3502) capability.") + if $#appends > 0 and $self->incapable('MULTIAPPEND'); + + # dump the cache before issuing the command if we're appending to the current mailbox + my ($UIDNEXT, $EXISTS, $cache, %vanished); + if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { + $cache = $self->{_CACHE}->{$mailbox}; + $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); + $EXISTS = $cache->{EXISTS} // $self->panic(); + %vanished = map {$_ => 1} @{$self->{_VANISHED}}; + } + + $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends)); + $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text); + my ($uidvalidity, $uidset) = ($1, $2); + $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity); + + my @uids; + foreach (split /,/, $uidset) { + if (/\A([0-9]+)\z/) { + $UIDNEXT = $1 + 1 if $UIDNEXT < $1; + push @uids, $1; + } elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1); + push @uids, ($min .. $max); + $UIDNEXT = $max + 1 if $UIDNEXT < $max; + } else { + $self->panic($_); + } + } + $self->fail("$uidset contains ".scalar(@uids)." elements while " + .scalar(@appends)." messages were appended.") + unless $#uids == $#appends; + + # if $mailbox is the current mailbox we need to update the cache + if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { + # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required + my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}}; + delete $vanished2{$_} foreach keys %vanished; + my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile + $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; + $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 0) < $UIDNEXT; + } + + return @uids; +} + + +# $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 +# advertize "NOTIFY" (RFC 5465) in its CAPABILITY list. +sub notify($@) { + my $self = shift; + $self->fail("Server did not advertize NOTIFY (RFC 5465) capability.") + if $self->incapable('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'; + $self->_send($command); +} + + +# $self->slurp() +# Turn on non-blocking IO, try to as many lines as possible, then turn +# non-blocking IO back off and return the number of lines read. +# This is mostly useful when waiting for notifications while no +# command is progress, cf. RFC 5465 (NOTIFY). +sub slurp($) { + my $self = shift; + my $read = 0; + $self->{STDOUT}->blocking(0) // $self->panic("Can't turn on non-blocking IO: $!"); + while (defined (my $x = $self->_getline())) { + $self->_resp($x); + $read++ + } + $self->{STDOUT}->blocking(1) // $self->panic("Can't turn off non-blocking IO: $!"); + return $read; +} + + +# $self->set_cache( $mailbox, STATE ) +# Initialize or update the persistent cache, that is, associate a +# known $mailbox with the last known (synced) state: +# * UIDVALIDITY +# * UIDNEXT: Any message the UID of which is at least UIDNEXT is +# considered new and must be downloaded. (If 0 or missing, all +# messages in $mailbox are considered new.) Note that while all +# UIDs in the map are <UIDNEXT, the message with UID UIDNEXT-1 may +# have been deleted hence may no longer be present in $mailbox. +# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been +# processed. (Note however that new messages may have a lower +# MODSEQ.) Always present when UIDNEXT is present. +sub set_cache($$%) { + my $self = shift; + my $mailbox = shift // $self->panic(); + my $cache = $self->{_PCACHE}->{$mailbox} //= {}; + + my %status = @_; + while (my ($k, $v) = each %status) { + if ($k eq 'UIDVALIDITY') { + # try to detect UIDVALIDITY changes early (before starting the sync) + $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", + "Need to invalidate the UID cache.") + if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; + } + $cache->{$k} = $v; + } + + $self->log("Update last clean state for $mailbox: ". + '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')') + if $self->{debug}; +} + + +# $self->uidvalidity([$mailbox]) +# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to +# its UIDVALIDITY if $mailbox is omitted. +sub uidvalidity($;$) { + my $self = shift; + my $mailbox = shift; + if (defined $mailbox) { + my $cache = $self->{_CACHE}->{$mailbox} // return; + return $cache->{UIDVALIDITY}; + } + else { + my %uidvalidity; + while (my ($mbx,$cache) = each %{$self->{_CACHE}}) { + $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0; + } + return %uidvalidity; + } +} + + +# $self->set_cache(@attributes) +# Return the persistent cache for the mailbox currently selected. If +# some @attributes are given, return the list of values corresponding +# to these attributes. +# /!\ Should only be called right after pull_updates! +# Croak if there are unprocessed VANISHED responses or FLAG updates. +sub get_cache($@) { + my $self = shift; + $self->fail("Invalid method 'get_cache' in state $self->{_STATE}") + unless $self->{_STATE} eq 'SELECTED'; + my $mailbox = $self->{_SELECTED} // $self->panic(); + + $self->fail("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->fail("Pending FLAG updates!") if %{$self->{_MODIFIED}}; + + my $cache = $self->{_PCACHE}->{$mailbox}; + return @_ ? @$cache{@_} : %$cache; +} + + +# $self->is_dirty($mailbox) +# Return true if there are pending updates for $mailbox, i.e., its +# internal cache is newer than its persistent cache. +sub is_dirty($$) { + my ($self, $mailbox) = @_; + my $cache = $self->{_CACHE}->{$mailbox} // return 1; + my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; + + if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ} + and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and + defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT} + and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) { + return 0 + } else { + return 1 + } +} + + +# $self->next_dirty_mailbox(@mailboxes) +# Return the name of a dirty mailbox, or undef if all mailboxes are +# clean. If @mailbox is non-empty, only consider mailboxes in that +# list. +sub next_dirty_mailbox($@) { + my $self = shift; + my %mailboxes = map {$_ => 1} @_; + my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) } + keys %{$self->{_CACHE}}; + if ($self->{debug}) { + @dirty ? $self->log("Dirty mailboxes: ".join(', ', @dirty)) + : $self->log("Clean state!"); + } + return $dirty[0]; +} + + +# $self->pull_updates() +# Get pending updates (unprocessed VANISHED responses and FLAG +# updates), and empty these lists from the cache. +# Finally, update the HIGHESTMODSEQ from the persistent cache to the +# value found in the internal cache. +sub pull_updates($) { + my $self = shift; + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + + my (@vanished, %modified); + unless (defined $pcache->{UIDNEXT} and defined $pcache->{HIGHESTMODSEQ}) { + $self->{_MODIFIED} = {}; + $self->{_VANISHED} = []; + } + else { + my @missing; + while (%{$self->{_MODIFIED}}) { + while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { + # don't filter on the fly (during FETCH responses) because + # FLAG updates can arrive while processing pull_new_messages + # for instance + if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH + next unless $uid < $pcache->{UIDNEXT} # out of bounds + and $v->[0] > $pcache->{HIGHESTMODSEQ}; # already seen + $modified{$uid} = $v->[1]; + } else { + push @missing, $uid; + } + } + $self->{_MODIFIED} = {}; + $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; + @missing = (); + } + + # do that afterwards since the UID FETCH command above can produce VANISHED responses + my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; + my @vanished = keys %vanished; + $self->{_VANISHED} = []; + + # ignore FLAG updates on VANISHED messages + delete @modified{@vanished}; + } + + # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT + # since there might be new messages) + $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ}); + + return (\@vanished, \%modified); +} + + +# $self->pull_new_messages($callback, @ignore) +# FETCH new messages since the UIDNEXT found in the persistent cache +# (or 1 in no such UIDNEXT is found), and process each response on the +# fly with the callback. +# If an @ignore list is supplied, then these messages are ignored from +# the UID FETCH range. +# Finally, update the UIDNEXT from the persistent cache to the value +# found in the internal cache. +# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ! +sub pull_new_messages($$@) { + my $self = shift; + my $callback = shift; + my @ignore = sort { $a <=> $b } @_; + my @attrs = !defined $self->{'extra-attrs'} ? () + : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}} + : ($self->{'extra-attrs'}); + my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]'; + + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; + + my $range = ''; + my $first; + foreach my $uid (@ignore) { + if ($since < $uid) { + $first //= $since; + $range .= ',' if $range ne ''; + $range .= $since; + $range .= ':'.($uid-1) if $since < $uid-1; + $since = $uid+1; + } + elsif ($since == $uid) { + $since++; + } + } + + $first //= $since; + $range .= ',' if $range ne ''; + # 2^32-1: don't use '*' since the highest UID can be known already + $range .= "$since:4294967295"; + + my $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT}; + $self->panic() unless defined $UIDNEXT and $UIDNEXT > 0; # sanity check + + $self->_send("UID FETCH $range ($attrs)", $callback) if $first < $UIDNEXT;; + + # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ + # since there might be pending updates) + $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{UIDNEXT}); +} + + +# $self->push_flag_updates($flags, @set) +# Change the flags to each UID in @set to $flags. +# A flag update fails for mails being updated after the HIGHESTMODSEQ +# found in the persistent cache; push such messages to the MODIFIED +# list. +sub push_flag_updates($$@) { + my $self = shift; + my $flags = shift; + my @set = @_; + + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); + my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; + + my %listed; + $self->_send($command, sub(%) { my %mail = @_; $listed{$mail{UID}}++; }); + + my %failed; + if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { + foreach (split /,/, $1) { + if (/\A([0-9]+)\z/) { + $failed{$1} = 1; + } + elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); + $failed{$_} = 1 foreach ($min .. $max); + } + else { + $self->panic($_); + } + } + } + + foreach my $uid (@set) { + if ($failed{$uid}) { + # $uid was listed in the MODIFIED response code + $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates + delete $self->{_MODIFIED}->{$uid} if + # got a FLAG update for $uid; ignore it if it's $flags + defined $self->{_MODIFIED}->{$uid}->[1] and + $self->{_MODIFIED}->{$uid}->[1] eq $flags; + } + else { + # $uid wasn't listed in the MODIFIED response code + next unless defined $self->{_MODIFIED}->{$uid}; # already stored + $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check + if ($listed{$uid} == 1) { + # ignore succesful update + delete $self->{_MODIFIED}->{$uid}; + } + elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) { + # got multiple FETCH responses for $uid, the last one with $flags + delete $self->{_MODIFIED}->{$uid}; + } + } + } + return keys %failed; +} + + +############################################################################# +# Private methods + + +# $self->_fingerprint_match($socket, $fingerprint) +# Croak unless the fingerprint of the peer certificate of the +# IO::Socket::SSL object doesn't match the given $fingerprint. +sub _fingerprint_match($$$) { + my ($self, $socket, $fpr) = @_; + + my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; + my $fpr2 = $socket->get_fingerprint($algo); + $fpr =~ s/.*\$//; + $fpr2 =~ s/.*\$//; + $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2; +} + + +# $self->_getline([$msg]) +# Read a line from the handle and strip the trailing CRLF. +sub _getline($;$) { + my $self = shift; + my $msg = shift // ''; + + my $x = $self->{STDOUT}->getline() // return; # non-blocking IO + $x =~ s/\r\n\z// or $self->panic($x); + $self->log("S: $msg", $x) if $self->{debug}; + return $x; +} + + +# $self->_update_cache( ATTRIBUTE => VALUE, [...] ) +# Update the internal cache for the currently selected mailbox with +# the given attributes and values. +sub _update_cache($%) { + my $self = shift; + $self->_update_cache_for($self->{_SELECTED}, @_); +} + + +# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] ) +# Update the internal cache for $mailbox with the given attributes and +# values. +sub _update_cache_for($$%) { + my $self = shift; + my $mailbox = shift // $self->panic(); + my $cache = $self->{_CACHE}->{$mailbox} //= {}; + + my %status = @_; + while (my ($k, $v) = each %status) { + if ($k eq 'UIDVALIDITY') { + # try to detect UIDVALIDITY changes early (before starting the sync) + $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", + "Need to invalidate the UID cache.") + if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; + $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v; + } + $cache->{$k} = $v; + } +} + + +# $self->_send($command, [$callback]) +# Send the given $command to the server, then wait for the response. +# (The status condition and response text are respectively placed in +# $IMAP_cond and $IMAP_text.) Each untagged response received in the +# meantime is read, parsed and processed. The optional $callback, if +# given, is executed with all untagged responses associated with the +# command. +# In void context, croak unless the server answers with a tagged 'OK' +# response. Otherwise, return the condition status ('OK'/'NO'/'BAD'). +sub _send($$;&) { + my ($self, $command, $callback) = @_; + 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; + + # send the command; for servers supporting non-synchronizing + # literals, mark literals as such and then the whole command in one + # go, otherwise send literals one at a time + my $tag = sprintf '%06d', $self->{_TAG}++; + my $prefix = $tag.' '; + while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { + my ($str, $len) = ($1, $2); + my $lit = substr $command, 0, $len, ''; # consume the literal + + if ($self->_capable('LITERAL+')) { # RFC 2088 LITERAL+ + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len+}") if $self->{debug}; + $self->{STDIN}->print($prefix, $str, "{$len+}\r\n"); + } + else { + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len}") if $self->{debug}; + $self->{STDIN}->print($prefix, $str, "{$len}\r\n"); + $self->{STDIN}->flush(); + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + } + $self->{STDIN}->print($lit); + $prefix = ''; + } + $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $command) if $self->{debug}; + $self->{STDIN}->print($prefix, $command, "\r\n"); + $self->{STDIN}->flush(); + + my $r; + # wait for the answer + while (defined($_ = $self->_getline())) { + if (s/\A\Q$tag\E (OK|NO|BAD) //) { + $IMAP_cond = $1; + $IMAP_text = $1.' '.$_; + $self->_resp_text($_); + $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK'; + $r = $1; + last; + } + else { + $self->_resp($_, $cmd, $set, $callback); + } + } + + if (defined $self->{_SELECTED}) { + my $mailbox = $self->{_SELECTED}; + my $cache = $self->{_CACHE}->{$mailbox}; + # can't keep track of the modification sequences + $self->fail("Mailbox $mailbox doesn't support MODSEQ.") + if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC'); + $self->fail("Mailbox $mailbox does not support persistent UIDs.") + if defined $cache->{UIDNOTSTICKY}; + } + + return $r; +} + + +# $self->_capable($capability, [...]) +# Return true if each $capability is listed in the server's CAPABILITY +# list. +sub _capable($@) { + my $self = shift; + return 0 unless defined $self->{_CAPABILITIES}; + foreach my $cap (@_) { + return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}}; + } + return 1; +} + + +# $self->_capable($extension) +# Return true if $extension has been enabled by the server, i.e., the +# server sent an untagged ENABLED response including it. +sub _enabled($$) { + my $self = shift; + my $ext = uc shift; + grep {$ext eq uc $_} @{$self->{_ENABLED} // []}; +} + + +# $self->_open_mailbox($mailbox) +# Initialize the internal and persistent caches for $mailbox, and mark +# it as selected. +sub _open_mailbox($$) { + my $self = shift; + my $mailbox = shift; + + # it is safe to wipe cached VANISHED responses or FLAG updates, + # because interesting stuff must have made the mailbox dirty so + # we'll get back to it + $self->{_VANISHED} = []; + $self->{_MODIFIED} = {}; + + $self->{_SELECTED} = $mailbox; + $self->{_CACHE}->{$mailbox} //= {}; + + # always reset EXISTS to keep track of new mails + delete $self->{_CACHE}->{$mailbox}->{EXISTS}; +} + + +# $self->_select_or_examine($command, $mailbox) +# Issue a SELECT or EXAMINE command for the $mailbox. (Always use +# EXAMINE if the 'read-only' flag is set.) Upon success, change the +# state to SELECTED, otherwise go back to AUTH. +sub _select_or_examine($$$) { + my $self = shift; + my $command = shift; + my $mailbox = shift; + + my $pcache = $self->{_PCACHE}->{$mailbox} //= {}; + my $cache = $self->{_CACHE}->{$mailbox} //= {}; + $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY}; + + $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive + $command .= ' '.quote($mailbox); + $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " + ."1:".($pcache->{UIDNEXT}-1)."))" + if $self->_enabled('QRESYNC') and + ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 0) > 0; + + if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { + # A mailbox is currently selected and the server advertizes + # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox + # selection until the [CLOSED] response code has been received: + # all responses before the [CLOSED] response code refer to the + # previous mailbox ($self->{_SELECTED}), while all subsequent + # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. + $self->{_SELECTED_DELAYED} = $mailbox; + } + else { + $self->_open_mailbox($mailbox); + } + + $self->{_STATE} = 'AUTH'; + if ($self->_send($command) eq 'OK') { + $self->{_STATE} = 'SELECTED'; + } else { + delete $self->{_SELECTED}; + } +} + + + +############################################################################# +# Parsing methods +# + +# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed. +sub _resp_text($$) { + my $self = shift; + local $_ = shift; + + if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) { + print STDERR $_, "\n"; + } + elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) { + $self->fail($_); + } + elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) { + $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; + } + elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] ); + } + elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache($1 => 1); + } + elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) { + $self->_update_cache($1 => $2); + } + elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) { + # RFC 4551/7162 CONDSTORE/QRESYNC + $self->_update_cache(HIGHESTMODSEQ => $1); + } + elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) { + # RFC 4551/7162 CONDSTORE/QRESYNC + $self->_update_cache(NOMODSEQ => 1); + } + elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) { + # RFC 7162 CONDSTORE/QRESYNC + # Update the selected mailbox: previous responses refer to the + # previous mailbox ($self->{_SELECTED}), while all subsequent + # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. + my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic(); + $self->_open_mailbox($mailbox); + } + elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) { + # RFC 5465 NOTIFY + $self->fail($_); + } + elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) { + # RFC 4315 UIDPLUS + $self->_update_cache(UIDNOTSTICKY => 1); + } +} + +# Parse and consume an RFC 3501 nstring (string / "NIL"). +sub _nstring($$) { + my ($self, $stream) = @_; + return $$stream =~ s/\ANIL// ? undef : $self->_string($stream); +} + +# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string). +sub _astring($$) { + my ($self, $stream) = @_; + return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream); +} + +# Parse and consume an RFC 3501 string (quoted / literal). +sub _string($$) { + my ($self, $stream) = @_; + if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) { + # quoted + my $str = $1; + $str =~ s/\\([\x22\x5C])/$1/g; + return $str; + } + elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) { + # literal + my $count = $1; + my @acc; + my $buf; + while ($count > 0) { + my $n = $self->{STDOUT}->read($buf, $count); + push @acc, $buf; + $count -= $n; + } + $$stream = $self->_getline('[...]'); + return join ('', @acc); + } + else { + $self->panic($$stream); + } +} + +# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL". +sub _addresses($$) { + my ($self, $stream) = @_; + return undef if $$stream =~ s/\ANIL//; + + my @addresses; + $$stream =~ s/\A\(// or $self->panic($$stream); + while ($$stream =~ s/\A ?\(//) { + my @addr; + push @addr, $self->_nstring($stream); # addr-name + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-adl + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-mailbox + $$stream =~ s/\A // or $self->panic($$stream); + push @addr, $self->_nstring($stream); # addr-host + $$stream =~ s/\A\)// or $self->panic($$stream); + push @addresses, \@addr; + } + $$stream =~ s/\A\)// or $self->panic($$stream); + return \@addresses; +} + +# Parse and consume an RFC 3501 envelope +sub _envelope($$) { + my ($self, $stream) = @_; + $$stream =~ s/\A\(// or $self->panic($$stream); + + my @envelope; + push @envelope, $self->_nstring($stream); # env-date + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-subject + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-from + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-sender + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-reply-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-cc + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_addresses($stream); # env-bcc + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-in-reply-to + $$stream =~ s/\A // or $self->panic($$stream); + push @envelope, $self->_nstring($stream); # env-message-id + + $$stream =~ s/\A\)// or $self->panic($$stream); + return \@envelope; +} + +# $self->_resp($buf, [$cmd, $callback] ) +# Parse an untagged response line or a continuation request line. +# (The trailing CRLF must be removed.) The internal cache is +# automatically updated when needed. +# If a command and callback are given, the callback is be executed +# for each (parsed) responses associated with the command. +sub _resp($$;$$$) { + my $self = shift; + local $_ = shift; + my $cmd = shift; + my $set = shift; + my $callback = shift; + my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED}; + + if (s/\A\* //) { + if (s/\ABYE //) { + exit 0; + } + elsif (s/\A(?:OK|NO|BAD) //) { + $self->_resp_text($_); + } + elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) { + $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; + } + elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) { + $cache->{FLAGS} = [ split / /, $1 ]; + } + elsif (/\A([0-9]+) RECENT\z/) { + $cache->{RECENT} = $1; + } + elsif (/\A([0-9]+) EXISTS\z/) { + # /!\ $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}; + } + $cache->{EXISTS} = $1; + } + elsif (/\A([0-9]+) EXPUNGE\z/) { + # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs + $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check + $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC'); + $cache->{EXISTS}--; # explicit EXISTS responses are optional + } + elsif (/\ASEARCH((?: [0-9]+)*)\z/) { + $callback->(split(/ /, ($1 =~ s/^ //r))) 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, $flags) = ($2, $1); + my @flags = defined $flags ? split(/ /, $flags) : (); + my $mailbox = $self->_astring(\$_); + $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; + $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST'; + } + elsif (s/\ASTATUS //) { + my $mailbox = $self->_astring(\$_); + /\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->_update_cache_for($mailbox, %status); + $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 + my ($seq, $first) = ($1, 1); + my %mail; + while ($_ ne ')') { + unless (defined $first) { + s/\A // or $self->panic($_); + } + if (s/\AUID ([0-9]+)//) { + # always present, cf RFC 3501 section 6.4.8 + $mail{UID} = $1; + # the actual UIDNEXT is *at least* that + $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} < $1; + } + if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC + # always present in unsolicited FETCH responses if QRESYNC has been enabled + $mail{MODSEQ} = $1; + $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1; + } + elsif (s/\AENVELOPE //) { + $mail{ENVELOPE} = $self->_envelope(\$_); + } + elsif (s/\AINTERNALDATE "([^"]+)"//) { + $mail{INTERNALDATE} = $1; + } + elsif (s/\A(?:RFC822|BODY\[\]) //) { + $mail{RFC822} = $self->_nstring(\$_); + } + elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { + $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : []; + } + undef $first; + } + + my $uid = $mail{UID} // $self->panic(); # sanity check + $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check + + if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails + (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or + ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) { + 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 in_set($uid, $set); + } + elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE + $self->{_ENABLED} //= []; + push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r)); + } + elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC + my $earlier = defined $1 ? 1 : 0; + my $set = $2; + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + foreach (split /,/, $set) { + if (/\A([0-9]+)\z/) { + $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional + $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that + push @{$self->{_VANISHED}}, $1 + if defined $pcache->{UIDNEXT} and $1 < $pcache->{UIDNEXT}; + } + elsif (/\A([0-9]+):([0-9]+)\z/) { + my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); + $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional + $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that + push @{$self->{_VANISHED}}, grep {$_ < $pcache->{UIDNEXT}} ($min .. $max) + if defined $pcache->{UIDNEXT}; + } + } + } + } + elsif (s/\A\+ //) { + if (defined $callback and $cmd eq 'AUTHENTICATE') { + my $x = $callback->($_); + print STDERR "C: ", $x, "\n" if $self->{debug}; + $self->{STDIN}->print($x, "\r\n"); + $self->{STDIN}->flush(); + } + } + else { + $self->panic("Unexpected response: ", $_); + } +} + + +############################################################################# + +return 1; |