aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/Sync.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP/Sync.pm')
-rw-r--r--lib/Net/IMAP/Sync.pm1617
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;