diff options
Diffstat (limited to 'lib/Net/IMAP/Sync.pm')
| -rw-r--r-- | lib/Net/IMAP/Sync.pm | 1617 |
1 files changed, 0 insertions, 1617 deletions
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 <guilhem@fripost.org> -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see <http://www.gnu.org/licenses/>. -#---------------------------------------------------------------------- - -package Net::IMAP::Sync v0.0.1; -use warnings; -use strict; - -use Config::Tiny (); -use 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 <UIDNEXT, the message with UID UIDNEXT-1 may -# have been deleted hence may no longer be present in $mailbox. -# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been -# processed. (Note however that new messages may have a lower -# MODSEQ.) Always present when UIDNEXT is present. -sub set_cache($$%) { - my $self = shift; - my $mailbox = shift // $self->panic(); - my $cache = $self->{_PCACHE}->{$mailbox} //= {}; - - my %status = @_; - while (my ($k, $v) = each %status) { - if ($k eq 'UIDVALIDITY') { - # try to detect UIDVALIDITY changes early (before starting the sync) - $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", - "Need to invalidate the UID cache.") - if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; - } - $cache->{$k} = $v; - } - - $self->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; |