From ac3e4cf6300448e9c83b45db1b769d79c6df2e38 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Sep 2015 17:36:00 +0200 Subject: =?UTF-8?q?Rename=20=E2=80=98imapsync=E2=80=99=20to=20=E2=80=98int?= =?UTF-8?q?erimap=E2=80=99.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To avoid confusion with http://imapsync.lamiral.info . --- lib/Net/IMAP/InterIMAP.pm | 1617 +++++++++++++++++++++++++++++++++++++++++++++ lib/Net/IMAP/Sync.pm | 1617 --------------------------------------------- 2 files changed, 1617 insertions(+), 1617 deletions(-) create mode 100644 lib/Net/IMAP/InterIMAP.pm delete mode 100644 lib/Net/IMAP/Sync.pm (limited to 'lib') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm new file mode 100644 index 0000000..26cfbbd --- /dev/null +++ b/lib/Net/IMAP/InterIMAP.pm @@ -0,0 +1,1617 @@ +#---------------------------------------------------------------------- +# A minimal IMAP4 client for QRESYNC-capable servers +# Copyright © 2015 Guilhem Moulin +# +# 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 . +#---------------------------------------------------------------------- + +package Net::IMAP::InterIMAP v0.0.1; +use warnings; +use strict; + +use Config::Tiny (); +use IO::Select (); +use List::Util 'first'; +use Socket 'SO_KEEPALIVE'; + +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?|tunnel)\z/, + STARTTLS => qr/\A(YES|NO)\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/, + SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, + SSL_cipher_list => qr/\A(\P{Control}+)\z/, + SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, + SSL_ca_path => qr/\A(\P{Control}+)\z/, +); + + +############################################################################# +# Utilities + +# read_config($conffile, $sections, %opts) +# Read $conffile's default section, then each section in the array +# reference $section (which takes precedence). %opts extends %OPTIONS +# and maps each option to a regexp validating its values. +sub read_config($$%) { + my $conffile = shift; + my $sections = shift; + my %opts = (%OPTIONS, @_); + + $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile + unless $conffile =~ /\A\//; # relative path + + die "No such config file $conffile\n" + unless defined $conffile and -f $conffile and -r $conffile; + + my $h = Config::Tiny::->read($conffile); + + my %configs; + foreach my $section (@$sections) { + my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section + $configs{$section} = $conf; + + if ($section ne '_') { + die "No such section $section\n" unless defined $h->{$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} //= 'YES'; + + # 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 \%configs; +} + + +# 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::InterIMAP 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 +# advertise "ENABLE" in its CAPABILITY list or does not reply with +# an untagged ENABLED response with all the given extensions. +# +# - 'name': An optional instance name to include in log messages. +# +# - 'extra-attrs': An attribute or list of extra attributes to FETCH +# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE +# BODY.PEEK[]). +# +# - 'logger-fd': An optional filehandle to use for debug output. +# +sub new($%) { + my $class = shift; + my $self = { @_ }; + bless $self, $class; + + # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' + # (cf RFC 3501 section 3) + $self->{_STATE} = ''; + + if ($self->{type} eq 'tunnel') { + require 'IPC/Open2.pm'; + my $command = $self->{command} // $self->fail("Missing tunnel command"); + my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $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 { + require 'IO/Socket/SSL.pm'; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; + } + my $fpr = delete $self->{SSL_fingerprint}; + $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; + $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} = {}; + + if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) { + require 'POSIX.pm'; + require 'Time/HiRes.pm'; + } + + # 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 'NO') { # RFC 2595 section 5.1 + $self->fail("Server did not advertise STARTTLS capability.") + unless grep {$_ eq 'STARTTLS'} @caps; + + require 'IO/Socket/SSL.pm'; + $self->_send('STARTTLS'); + + my %sslargs; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; + } + my $fpr = delete $self->{SSL_fingerprint}; + $sslargs{$_} = $self->{$_} foreach 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(); + } + + my @mechs = ('LOGIN', 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; + $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and + grep {$_ eq 'LOGINDISABLED'} @caps; + + 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/; + my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); + $command = "AUTHENTICATE $mech"; + if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR + $command .= " $credentials"; + } else { + $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 advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); + $self->_send('ENABLE '.join(' ',@extensions)); + my @enabled = @{$self->{_ENABLED} // []}; + $self->fail("Couldn't ENABLE $_") foreach + grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; + } + + return $self; +} + + +# Log out when the Net::IMAP::InterIMAP object is destroyed. +sub DESTROY($) { + my $self = shift; + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } +} + + +# $self->log($message, [...]) +# $self->logger($message, [...]) +# Log a $message. The latter method is used to log in the 'logger-fd', and +# add timestamps. +sub log($@) { + my $self = shift; + return unless @_; + $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR; + my $prefix = defined $self->{name} ? $self->{name} : ''; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + print STDERR $prefix, ': ', @_, "\n"; +} +sub logger($@) { + my $self = shift; + return unless @_ and defined $self->{'logger-fd'}; + my $prefix = ''; + if ($self->{'logger-fd'}->fileno != fileno STDERR) { + my ($s, $us) = Time::HiRes::gettimeofday(); + $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; + } + $prefix .= defined "$self->{name}" ? $self->{name} : ''; + $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; + $self->{'logger-fd'}->say($prefix, ': ', @_); +} + + +# $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 advertised 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, [$seqs, $UIDs]) +# $self->examine($mailbox, [$seqs, $UIDs]) +# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, +# change the state to SELECTED, otherwise go back to AUTH. +# The optional $seqs and $UIDs are used as Message Sequence Match +# Data for the QRESYNC parameter to the SELECT command. +sub select($$;$$) { + my $self = shift; + my $mailbox = shift; + $self->_select_or_examine('SELECT', $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; + # don't bother if the connection is already closed + $self->_send('LOGOUT') if $self->{STDIN}->opened(); + $self->{_STATE} = 'LOGOUT'; + undef $self; +} + + +# $self->noop() +# Issue a NOOP command. +sub noop($) { + shift->_send('NOOP'); +} + + +# $self->create($mailbox, [$try]) +# $self->delete($mailbox, [$try]) +# CREATE or DELETE $mailbox. +# If try is set, print a warning but don't crash if the command fails. +sub create($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("CREATE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} +sub delete($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("DELETE ".quote($mailbox)); + delete $self->{_CACHE}->{$mailbox}; + delete $self->{_PCACHE}->{$mailbox}; + if ($IMAP_cond eq 'OK') { + $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $self->rename($oldname, $newname, [$try]) +# RENAME the mailbox $oldname to $newname. +# If $try is set, print a warning but don't crash if the command fails. +# /!\ Requires a LIST command to be issued to determine the hierarchy +# delimiter and the mailbox attributes for the original name. +sub rename($$$;$) { + my ($self, $from, $to, $try) = @_; + my ($delim, @attrs); + if ($self->{_CACHE}->{$from}) { + $delim = $self->{_CACHE}->{$from}->{DELIMITER}; + @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []}; + } + my $r = $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}; + if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) { + # on non-flat mailboxes, move children as well (cf 3501) + foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) { + my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r; + $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1}; + $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1}; + } + } + if ($IMAP_cond eq 'OK') { + $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; + } + else { + my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $self->subscribe($mailbox, [$try]) +# $self->unsubscribe($mailbox, [$try]) +# SUBSCRIBE or UNSUBSCRIBE $mailbox. +# If $try is set, print a warning but don't crash if the command fails. +sub subscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} +sub unsubscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; +} + + +# $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_message($uid, [...]) +# Remove the given $uid list. Croak if the server did not advertise +# "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 couldn't be EXPUNGEd. +sub remove_message($@) { + my $self = shift; + my @set = @_; + $self->fail("Server did not advertise 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, @expunged); + foreach my $uid (@set) { + if (exists $vanished{$uid}) { + push @expunged, $uid + } else { + push @failed, $uid; + } + } + + # ignore succesfully EXPUNGEd messages + delete @vanished{@expunged}; + delete @{$self->{_MODIFIED}}{@expunged}; + $self->{_VANISHED} = [ keys %vanished ]; + + $self->log("Removed ".($#expunged+1)." message(s), ". + "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; + $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed; + return @failed; +} + + +# $self->append($mailbox, $mail, [...]) +# Issue an APPEND command with the given mails. Croak if the server +# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list. +# Providing multiple mails is only allowed for servers advertising +# "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; + return unless @_; + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") + if $self->incapable('UIDPLUS'); + + my @appends; + foreach my $mail (@_) { + my $append = ''; + $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' + if defined $mail->{FLAGS}; + $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; + $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822}; + push @appends, $append; + } + $self->fail("Server did not advertise 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 defined $UIDNEXT and $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 defined $UIDNEXT and $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} // 1) < $UIDNEXT; + } + + $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) + unless $self->{quiet}; + return @uids; +} + + +# $self->fetch($set, $flags, [$callback]) +# Issue an UID FETCH command with the given UID $set, $flags, and +# optional $callback. +sub fetch($$$$) { + my ($self, $set, $flags, $callback) = @_; + $self->_send("UID FETCH $set $flags", $callback); +} + + +# $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($@) { + my $self = shift; + $self->fail("Server did not advertise 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->{_SEL_OUT} = IO::Select::->new($self->{STDOUT}); +} + + +# $self->slurp() +# 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 5465 (NOTIFY). +sub slurp($) { + my $self = shift; + + my $stdout = $self->{STDOUT}; + my $read = 0; + + while (1) { + # Unprocessed data within the current SSL frame would cause + # select(2) to block/timeout due to the raw socket not being + # ready. + unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) { + my ($ok) = $self->{_SEL_OUT}->can_read(0); + return $read unless defined $ok; + } + + $self->_resp( $self->_getline() ); + $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 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->logger("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->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->panic("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->logger("Dirty mailboxes: ".join(', ', @dirty)) + : $self->logger("Clean state!"); + } + return $dirty[0]; +} + + +# $self->pull_updates([$full]) +# If $full is set, FETCH FLAGS and MODSEQ for each UID up to +# UIDNEXT-1. +# 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 $full = shift // 0; + my $mailbox = $self->{_SELECTED} // $self->panic(); + my $pcache = $self->{_PCACHE}->{$mailbox}; + + my %modified; + $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") + if $full and ($pcache->{UIDNEXT} // 1) > 1; + + 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} // 1) # out of bounds + and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen + $modified{$uid} = $full ? $v : $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} grep { $_ < ($pcache->{UIDNEXT} // 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 $UIDNEXT; + do { + my $range = ''; + my $first; + my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; + 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"; + + $UIDNEXT = $self->{_CACHE}->{$mailbox}->{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; + + # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ + # since there might be pending updates) + $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); + } + # loop if new messages were received in the meantime + while ($UIDNEXT < $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($){ $listed{shift->{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($_); + } + } + } + + my @ok; + 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}; + } + push @ok, $uid; + } + } + + unless ($self->{quiet}) { + $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; + $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. + "trying again later") if %failed; + } + 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. +# /!\ Don't use this method with non-blocking IO! +sub _getline($;$) { + my $self = shift; + my $msg = shift // ''; + + if ($self->{STDOUT}->opened()) { + my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); + $x =~ s/\r\n\z// or $self->panic($x); + $self->logger("S: $msg", $x) if $self->{debug}; + return $x; + } + else { + undef $self; + } +} + + +# $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 $litplus; + my @command = ("$tag "); + my $dbg_cmd = "C: $command[0]"; + while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { + my ($str, $len) = ($1, $2); + my $lit = substr $command, 0, $len, ''; # consume the literal + + $litplus //= $self->_capable('LITERAL+') ? '+' : ''; + push @command, $str, "{$len$litplus}", "\r\n"; + $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug}; + $dbg_cmd = 'C: [...]'; + + unless ($litplus) { + $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + @command = (); + } + push @command, $lit; + } + push @command, $command, "\r\n"; + $self->logger($dbg_cmd, $command) if $self->{debug}; + $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + + + my $r; + # wait for the answer + while (1) { + my $x = $self->_getline(); + if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) { + $IMAP_cond = $1; + $IMAP_text = $1.' '.$x; + $self->_resp_text($x); + $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; + $r = $1; + last; + } + else { + $self->_resp($x, $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, [$seqs, $UIDs]) +# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, +# change the state to SELECTED, otherwise go back to AUTH. +# The optional $seqs and $UIDs are used as Message Sequence Match +# Data for the QRESYNC parameter to the $command. +sub _select_or_examine($$$;$$) { + my $self = shift; + my $command = shift; + my $mailbox = shift; + my ($seqs, $uids) = @_; + + 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); + if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { + $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " + ."1:".($pcache->{UIDNEXT}-1); + $command .= " ($seqs $uids)" if defined $seqs and defined $uids; + $command .= "))"; + } + + if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { + # A mailbox is currently selected and the server advertises + # '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'; + $self->_send($command); + $self->{_STATE} = '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/) { + $self->log($_); + } + 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 + $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!"); + # read a the rest of the response + $$stream = $self->_getline('[...]'); + return $lit; + } + 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 //) { + undef $self; + } + 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, $attrs) = ($2, $1); + my @attrs = defined $attrs ? split(/ /, $attrs) : (); + 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; + $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'; + } + 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; + } + 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}}, ($min .. $max); + } + } + } + } + elsif (s/\A\+ //) { + if (defined $callback and $cmd eq 'AUTHENTICATE') { + my $x = $callback->($_); + $self->logger("C: ", $x) if $self->{debug}; + $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!"); + $self->{STDIN}->flush(); + } + } + else { + $self->panic("Unexpected response: ", $_); + } +} + + +############################################################################# + +return 1; diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm deleted file mode 100644 index 6561a66..0000000 --- a/lib/Net/IMAP/Sync.pm +++ /dev/null @@ -1,1617 +0,0 @@ -#---------------------------------------------------------------------- -# A minimal IMAP4 client for QRESYNC-capable servers -# Copyright © 2015 Guilhem Moulin -# -# 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 . -#---------------------------------------------------------------------- - -package Net::IMAP::Sync v0.0.1; -use warnings; -use strict; - -use Config::Tiny (); -use IO::Select (); -use List::Util 'first'; -use Socket 'SO_KEEPALIVE'; - -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?|tunnel)\z/, - STARTTLS => qr/\A(YES|NO)\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/, - SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, - SSL_cipher_list => qr/\A(\P{Control}+)\z/, - SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, - SSL_ca_path => qr/\A(\P{Control}+)\z/, -); - - -############################################################################# -# Utilities - -# read_config($conffile, $sections, %opts) -# Read $conffile's default section, then each section in the array -# reference $section (which takes precedence). %opts extends %OPTIONS -# and maps each option to a regexp validating its values. -sub read_config($$%) { - my $conffile = shift; - my $sections = shift; - my %opts = (%OPTIONS, @_); - - $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile - unless $conffile =~ /\A\//; # relative path - - die "No such config file $conffile\n" - unless defined $conffile and -f $conffile and -r $conffile; - - my $h = Config::Tiny::->read($conffile); - - my %configs; - foreach my $section (@$sections) { - my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section - $configs{$section} = $conf; - - if ($section ne '_') { - die "No such section $section\n" unless defined $h->{$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} //= 'YES'; - - # 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 \%configs; -} - - -# 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 -# advertise "ENABLE" in its CAPABILITY list or does not reply with -# an untagged ENABLED response with all the given extensions. -# -# - 'name': An optional instance name to include in log messages. -# -# - 'extra-attrs': An attribute or list of extra attributes to FETCH -# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE -# BODY.PEEK[]). -# -# - 'logger-fd': An optional filehandle to use for debug output. -# -sub new($%) { - my $class = shift; - my $self = { @_ }; - bless $self, $class; - - # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' - # (cf RFC 3501 section 3) - $self->{_STATE} = ''; - - if ($self->{type} eq 'tunnel') { - require 'IPC/Open2.pm'; - my $command = $self->{command} // $self->fail("Missing tunnel command"); - my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $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 { - require 'IO/Socket/SSL.pm'; - if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { - $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; - } - my $fpr = delete $self->{SSL_fingerprint}; - $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; - $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} = {}; - - if (defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR) { - require 'POSIX.pm'; - require 'Time/HiRes.pm'; - } - - # 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 'NO') { # RFC 2595 section 5.1 - $self->fail("Server did not advertise STARTTLS capability.") - unless grep {$_ eq 'STARTTLS'} @caps; - - require 'IO/Socket/SSL.pm'; - $self->_send('STARTTLS'); - - my %sslargs; - if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { - $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; - } - my $fpr = delete $self->{SSL_fingerprint}; - $sslargs{$_} = $self->{$_} foreach 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(); - } - - my @mechs = ('LOGIN', 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; - $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and - grep {$_ eq 'LOGINDISABLED'} @caps; - - 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/; - my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); - $command = "AUTHENTICATE $mech"; - if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR - $command .= " $credentials"; - } else { - $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 advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); - $self->_send('ENABLE '.join(' ',@extensions)); - my @enabled = @{$self->{_ENABLED} // []}; - $self->fail("Couldn't ENABLE $_") foreach - grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; - } - - return $self; -} - - -# Log out 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->log($message, [...]) -# $self->logger($message, [...]) -# Log a $message. The latter method is used to log in the 'logger-fd', and -# add timestamps. -sub log($@) { - my $self = shift; - return unless @_; - $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'}->fileno != fileno STDERR; - my $prefix = defined $self->{name} ? $self->{name} : ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - print STDERR $prefix, ': ', @_, "\n"; -} -sub logger($@) { - my $self = shift; - return unless @_ and defined $self->{'logger-fd'}; - my $prefix = ''; - if ($self->{'logger-fd'}->fileno != fileno STDERR) { - my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; - } - $prefix .= defined "$self->{name}" ? $self->{name} : ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $self->{'logger-fd'}->say($prefix, ': ', @_); -} - - -# $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 advertised 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, [$seqs, $UIDs]) -# $self->examine($mailbox, [$seqs, $UIDs]) -# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, -# change the state to SELECTED, otherwise go back to AUTH. -# The optional $seqs and $UIDs are used as Message Sequence Match -# Data for the QRESYNC parameter to the SELECT command. -sub select($$;$$) { - my $self = shift; - my $mailbox = shift; - $self->_select_or_examine('SELECT', $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; - # don't bother if the connection is already closed - $self->_send('LOGOUT') if $self->{STDIN}->opened(); - $self->{_STATE} = 'LOGOUT'; - undef $self; -} - - -# $self->noop() -# Issue a NOOP command. -sub noop($) { - shift->_send('NOOP'); -} - - -# $self->create($mailbox, [$try]) -# $self->delete($mailbox, [$try]) -# CREATE or DELETE $mailbox. -# If try is set, print a warning but don't crash if the command fails. -sub create($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("CREATE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} -sub delete($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("DELETE ".quote($mailbox)); - delete $self->{_CACHE}->{$mailbox}; - delete $self->{_PCACHE}->{$mailbox}; - if ($IMAP_cond eq 'OK') { - $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $self->rename($oldname, $newname, [$try]) -# RENAME the mailbox $oldname to $newname. -# If $try is set, print a warning but don't crash if the command fails. -# /!\ Requires a LIST command to be issued to determine the hierarchy -# delimiter and the mailbox attributes for the original name. -sub rename($$$;$) { - my ($self, $from, $to, $try) = @_; - my ($delim, @attrs); - if ($self->{_CACHE}->{$from}) { - $delim = $self->{_CACHE}->{$from}->{DELIMITER}; - @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []}; - } - my $r = $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}; - if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) { - # on non-flat mailboxes, move children as well (cf 3501) - foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) { - my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r; - $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1}; - $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1}; - } - } - if ($IMAP_cond eq 'OK') { - $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; - } - else { - my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $self->subscribe($mailbox, [$try]) -# $self->unsubscribe($mailbox, [$try]) -# SUBSCRIBE or UNSUBSCRIBE $mailbox. -# If $try is set, print a warning but don't crash if the command fails. -sub subscribe($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} -sub unsubscribe($$;$) { - my ($self, $mailbox, $try) = @_; - my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); - if ($IMAP_cond eq 'OK') { - $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; - } - else { - my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; - $try ? $self->warn($msg) : $self->fail($msg); - } - return $r; -} - - -# $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_message($uid, [...]) -# Remove the given $uid list. Croak if the server did not advertise -# "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 couldn't be EXPUNGEd. -sub remove_message($@) { - my $self = shift; - my @set = @_; - $self->fail("Server did not advertise 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, @expunged); - foreach my $uid (@set) { - if (exists $vanished{$uid}) { - push @expunged, $uid - } else { - push @failed, $uid; - } - } - - # ignore succesfully EXPUNGEd messages - delete @vanished{@expunged}; - delete @{$self->{_MODIFIED}}{@expunged}; - $self->{_VANISHED} = [ keys %vanished ]; - - $self->log("Removed ".($#expunged+1)." message(s), ". - "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; - $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed; - return @failed; -} - - -# $self->append($mailbox, $mail, [...]) -# Issue an APPEND command with the given mails. Croak if the server -# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list. -# Providing multiple mails is only allowed for servers advertising -# "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; - return unless @_; - $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") - if $self->incapable('UIDPLUS'); - - my @appends; - foreach my $mail (@_) { - my $append = ''; - $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' - if defined $mail->{FLAGS}; - $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; - $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822}; - push @appends, $append; - } - $self->fail("Server did not advertise 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 defined $UIDNEXT and $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 defined $UIDNEXT and $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} // 1) < $UIDNEXT; - } - - $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) - unless $self->{quiet}; - return @uids; -} - - -# $self->fetch($set, $flags, [$callback]) -# Issue an UID FETCH command with the given UID $set, $flags, and -# optional $callback. -sub fetch($$$$) { - my ($self, $set, $flags, $callback) = @_; - $self->_send("UID FETCH $set $flags", $callback); -} - - -# $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($@) { - my $self = shift; - $self->fail("Server did not advertise 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->{_SEL_OUT} = IO::Select::->new($self->{STDOUT}); -} - - -# $self->slurp() -# 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 5465 (NOTIFY). -sub slurp($) { - my $self = shift; - - my $stdout = $self->{STDOUT}; - my $read = 0; - - while (1) { - # Unprocessed data within the current SSL frame would cause - # select(2) to block/timeout due to the raw socket not being - # ready. - unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) { - my ($ok) = $self->{_SEL_OUT}->can_read(0); - return $read unless defined $ok; - } - - $self->_resp( $self->_getline() ); - $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 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->logger("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->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; - $self->panic("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->logger("Dirty mailboxes: ".join(', ', @dirty)) - : $self->logger("Clean state!"); - } - return $dirty[0]; -} - - -# $self->pull_updates([$full]) -# If $full is set, FETCH FLAGS and MODSEQ for each UID up to -# UIDNEXT-1. -# 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 $full = shift // 0; - my $mailbox = $self->{_SELECTED} // $self->panic(); - my $pcache = $self->{_PCACHE}->{$mailbox}; - - my %modified; - $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") - if $full and ($pcache->{UIDNEXT} // 1) > 1; - - 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} // 1) # out of bounds - and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen - $modified{$uid} = $full ? $v : $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} grep { $_ < ($pcache->{UIDNEXT} // 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 $UIDNEXT; - do { - my $range = ''; - my $first; - my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; - 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"; - - $UIDNEXT = $self->{_CACHE}->{$mailbox}->{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; - - # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ - # since there might be pending updates) - $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); - } - # loop if new messages were received in the meantime - while ($UIDNEXT < $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($){ $listed{shift->{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($_); - } - } - } - - my @ok; - 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}; - } - push @ok, $uid; - } - } - - unless ($self->{quiet}) { - $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; - $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. - "trying again later") if %failed; - } - 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. -# /!\ Don't use this method with non-blocking IO! -sub _getline($;$) { - my $self = shift; - my $msg = shift // ''; - - if ($self->{STDOUT}->opened()) { - my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); - $x =~ s/\r\n\z// or $self->panic($x); - $self->logger("S: $msg", $x) if $self->{debug}; - return $x; - } - else { - undef $self; - } -} - - -# $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 $litplus; - my @command = ("$tag "); - my $dbg_cmd = "C: $command[0]"; - while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { - my ($str, $len) = ($1, $2); - my $lit = substr $command, 0, $len, ''; # consume the literal - - $litplus //= $self->_capable('LITERAL+') ? '+' : ''; - push @command, $str, "{$len$litplus}", "\r\n"; - $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug}; - $dbg_cmd = 'C: [...]'; - - unless ($litplus) { - $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - my $x = $self->_getline(); - $x =~ /\A\+ / or $self->panic($x); - @command = (); - } - push @command, $lit; - } - push @command, $command, "\r\n"; - $self->logger($dbg_cmd, $command) if $self->{debug}; - $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - - - my $r; - # wait for the answer - while (1) { - my $x = $self->_getline(); - if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) { - $IMAP_cond = $1; - $IMAP_text = $1.' '.$x; - $self->_resp_text($x); - $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; - $r = $1; - last; - } - else { - $self->_resp($x, $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, [$seqs, $UIDs]) -# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, -# change the state to SELECTED, otherwise go back to AUTH. -# The optional $seqs and $UIDs are used as Message Sequence Match -# Data for the QRESYNC parameter to the $command. -sub _select_or_examine($$$;$$) { - my $self = shift; - my $command = shift; - my $mailbox = shift; - my ($seqs, $uids) = @_; - - 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); - if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { - $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " - ."1:".($pcache->{UIDNEXT}-1); - $command .= " ($seqs $uids)" if defined $seqs and defined $uids; - $command .= "))"; - } - - if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { - # A mailbox is currently selected and the server advertises - # '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'; - $self->_send($command); - $self->{_STATE} = '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/) { - $self->log($_); - } - 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 - $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!"); - # read a the rest of the response - $$stream = $self->_getline('[...]'); - return $lit; - } - 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 //) { - undef $self; - } - 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, $attrs) = ($2, $1); - my @attrs = defined $attrs ? split(/ /, $attrs) : (); - 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; - $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'; - } - 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; - } - 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}}, ($min .. $max); - } - } - } - } - elsif (s/\A\+ //) { - if (defined $callback and $cmd eq 'AUTHENTICATE') { - my $x = $callback->($_); - $self->logger("C: ", $x) if $self->{debug}; - $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!"); - $self->{STDIN}->flush(); - } - } - else { - $self->panic("Unexpected response: ", $_); - } -} - - -############################################################################# - -return 1; -- cgit v1.2.3