path: root/lib/Net/IMAP/InterIMAP.pm

#----------------------------------------------------------------------
# A minimal IMAP4 client for QRESYNC-capable servers
# Copyright © 2015-2020 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 <https://www.gnu.org/licenses/>.
#----------------------------------------------------------------------

package Net::IMAP::InterIMAP v0.5.5;
use v5.20.0;
use warnings;
use strict;

use Compress::Raw::Zlib qw/Z_OK Z_STREAM_END Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
use Errno qw/EEXIST EINTR/;
use Net::SSLeay 1.86_06 ();
use List::Util qw/all first/;
use POSIX ':signal_h';
use Socket qw/SOCK_STREAM SOCK_RAW SOCK_CLOEXEC IPPROTO_TCP SHUT_RDWR
              AF_UNIX AF_INET AF_INET6 PF_UNSPEC :addrinfo/;

use Exporter 'import';
BEGIN {
    Net::SSLeay::load_error_strings();
    Net::SSLeay::SSLeay_add_ssl_algorithms();
    Net::SSLeay::randomize();

    our @EXPORT_OK = qw/xdg_basedir read_config compact_set
                        slurp is_dirty has_new_mails/;
}


# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR', 'list-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_LIST_CHAR    = qr/[\x21\x23-\x27\x2A\x2B-\x5B\x5D-\x7A\x7C-\x7E]/;
my $RE_TEXT_CHAR    = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;

my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-3])/;

# Map each option to a regexp validating its values.
my %OPTIONS = (
    host => qr/\A(\P{Control}+)\z/,
    port => qr/\A(\P{Control}+)\z/,
    proxy => qr/\A(\P{Control}+)\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/,
    'null-stderr' => qr/\A(YES|NO)\z/i,
    compress => qr/\A(YES|NO)\z/i,
    SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/, # TODO deprecated, remove in 0.6
    SSL_protocol_min => qr/\A(\P{Control}+)\z/,
    SSL_protocol_max => qr/\A(\P{Control}+)\z/,
    SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+(?: (?:[A-Za-z0-9]+\$)?\p{AHex}+)*)\z/,
    SSL_cipherlist => qr/\A(\P{Control}+)\z/,
    SSL_ciphersuites => qr/\A(\P{Control}*)\z/, # "an empty list is permissible"
    SSL_hostname => qr/\A(\P{Control}*)\z/,
    SSL_verify => qr/\A(YES|NO)\z/i,
    SSL_CApath => qr/\A(\P{Control}+)\z/,
    SSL_CAfile => qr/\A(\P{Control}+)\z/,
);

# Use the same buffer size as Net::SSLeay::read(), to ensure there is
# never any pending data left in the current TLS record
my $BUFSIZE = 32768;
my $CRLF = "\x0D\x0A";

#############################################################################
# Utilities

# xdg_basedir($xdg_variable, $default, $subdir, $path)
#   Return $path if $path is absolute.  Otherwise, return
#   "$ENV{$xdg_variable}/$subdir/$path" (resp. "~/$default/$subdir/path"
#   if the "$xdg_variable" environment variable is not set).
#   An error is raised if "$ENV{$xdg_variable}" (resp. "~/$default") is
#   not an existing absolute directory.
#   If "$ENV{$xdg_variable}/$subdir" doesn't exist, it is created with
#   mode 0700.
sub xdg_basedir($$$$) {
    my ($xdg_variable, $default, $subdir, $path) = @_;
    $path =~ /\A(\p{Print}+)\z/ or die "Insecure $path";
    $path = $1;
    return $path if $path =~ /\A\//;

    my $basedir = $ENV{$xdg_variable};
    $basedir = ($ENV{HOME} // "") ."/". $default unless defined $basedir;
    die "No such directory: ", $basedir unless -d $basedir;

    $basedir .= "/".$subdir;
    $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir";
    $basedir = $1;
    unless (mkdir ($basedir, 0700)) {
        die "Couldn't create $basedir: $!\n" unless $! == EEXIST;
    }
    return $basedir ."/". $path;
}

# 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, @_);

    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} = $opts{$k} ne qr/\A(YES|NO)\z/i ? $1 : uc $1 eq 'YES' ? 1 : 0;
        }
    }
    return \%configs;
}


# compact_set(@set)
# compact_list(@set)
#   Compact the UID or sequence number set @set, which must be
#   non-empty and may not contain '*'.
#   compact_set sorts the input UID list and removes duplicates, while
#   compact_list doesn't.
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;
}
sub compact_list(@) {
    my $min = my $max = shift // die 'Empty range';
    my ($set, $dir);

    while (@_) {
        my $k = shift;
        $dir //= $k < $max ? -1 : 1;
        if ($k != $max and $k == $max + $dir) {
            $max += $dir;
        }
        else {
            $set .= ',' if defined $set;
            $set .= $min == $max ? $min : "$min:$max";
            $min = $max = $k;
            undef $dir;
        }
    }

    $set .= ',' if defined $set;
    $set .= $min == $max ? $min : "$min:$max";
    return $set;
}

# with_set($set, $cmd)
#   Split long commands over multiple subsets to avoid exceeding the server limit
sub with_set($&) {
    my ($set, $cmd) = @_;
    my $max_length = 4096;
    for (my $length = length($set); $length > $max_length;) {
        my $l = rindex($set, ',', $max_length);
        die unless $l > 0; # sanity check
        $cmd->(substr($set, 0, $l));
        $set = substr($set, ++$l);
        $length -= $l;
    }
    return $cmd->($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 {
        # we'll later replace the non-synchronizing literal with a
        # synchronizing one if need be
        return "{".length($str)."+}$CRLF".$str;
    }
}



#############################################################################
# Public interface
# /!\ While this module can be used with non QRESYNC-capable (or non
# QRESYNC-enabled) servers, there is no internal cache mapping sequence
# numbers to UIDs, so EXPUNGE responses are ignored.

# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status
# ('OK'/'NO'/'BAD') condition for the last command issued.
our $IMAP_cond;

# The response text for the last command issued (prefixed with the status
# condition but without the tag).
our $IMAP_text;


# Create a new Net::IMAP::InterIMAP object.  Connect to the server,
# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and
# update the CAPABILITY list.
# In addition to the %OPTIONS above, valid parameters include:
#
#   - 'debug': Enable debug messages.
#
#   - 'enable': An extension or array reference of extensions to ENABLE
#     (RFC 5161) after entering AUTH state.  Croak if the server did not
#     advertise "ENABLE" in its CAPABILITY list or does not reply with
#     an untagged ENABLED response with all the given extensions.
#
#   - 'name': An optional instance name to include in log messages.
#
#   - 'logger-fd': An optional filehandle to use for debug output
#     (default: STDERR).
#
#   - 'keepalive': Whether to enable sending of keep-alive messages.
#     (type=imap or type=imaps).
#
sub new($%) {
    my $class = shift;
    my $self = { @_ };
    bless $self, $class;
    require 'Time/HiRes.pm' if defined $self->{'logger-fd'};

    # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
    # (cf RFC 3501 section 3)
    $self->{_STATE} = '';

    # in/out buffer counts and output stream
    $self->{_INCOUNT}  = $self->{_INRAWCOUNT}  = 0;
    $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
    $self->{_OUTBUF} = $self->{_INBUF} = undef;
    $self->{_LITPLUS} = '';

    if ($self->{type} eq 'tunnel') {
        my $command = $self->{command} // $self->fail("Missing tunnel command");
        socketpair($self->{S}, my $s, AF_UNIX, SOCK_STREAM|SOCK_CLOEXEC, PF_UNSPEC) or $self->panic("socketpair: $!");
        my $pid = fork // $self->panic("fork: $!");
        unless ($pid) {
            # children
            close($self->{S}) or $self->panic("close: $!");
            open STDIN,  '<&', $s or $self->panic("dup: $!");
            open STDOUT, '>&', $s or $self->panic("dup: $!");

            my $stderr2;
            if (($self->{'null-stderr'} // 0) and !($self->{debug} // 0)) {
                open $stderr2, '>&', *STDERR;
                open STDERR, '>', '/dev/null' or $self->panic("open(/dev/null): $!");
            }

            my $sigset = POSIX::SigSet::->new(SIGINT);
            my $oldsigset = POSIX::SigSet::->new();
            sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("sigprocmask: $!");

            unless (exec $command) {
                my $err = $!;
                if (defined $stderr2) {
                    close STDERR;
                    open STDERR, '>&', $stderr2;
                }
                $self->panic("exec: $err");
            }
        }

        # parent
        close($s) or $self->panic("close: $!");
    }
    else {
        foreach (qw/host port/) {
            $self->fail("Missing option $_") unless defined $self->{$_};
        }
        $self->{S} = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
                                            : $self->_tcp_connect(@$self{qw/host port/});
        if (defined $self->{keepalive}) {
            setsockopt($self->{S}, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
                or $self->fail("setsockopt SO_KEEPALIVE: $!");
            setsockopt($self->{S}, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
                or $self->fail("setsockopt TCP_KEEPIDLE: $!");
        }

    }
    binmode($self->{S}) // $self->panic("binmode: $!");
    $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps';

    # 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} = {};

    # 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 $self->{STARTTLS}) { # RFC 2595 section 5.1
            $self->fail("Server did not advertise STARTTLS capability.")
                unless grep {$_ eq 'STARTTLS'} @caps;
            $self->_send('STARTTLS');
            $self->_start_ssl($self->{S});

            # 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=(.+)/i ? uc($1) : undef } @caps);
        my $mech = (grep defined, map {my $m = uc($_); (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");
        }

        my $dbg;
        delete $self->{password}; # no need to remember passwords
        if (($self->{debug} // 0) == 1) {
            $dbg = $self->{debug}--;
            my $cmd = $command =~ /\A(LOGIN) / ? $1
                    : $command =~ /\A(AUTHENTICATE \S+)(?: .*)?\z/ ? $1
                    : $self->panic();
            $self->logger('C: xxx ', $cmd, ' [REDACTED]');
        }
        $self->_send($command, $callback);
        if (defined $dbg) {
            $self->logger('S: xxx ', $IMAP_text);
            $self->{debug} = $dbg;
        }
        $self->{_STATE} = 'AUTH';

        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();
        }
    }
    elsif ($IMAP_cond eq 'PREAUTH') {
        if ($self->{type} eq 'imap' and $self->{STARTTLS} != 0) {
            $self->fail("PREAUTH greeting on plaintext connection? MiTM in action? Aborting, set \"STARTTLS = NO\" to ignore.");
        }
        $self->{_STATE} = 'AUTH';
    }
    else {
        $self->panic();
    }

    # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
    if ($self->{compress} // 1 and
            my @algos = grep defined, map { /^COMPRESS=(.+)/i ? uc $1 : undef } @{$self->{_CAPABILITIES}}) {
        my @supported = qw/DEFLATE/; # supported compression algorithms
        my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported;
        if (!defined $algo) {
            $self->warn("Couldn't find a suitable compression algorithm. Not enabling compression.");
        }
        else {
            my ($d, $i);
            my $r = $self->_send("COMPRESS $algo");
            unless ($r eq 'NO' and $IMAP_text =~ /\ANO \[COMPRESSIONACTIVE\] /) {
                $self->panic($IMAP_text) unless $r eq 'OK';

                if ($algo eq 'DEFLATE') {
                    my %args = ( -WindowBits => 0 - MAX_WBITS, -Bufsize => $BUFSIZE );
                    $self->{_Z_DEFLATE} = Compress::Raw::Zlib::Deflate::->new(%args, -AppendOutput => 1) //
                        $self->panic("Can't create deflation stream");
                    $self->{_Z_INFLATE} = Compress::Raw::Zlib::Inflate::->new(%args) //
                        $self->panic("Can't create inflation stream");
                }
                else {
                    $self->fail("Unsupported compression algorithm: $algo");
                }
            }
        }
    }

    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->fail("Server did not advertise $_ capability.") foreach grep { !$self->_capable($_) } @extensions;
        $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;
}


# Print traffic statistics
sub stats($) {
    my $self = shift;
    my $msg = 'IMAP traffic (bytes):';
    $msg .= ' recv '._kibi($self->{_OUTCOUNT});
    $msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}).
            ', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')'
      if exists $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0;
    $msg .= ' sent '._kibi($self->{_INCOUNT});
    $msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}).
            ', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')'
      if exists $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0;
    $self->log($msg);
}


# Destroy a Net::IMAP::InterIMAP object.
sub DESTROY($) {
    local($., $@, $!, $^E, $?);
    my $self = shift;
    $self->{_STATE} = 'LOGOUT';

    Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL};
    Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX};

    if (defined (my $s = $self->{S})) {
        # for type=tunnel we assume the child won't linger around once
        # we close its standard input and output.
        shutdown($s, SHUT_RDWR);
        $s->close() if $s->opened();
    }
    $self->stats() unless $self->{quiet};
}


# $self->log($message, [...])
# $self->logger($message, [...])
#   Log a $message.  The latter method is used to log in the 'logger-fd'
#   (and adds timestamps).
sub log($@) {
    my $self = shift;
    return unless @_;
    my $prefix = _logger_prefix($self);
    if (defined (my $fd = $self->{'logger-fd'})) {
        say $fd _date(), " ", $prefix, @_;
    }
    say STDERR $prefix, @_;
}
sub logger($@) {
    my $self = shift;
    return unless @_;
    my $prefix = _logger_prefix($self);
    if (defined (my $fd = $self->{'logger-fd'})) {
        say $fd _date(), " ", $prefix, @_;
    } else {
        say STDERR $prefix, @_;
    }
}
sub _date() {
    my ($s, $us) = Time::HiRes::gettimeofday();
    my $t = POSIX::strftime("%b %e %H:%M:%S", localtime($s));
    return "$t.$us"; # millisecond precision
}

# $self->_logger_prefix()
#   Format a prefix for logging with printf(3)-like sequences:
#     %n: the object name
#     %m: mailbox, either explicit named or selected
sub _logger_prefix($) {
    my $self = shift;
    my $format = $self->{'logger-prefix'} // return "";

    my %seq = ( "%" => "%", m => $self->{mailbox}, n => $self->{name} );
    $seq{m} //= $self->{_SELECTED} // die
        if defined $self->{_STATE} and $self->{_STATE} eq 'SELECTED';

    do {} while
        # rewrite conditionals (loop because of nesting)
        $format =~ s#%\? ([[:alpha:]]) \?
                ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )* )
         (?: \& ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )*) )?
            \?# ($seq{$1} // "") ne "" ? $2 : ($3 // "") #agex;

    $format =~ s#\\([&?\\])#$1#g; # unescape remaining '&', '?' and '\'
    $format =~ s#%([%mn])# $seq{$1} #ge;
    return $format;
}


# $self->warn([$type,] $warning)
#   Log a $warning.
sub warn($$;$) {
    my ($self, $msg, $t) = @_;
    $msg = defined $t ? "$msg WARNING: $t" : "WARNING: $msg";
    $self->log($msg);
}


# $self->fail([$type,] $error)
#   Log an $error and exit with return value 1.
sub fail($$;$) {
    my ($self, $msg, $t) = @_;
    $msg = defined $t ? "$msg ERROR: $t" : "ERROR: $msg";
    $self->log($msg);
    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 a UID SEARCH command with the given $criterion.  For the "normal"
#   UID SEARCH command from RFC 3501, return the list of matching UIDs;
#   for the extended UID SEARCH command from RFC 4731 (ensuring ESEARCH
#   capability is the caller's responsibility), return an optional "UID"
#   indicator followed by a hash containing search data pairs.
sub search($$) {
    my ($self, $crit) = @_;
    my @res;
    $self->_send('UID SEARCH '.$crit, sub(@) {@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->unselect()
#   Issue an UNSELECT command (cf. RFC 3691). Upon success, change the
#   state to AUTH.
sub unselect($) {
    my $self = shift;

    $self->_send('UNSELECT');

    $self->{_STATE} = 'AUTH';
    delete $self->{_SELECTED};

    # 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->{_NEW} = 0;
}


# $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->{S}->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) = @_;
    $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
    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) = @_;
    $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
    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.")
        unless $self->_capable('UIDPLUS');

    with_set(compact_set(@set), sub($) {
        $self->_send("UID STORE $_[0] +FLAGS.SILENT (\\Deleted)");
        $self->_send("UID EXPUNGE $_[0]"); # 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)." UID(s) ".
               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.
#   Each $mail is a hash reference with key 'RFC822' and optionally
#   'UID', 'FLAGS' and 'INTERNALDATE'.
#   Providing multiple mails is only allowed for servers supporting
#   "MULTIAPPEND" (RFC 3502).
#   Return the list of UIDs allocated for the new messages, in the order
#   they were APPENDed.
sub append($$@) {
    my $self = shift;
    my $mailbox = shift;
    return unless @_;
    $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
        unless $self->_capable('UIDPLUS');
    $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.")
        unless $#_ == 0 or $self->_capable('MULTIAPPEND');

    # dump the cache before issuing the command if we're appending to the current mailbox
    my ($UIDNEXT, $EXISTS, $cache, %vanished);
    $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
    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}};
    }

    my $tag = $self->_cmd_init('APPEND '.quote($mailbox));
    foreach my $mail (@_) {
        my $str = ' ';
        $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS};
        $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
        $self->_cmd_extend(\$str);
        $self->_cmd_extend_lit($mail->{RFC822} // $self->panic("Missing message body in APPEND"));
    }

    $self->_cmd_flush();
    $self->_recv($tag);

    $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 ".($#_+1)." messages were appended.")
        unless $#uids == $#_;

    # 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} += $#_+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
        $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT;
    }

    unless ($self->{quiet}) {
        my $msg = "Added ".($#_+1)." UID(s) ";
        $msg .= "to $mailbox " unless defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED};
        if (defined $self->{name} and all {defined $_->{UID}} @_) {
            $msg .= $self->{name} eq 'local' ?
                (compact_list(@uids) .' <- '. compact_list(map {$_->{UID}} @_)) :
                (compact_list(map {$_->{UID}} @_) .' -> '. compact_list(@uids));
        }
        else {
            $msg .= compact_list(@uids);
        }
        $self->log($msg);
    }
    return @uids;
}


# $self->fetch($set, $flags, [$callback])
#   Issue a UID FETCH command with the given UID $set, $flags, and
#   optional $callback.
sub fetch($$$;&) {
    my ($self, $set, $flags, $callback) = @_;
    return with_set($set, sub($) {
        $self->_send("UID FETCH $_[0] $flags", $callback);
    });
}


# $self->notify($arg, %specifications)
#   Issue a NOTIFY command with the given $arg ("SET", "SET STATUS" or
#   "NONE") and mailbox %specifications (cf RFC 5465 section 6) to be
#   monitored.  Croak if the server did not advertise "NOTIFY" (RFC
#   5465) in its CAPABILITY list.
sub notify($$@) {
    my $self = shift;
    $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
        unless $self->_capable('NOTIFY');
    my $command = 'NOTIFY '.shift;
    while (@_) {
        $command .= " (".shift." (".join(' ', @{shift()})."))";
    }
    $self->_send($command);
}


# slurp($imap, $timeout, $stopwhen)
#   Keep reading untagged responses from the @$imap servers until the
#   $stopwhen condition becomes true (then return true), or until the
#   $timeout expires (then return false).
#   This is mostly useful when waiting for notifications while no
#   command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY).
sub slurp($$$) {
    my ($selfs, $timeout, $stopwhen) = @_;
    my $aborted = 0;

    my $rin = '';
    vec($rin, fileno($_->{S}), 1) = 1 foreach @$selfs;

    while (1) {
        # first, consider only unprocessed data without our own output
        # buffer, or within the current TLS record: these would cause
        # select(2) to block/timeout due to the raw socket not being
        # ready.
        my @ready = grep { (defined $_->{_OUTBUF} and $_->{_OUTBUF} ne '') or
                           (defined $_->{_SSL} and Net::SSLeay::pending($_->{_SSL}) > 0)
                         } @$selfs;
        unless (@ready) {
            my ($r, $timeleft) = CORE::select(my $rout = $rin, undef, undef, $timeout);
            next if $r == -1 and $! == EINTR; # select(2) was interrupted
            die "select: $!" if $r == -1;
            return $aborted if $r == 0; # nothing more to read (timeout reached)
            @ready = grep {vec($rout, fileno($_->{S}), 1)} @$selfs;
            $timeout = $timeleft if $timeout > 0;
        }

        foreach my $imap (@ready) {
            my $x = $imap->_getline();
            $imap->_resp($x, sub($;$$) {
                if ($stopwhen->($imap, @_)) {
                    $aborted = 1;
                    $timeout = 0; # keep reading the handles while there is pending data
                }
            }, 'slurp');
        }
    }
    return $aborted;
}


# $self->idle($timeout, $stopwhen)
#   Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or
#   when the callback $stopwhen returns true.
#   Return true if the callback returned true (either aborting IDLE, or
#   after the $timeout) and false otherwise.
sub idle($$$) {
    my ($self, $timeout, $stopwhen) = @_;
    my $tag = $self->idle_start($timeout);
    my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins
    $r += $self->idle_stop($tag, $stopwhen);
    return $r;
}

# $self->idle_start()
#   Enter IDLE (RFC 2177).
#   Return the command tag.
sub idle_start($) {
    my $self = shift;
    $self->fail("Server did not advertise IDLE (RFC 2177) capability.")
        unless $self->_capable('IDLE');

    my $tag = $self->_cmd_init('IDLE');
    $self->_cmd_flush();
    return $tag;
}

# $self->idle_stop($tag, $callback)
#   Stop a running IDLE (RFC 2177) command $tag.
#   Returns the number of untagged responses received between the DONE
#   the tagged response that are satisfying $callback.
sub idle_stop($$$) {
    my ($self, $tag, $callback) = @_;
    my $r = 0;

    # done idling
    $self->_cmd_extend('DONE');
    $self->_cmd_flush();
    # run the callback again to update the return value if we received
    # untagged responses between the DONE and the tagged response
    $self->_recv($tag, sub($;$$) { $r++ if $callback->($self, @_) }, 'slurp');

    return $r;
}


# $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();
    $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
    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 for $mailbox.")
                if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
        }
        $cache->{$k} = $v;
    }

    $self->logger("Update last clean state for $mailbox: ".
                 '('.join(' ', map {"$_ $cache->{$_}"} grep {defined $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) {
        $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
        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->get_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., if its
#   internal cache's HIGHESTMODSEQ or UIDNEXT values differ from its
#   persistent cache's values.
sub is_dirty($$) {
    my ($self, $mailbox) = @_;
    return 1 if $self->{_NEW};
    $self->_updated_cache($mailbox, qw/HIGHESTMODSEQ UIDNEXT/);
}


# $self->has_new_mails($mailbox)
#   Return true if there are new messages in $mailbox, i.e., if its
#   internal cache's UIDNEXT value differs from its persistent cache's.
sub has_new_mails($$) {
    my ($self, $mailbox) = @_;
    return 1 if $self->{_NEW};
    $self->_updated_cache($mailbox, 'UIDNEXT');
}


# $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};

    $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)")
        if $full and ($pcache->{UIDNEXT} // 1) > 1;

    my %modified;
    while (%{$self->{_MODIFIED}}) {
        my @missing;
        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} = {};
        # non-empty @missing indicates a discouraged (but allowed) CONDSTORE server behavior,
        # cf. RFC 7162 sec. 3.1.3 ex. 8 and the comment in push_flag_updates() below
        with_set(compact_set(@missing), sub($) {
            $self->_send("UID FETCH $_[0] (MODSEQ FLAGS)")
        }) if @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($attrs, $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.
#   The list of attributes to FETCH, $attr, must contain BODY[].
#   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 $attrs = shift;
    my $callback = shift;
    my @ignore = sort { $a <=> $b } @_;

    my $mailbox = $self->{_SELECTED} // $self->panic();
    my $cache = $self->{_CACHE}->{$mailbox};

    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 = $cache->{UIDNEXT} // $self->panic(); # sanity check
        $self->fetch($range, "($attrs)", sub($) {
            my $mail = shift;
            $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID};
            $callback->($mail) if defined $callback;
        }) if $first < $UIDNEXT or $self->{_NEW};

        # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ
        # since there might be pending updates)
        $self->set_cache($mailbox, UIDNEXT => $UIDNEXT);
        $self->{_NEW} = 0;
    }
    # loop if new messages were received in the meantime
    while ($self->{_NEW} or $UIDNEXT < $cache->{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 %failed;
    with_set(compact_set(@set), sub($) {
        $self->_send("UID STORE $_[0] (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)");
        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) {
        my $modified = $self->{_MODIFIED};
        if ($failed{$uid}) {
            # $uid was listed in the MODIFIED response code from RFC 7162; will FETCH
            # again in pull_updates(); per RFC 7162 sec. 3.1.3 $modified->{$uid} might not
            # be defined ("nice" servers send an untagged FETCH response, cf. example 10,
            # but they might omit it - allowed but discouraged CONDSTORE server behavior -
            # cf. example 8)
            $modified->{$uid} //= [ 0, undef ];
        } elsif (defined (my $m = $modified->{$uid})) {
            # received an untagged FETCH response, remove from the list of pending changes
            # if the flag list was up to date (either implicitely or explicitly)
            if (!defined $m->[1] or $m->[1] eq $flags) {
                delete $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).', '.
                   "will try again later") if %failed;
    }
    return keys %failed;
}


# $self->silent_store($set, $mod, @flags)
#   Set / Add / Remove the flags list on the UID $set, depending on the
#   value of $mod ('' / '+' / '-').
#   /!\ There is no guaranty that message flags are successfully updated!
sub silent_store($$$@) {
    my $self = shift;
    my $set = shift;
    my $subcmd = shift . "FLAGS.SILENT";
    my $flags = join(' ', @_);
    with_set($set, sub($) { $self->_send("UID STORE $_[0] $subcmd ($flags)") });
}


# $self->expunge($set)
#   Exunge the given UID $set.
#   /!\ There is no guaranty that messages are successfully expunged!
sub expunge($$) {
    my $self = shift;
    my $set = shift;

    $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
        unless $self->_capable('UIDPLUS');
    with_set($set, sub($) { $self->_send("UID EXPUNGE $_[0]") });
}


#############################################################################
# Private methods

# $self->_ssl_error($error, [...])
#   Log an SSL $error and exit with return value 1.
sub _ssl_error($$@) {
    my $self = shift;
    $self->fail(@_) unless defined $self->{_SSL};
    $self->log('SSL ERROR: ', @_);
    if ($self->{debug}) {
        while (my $err = Net::SSLeay::ERR_get_error()) {
            $self->log(Net::SSLeay::ERR_error_string($err));
        }
    }
    exit 1;
}


# RFC 3986 appendix A
my $RE_IPv4 = do {
    my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/;
    qr/$dec(?:\.$dec){3}/ };
my $RE_IPv6 = do {
    my $h16  = qr/[0-9A-Fa-f]{1,4}/;
    my $ls32 = qr/$h16:$h16|$RE_IPv4/;
    qr/                                  (?: $h16 : ){6} $ls32
      |                               :: (?: $h16 : ){5} $ls32
      | (?:                   $h16 )? :: (?: $h16 : ){4} $ls32
      | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
      | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
      | (?: (?: $h16 : ){0,3} $h16 )? ::     $h16 :      $ls32
      | (?: (?: $h16 : ){0,4} $h16 )? ::                 $ls32
      | (?: (?: $h16 : ){0,5} $h16 )? ::                 $h16
      | (?: (?: $h16 : ){0,6} $h16 )? ::
      /x };

# Parse an IPv4 or IPv6.  In list context, return a pair (IP, family),
# otherwise only the IP.  If the argument is not an IP (for instance if
# it's a hostname), then return (undef, undef) resp. undef.  The input
# can optionaly be enclosed in square brackets which forces its
# interpretation as an IP literal: an error is raised if it is not the
# case.
my $RE_IPv4_anchored = qr/\A($RE_IPv4)\z/;
my $RE_IPv6_anchored = qr/\A($RE_IPv6)\z/;
sub _parse_hostip($) {
    my $v = shift // return;
    my $literal = $v =~ s/\A\[(.*)\]\z/$1/ ? 1 : 0;
    my ($ip, $af) = $v =~ $RE_IPv4_anchored ? ($1, AF_INET)
                  : $v =~ $RE_IPv6_anchored ? ($1, AF_INET6)
                  : (undef, undef);
    die "Invalid IP literal: $v\n" if $literal and !defined($ip);
    return wantarray ? ($ip, $af) : $ip;
}

# Opens a TCP socket to the given $host and $port.
sub _tcp_connect($$$) {
    my ($self, $host, $port) = @_;

    my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP);
    my ($host2, $family) = _parse_hostip($host);
    if (defined $family) {
        $hints{family} = $family;
        $hints{flags} |= AI_NUMERICHOST;
    } else {
        $host2 = $host;
    }

    my ($err, @res) = getaddrinfo($host2, $port, \%hints);
    $self->fail("getaddrinfo($host2): $err") if $err ne '';

    SOCKETS:
    foreach my $ai (@res) {
        socket (my $s, $ai->{family}, $ai->{socktype}|SOCK_CLOEXEC, $ai->{protocol}) or $self->panic("socket: $!");

        # timeout connect/read/write/... after 30s
        # XXX we need to pack the struct timeval manually: not portable!
        # https://stackoverflow.com/questions/8284243/how-do-i-set-so-rcvtimeo-on-a-socket-in-perl
        my $timeout = pack('l!l!', 30, 0);
        setsockopt($s, Socket::SOL_SOCKET, Socket::SO_RCVTIMEO, $timeout)
                or $self->fail("setsockopt SO_RCVTIMEO: $!");
        setsockopt($s, Socket::SOL_SOCKET, Socket::SO_SNDTIMEO, $timeout)
                or $self->fail("setsockopt SO_RCVTIMEO: $!");

        until (connect($s, $ai->{addr})) {
            next if $! == EINTR; # try again if connect(2) was interrupted by a signal
            next SOCKETS;
        }
        return $s;
    }
    $self->fail("Can't connect to $host:$port");
}

sub _xwrite($$$) {
    my $self = shift;
    my ($offset, $length) = (0, length $_[1]);

    while ($length > 0) {
        my $n = syswrite($_[0], $_[1], $length, $offset);
        $self->fail("write: $!") unless defined $n and $n > 0;
        $offset += $n;
        $length -= $n;
    }
}


sub _xread($$$) {
    my ($self, $fh, $length) = @_;
    my $offset = 0;
    my $buf;
    while ($length > 0) {
        my $n = sysread($fh, $buf, $length, $offset) // $self->fail("read: $!");
        $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
        $offset += $n;
        $length -= $n;
    }
    return $buf;
}


# $self->_proxify($proxy, $host, $port)
#   Initiate the given $proxy to proxy TCP connections to $host:$port.
sub _proxify($$$$) {
    my ($self, $proxy, $host, $port) = @_;
    $port = getservbyname($port, 'tcp') // $self->fail("Can't getservbyname $port")
        unless $port =~ /\A[0-9]+\z/;

    $proxy =~ /\A([A-Za-z0-9]+):\/\/(\P{Control}*\@)?([^:]+|\[[^\]]+\])(:[A-Za-z0-9]+)?\z/
        or $self->fail("Invalid proxy URI $proxy");
    my ($proto, $userpass, $proxyhost, $proxyport) = ($1, $2, $3, $4);
    $userpass =~ s/\@\z// if defined $userpass;
    $proxyport = defined $proxyport ? $proxyport =~ s/\A://r : 1080;

    my $socket = $self->_tcp_connect($proxyhost, $proxyport);
    if ($proto eq 'socks5' or $proto eq 'socks5h') {
        my $resolv = $proto eq 'socks5h' ? 1 : 0;
        my $v = 0x05; # RFC 1928  VER protocol version

        my %mech = ( ANON => 0x00 );
        $mech{USERPASS} = 0x02 if defined $userpass;

        $self->_xwrite($socket, pack('CCC*', 0x05, scalar (keys %mech), values %mech));
        my ($v2, $m) = unpack('CC', $self->_xread($socket, 2));
        $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2;

        %mech = reverse %mech;
        my $mech = $mech{$m} // '';
        if ($mech eq 'USERPASS') { # RFC 1929 Username/Password Authentication for SOCKS V5
            my $v = 0x01; # current version of the subnegotiation
            my ($u, $pw) = split /:/, $userpass, 2;

            $self->_xwrite($socket, pack('C2', $v,length($u)).$u.pack('C',length($pw)).$pw);
            my ($v2, $r) = unpack('C2', $self->_xread($socket, 2));
            $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2;
            $self->fail('SOCKSv5', 'Authentication failed') unless $r == 0x00;
        }
        elsif ($mech ne 'ANON') { # $m == 0xFF
            $self->fail('SOCKSv5', 'No acceptable authentication methods');
        }

        my ($hostip, $fam) = _parse_hostip($host);
        unless (defined($fam) or $resolv) {
            # resove the hostname $host locally
            my ($err, @res) = getaddrinfo($host, undef, {socktype => SOCK_RAW});
            $self->fail("getaddrinfo($host): $err") if $err ne '';
            my ($addr) = first { defined($_) } map {
                my ($err, $ipaddr) = getnameinfo($_->{addr}, NI_NUMERICHOST, NIx_NOSERV);
                $err eq '' ? [$ipaddr,$_->{family}] : undef
            } @res;
            $self->fail("getnameinfo") unless defined $addr;
            ($hostip, $fam) = @$addr;
        }

        # send a CONNECT command (CMD 0x01)
        my ($typ, $addr);
        if (defined $fam) {
            $typ = $fam == AF_INET ? 0x01 : $fam == AF_INET6 ? 0x04 : $self->panic();
            $addr = Socket::inet_pton($fam, $hostip);
        } else {
            # let the SOCKS server do the resolution
            $typ = 0x03;
            $addr = pack('C',length($host)) . $host;
        }
        $self->_xwrite($socket, pack('C4', $v, 0x01, 0x00, $typ) . $addr . pack('n', $port));

        ($v2, my $r, my $rsv, $typ) = unpack('C4', $self->_xread($socket, 4));
        $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2 and $rsv == 0x00;
        my $err = $r == 0x00 ? undef
                : $r == 0x01 ? 'general SOCKS server failure'
                : $r == 0x02 ? 'connection not allowed by ruleset'
                : $r == 0x03 ? 'network unreachable'
                : $r == 0x04 ? 'host unreachable'
                : $r == 0x05 ? 'connection refused'
                : $r == 0x06 ? 'TTL expired'
                : $r == 0x07 ? 'command not supported'
                : $r == 0x08 ? 'address type not supported'
                : $self->panic();
        $self->fail('SOCKSv5', $err) if defined $err;

        my $len = $typ == 0x01 ? 4
                : $typ == 0x03 ? unpack('C', $self->_xread($socket, 1))
                : $typ == 0x04 ? 16
                : $self->panic();
        $self->_xread($socket, $len + 2); # consume (and ignore) the rest of the response
        return $socket;
    }
    else {
        $self->fail("Unsupported proxy protocol $proto");
    }
}


# $self->_ssl_verify($self, $preverify_ok, $x509_ctx)
#   SSL verify callback function, see
#   https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_verify.html
sub _ssl_verify($$$) {
    my ($self, $ok, $x509_ctx) = @_;
    return 0 unless $x509_ctx; # reject

    my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($x509_ctx);
    my $cert  = Net::SSLeay::X509_STORE_CTX_get_current_cert($x509_ctx)
        or $self->_ssl_error("Can't get current certificate");
    if ($self->{debug}) {
        $self->log("[$depth] preverify=$ok");
        $self->log('  Issuer Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)));
        $self->log('  Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)));
    }

    $ok = 1 unless $self->{SSL_verify} // die; # safety check, always set
    if ($depth == 0 and !exists $self->{_SSL_PEER_VERIFIED}) {
        if ($self->{debug}) {
            my $algo = 'sha256';
            my $type = Net::SSLeay::EVP_get_digestbyname($algo)
                or $self->_ssl_error("Can't find MD value for name '$algo'");
            $self->log('Peer certificate fingerprint: '
                      .$algo.'$'.unpack('H*', Net::SSLeay::X509_digest($cert, $type)));
        }

        if (defined (my $fprs = $self->{SSL_fingerprint})) {
            my $rv = 0;
            foreach my $fpr (split /\s+/, $fprs) {
                (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr);
                my $digest = pack 'H*', ($fpr =~ tr/://rd);

                my $type = Net::SSLeay::EVP_get_digestbyname($algo)
                    or $self->_ssl_error("Can't find MD value for name '$algo'");

                my $pkey = Net::SSLeay::X509_get_X509_PUBKEY($cert);
                if (defined $pkey and Net::SSLeay::EVP_Digest($pkey, $type) eq $digest) {
                    $self->log('Peer certificate matches pinned SPKI digest ', $algo .'$'. $fpr) if $self->{debug};
                    $rv = 1;
                    last;
                }
            }
            unless ($rv) {
                $self->warn("Fingerprint doesn't match! MiTM in action?");
                $ok = 0;
            }
        }
        $self->{_SSL_PEER_VERIFIED} = $ok;
    }
    return $ok; # 1=accept cert, 0=reject
}

my %SSL_proto;
BEGIN { # TODO deprecated, remove in 0.6
    sub _append_ssl_proto($$) {
        my ($k, $v) = @_;
        $SSL_proto{$k} = $v if defined $v;
    }
    _append_ssl_proto( "SSLv2",   eval { Net::SSLeay::OP_NO_SSLv2()   } );
    _append_ssl_proto( "SSLv3",   eval { Net::SSLeay::OP_NO_SSLv3()   } );
    _append_ssl_proto( "TLSv1",   eval { Net::SSLeay::OP_NO_TLSv1()   } );
    _append_ssl_proto( "TLSv1.1", eval { Net::SSLeay::OP_NO_TLSv1_1() } );
    _append_ssl_proto( "TLSv1.2", eval { Net::SSLeay::OP_NO_TLSv1_2() } );
    _append_ssl_proto( "TLSv1.3", eval { Net::SSLeay::OP_NO_TLSv1_3() } );
}

# see ssl/ssl_conf.c:protocol_from_string() in the OpenSSL source tree
my %SSL_protocol_versions = (
    "SSLv3"   => eval { Net::SSLeay::SSL3_VERSION() }
  , "TLSv1"   => eval { Net::SSLeay::TLS1_VERSION() }
  , "TLSv1.1" => eval { Net::SSLeay::TLS1_1_VERSION() }
  , "TLSv1.2" => eval { Net::SSLeay::TLS1_2_VERSION() }
  , "TLSv1.3" => eval { Net::SSLeay::TLS1_3_VERSION() }
);

# $self->_start_ssl($socket)
#   Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
    my ($self, $socket) = @_;
    # need  OpenSSL 1.1.0 or later for SSL_CTX_set_min_proto_version(3ssl), see
    # https://www.openssl.org/docs/man1.1.0/man3/SSL_CTX_set_min_proto_version.html
    $self->panic("SSL/TLS functions require OpenSSL 1.1.0 or later")
        if Net::SSLeay::OPENSSL_VERSION_NUMBER() < 0x1010000f;

    my $ctx = Net::SSLeay::CTX_new() or $self->panic("SSL_CTX_new(): $!");
    $self->{SSL_verify} //= 1; # default is to perform certificate verification

    if (defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') {
        $self->warn("Truncating non-empty output buffer (unauthenticated response injection?)");
        undef $self->{_OUTBUF};
    }

    my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE();
    $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION();

    if (defined $self->{SSL_protocol_min} or defined $self->{SSL_protocol_max}) {
        my ($min, $max) = @$self{qw/SSL_protocol_min SSL_protocol_max/};
        if (defined $min) {
            my $v = $SSL_protocol_versions{$min} // $self->panic("Unknown protocol version: $min");
            $self->_ssl_error("CTX_set_min_proto_version()") unless Net::SSLeay::CTX_set_min_proto_version($ctx, $v) == 1;
            $self->log("Minimum SSL/TLS protocol version: ", $min) if $self->{debug};
        }
        if (defined $max) {
            my $v = $SSL_protocol_versions{$max} // $self->panic("Unknown protocol version: $max");
            $self->_ssl_error("CTX_set_max_proto_version()") unless Net::SSLeay::CTX_set_max_proto_version($ctx, $v) == 1;
            $self->log("Maximum SSL/TLS protocol version: ", $max) if $self->{debug};
        }
    } elsif (defined (my $protos = $self->{SSL_protocols})) { # TODO deprecated, remove in 0.6
        $self->warn("SSL_protocols is deprecated and will be removed in a future release! " .
                    "Use SSL_protocol_{min,max} instead.");
        my ($proto_include, $proto_exclude) = (0, 0);
        foreach (split /\s+/, $protos) {
            my $neg = s/^!// ? 1 : 0;
            s/\.0$//;
            ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_");
        }
        if ($proto_include != 0) {
            # exclude all protocols except those explictly included
            my $x = 0;
            $x |= $_ foreach values %SSL_proto;
            $x &= ~ $proto_include;
            $proto_exclude |= $x;
        }
        my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto;
        $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug};
        $ssl_options |= $SSL_proto{$_} foreach @proto_exclude;
    }

    # https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_options.html
    # TODO 0.6: move SSL_CTX_set_options() and SSL_CTX_set_mode() before SSL_CTX_set_{min,max}_proto_version()
    Net::SSLeay::CTX_set_options($ctx, $ssl_options);

    # https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_mode.html
    Net::SSLeay::CTX_set_mode($ctx,
        Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() |
        Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() |
        Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegotiation
        Net::SSLeay::MODE_RELEASE_BUFFERS() );

    if (defined (my $str = $self->{SSL_cipherlist})) {
        $self->_ssl_error("SSL_CTX_set_cipher_list()") unless Net::SSLeay::CTX_set_cipher_list($ctx, $str) == 1;
    }
    if (defined (my $str = $self->{SSL_ciphersuites})) {
        $self->_ssl_error("SSL_CTX_set_ciphersuites()") unless Net::SSLeay::CTX_set_ciphersuites($ctx, $str) == 1;
    }

    my $vpm = Net::SSLeay::X509_VERIFY_PARAM_new() or $self->_ssl_error("X509_VERIFY_PARAM_new()");
    my $purpose = Net::SSLeay::X509_PURPOSE_SSL_SERVER();
    $self->_ssl_error("X509_VERIFY_PARAM_set_purpose()") unless Net::SSLeay::X509_VERIFY_PARAM_set_purpose($vpm, $purpose) == 1;
    $self->_ssl_error("CTX_set_purpose()") unless Net::SSLeay::CTX_set_purpose($ctx, $purpose) == 1;

    my $host = $self->{host} // $self->panic();
    my ($hostip, $hostipfam) = _parse_hostip($host);
    if ($self->{SSL_verify}) {
        # verify certificate chain
        if (defined $self->{SSL_CAfile} or defined $self->{SSL_CApath}) {
            $self->_ssl_error("SSL_CTX_load_verify_locations()")
                unless Net::SSLeay::CTX_load_verify_locations($ctx,
                    $self->{SSL_CAfile} // '', $self->{SSL_CApath} // '') == 1;
        } else {
            $self->log("Using default locations for trusted CA certificates") if $self->{debug};
            $self->_ssl_error("SSL_CTX_set_default_verify_paths()")
                unless Net::SSLeay::CTX_set_default_verify_paths($ctx) == 1;
        }

        # verify DNS hostname or IP literal
        if (defined $hostipfam) {
            my $addr = Socket::inet_pton($hostipfam, $hostip) // $self->panic();
            $self->_ssl_error("X509_VERIFY_PARAM_set1_ip()")
                unless Net::SSLeay::X509_VERIFY_PARAM_set1_ip($vpm, $addr) == 1;
        } else {
            $self->_ssl_error("X509_VERIFY_PARAM_set1_host()")
                unless Net::SSLeay::X509_VERIFY_PARAM_set1_host($vpm, $host) == 1;
        }
    }
    else {
        Net::SSLeay::CTX_set_verify_depth($ctx, 0);
    }
    Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)});
    $self->_ssl_error("CTX_SSL_set1_param()") unless Net::SSLeay::CTX_set1_param($ctx, $vpm) == 1;

    my $ssl = Net::SSLeay::new($ctx) or $self->fail("SSL_new()");
    $self->fail("SSL_set_fd()") unless Net::SSLeay::set_fd($ssl, fileno($socket)) == 1;

    # always use 'SSL_hostname' when set, otherwise use 'host' (unless it's an IP)
    my $servername = $self->{SSL_hostname} // (defined $hostipfam ? "" : $host);
    if ($servername ne "") {
        $self->_ssl_error("SSL_set_tlsext_host_name($servername)")
            unless Net::SSLeay::set_tlsext_host_name($ssl, $servername) == 1;
        $self->log("Using SNI with name $servername") if $self->{debug};
    }

    $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
    $self->panic() unless $self->{_SSL_PEER_VERIFIED}; # sanity check
    $self->panic() if $self->{SSL_verify} and Net::SSLeay::get_verify_result($ssl) != Net::SSLeay::X509_V_OK();
    Net::SSLeay::X509_VERIFY_PARAM_free($vpm);

    if ($self->{debug}) {
        $self->log(sprintf('SSL protocol: %s (0x%x)',
                          , Net::SSLeay::get_version($ssl)
                          , Net::SSLeay::version($ssl)));
        $self->log(sprintf('SSL cipher: %s (%d bits)'
                          , Net::SSLeay::get_cipher($ssl)
                          , Net::SSLeay::get_cipher_bits($ssl)));
    }

    @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
    undef $self; # the verify callback has reference to $self, free it now
}


# $self->_getline([$length])
#   Read a line from the handle and strip the trailing CRLF, optionally
#   after reading a literal of the given $length (default: 0).
#   In list context, return a pair ($literal, $line); otherwise only
#   return the $line.
#   /!\ Don't use this method with non-blocking IO!
sub _getline($;$) {
    my $self = shift;
    my $len = shift // 0;

    my ($stdout, $ssl) = @$self{qw/S _SSL/};
    $self->fail("Lost connection") unless $stdout->opened();

    my (@lit, @line);
    while(1) {
        unless (defined $self->{_OUTBUF}) {
            my ($buf, $n);
            # nothing cached: read some more
            if (defined $ssl) {
                ($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE);
            } else {
                $n = sysread($stdout, $buf, $BUFSIZE, 0);
            }

            $self->_ssl_error("read: $!") unless defined $n;
            $self->_ssl_error("0 bytes read (got EOF)") unless $n > 0; # EOF
            $self->{_OUTRAWCOUNT} += $n;

            if (defined (my $i = $self->{_Z_INFLATE})) {
                my $r = $i->inflate($buf, $self->{_OUTBUF});
                $self->panic("Inflation failed: $r ", $i->msg())
                    unless $r == Z_OK or $r == Z_STREAM_END;
            }
            else {
                $self->{_OUTBUF} = $buf;
            }
        }
        if ($len == 0) { # read a regular line: stop after the first \r\n
            if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) {
                # found the EOL, we're done
                my $lit = join '', @lit;
                my $line = join '', @line, substr($self->{_OUTBUF}, 0, $idx);
                $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx);

                $self->{_OUTCOUNT} += length($lit) + length($line);
                $line =~ s/$CRLF\z// or $self->panic($line);
                $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug};

                return (wantarray ? (\$lit, $line) : $line);
            }
            else {
                push @line, $self->{_OUTBUF};
                undef $self->{_OUTBUF};
            }
        }
        elsif ($len > 0) { # $len bytes of literal bytes to read
            if ($len < length($self->{_OUTBUF})) {
                push @lit, substr($self->{_OUTBUF}, 0, $len, '');
                $len = 0;
            }
            else {
                push @lit, $self->{_OUTBUF};
                $len -= length($self->{_OUTBUF});
                undef $self->{_OUTBUF};
            }
        }
    }
}


# $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 for $mailbox.")
                if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
            $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;
        }
        $cache->{$k} = $v;
    }
}


# $self->_updated_cache($mailbox)
#   Return true if there are pending updates for $mailbox, i.e., if one
#   of its internal cache's @attrs value differs from the persistent
#   cache's value.
sub _updated_cache($$@) {
    my ($self, $mailbox, @attrs) = @_;
    $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
    my $cache  = $self->{_CACHE}->{$mailbox}  // return 1;
    my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;

    foreach (@attrs) {
        return 1 unless $pcache->{$_} and defined $cache->{$_} and
                        $pcache->{$_} == $cache->{$_};
    }
    return 0;
}


# $self->_cmd_init($command)
#   Generate a new tag for the given $command, push both the
#   concatenation to the command buffer.  $command can be a scalar or a
#   scalar reference.
#   Use the _cmd_extend and/or _cmd_extend_lit methods to extend the
#   command, and _cmd_flush to send it to the server.
sub _cmd_init($$) {
    my $self = shift;
    my $tag = sprintf '%06d', $self->{_TAG}++;
    my $command = (defined $self->{_INBUF} ? $CRLF : '').$tag.' '.(ref $_[0] ? ${$_[0]} : $_[0]);
    $self->_cmd_extend(\$command);
    return $tag;
}


# $self->_cmd_extend($args)
#   Append $args to the command buffer.  $args can be a scalar or a
#   scalar reference.  If $args contains some literal(s) and the server
#   doesn't support LITERAL+, flush the command and wait for an answer
#   before each literal
sub _cmd_extend($$) {
    my $self = shift;
    my $args = ref $_[0] ? $_[0] : \$_[0];

    if ($self->{_LITPLUS} ne '') {
        # server supports LITERAL+: use $args as is
        $self->_cmd_extend_($args);
    }
    else {
        # server doesn't supports LITERAL+: flush the command before
        # each literal
        my ($offset, $litlen) = (0, 0);
        while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) {
            my $line = substr($$args, $offset, $idx+1-$offset);
            $line =~ s/\{([0-9]+)\+\}$CRLF\z/{$1}$CRLF/ or $self->panic();
            $litlen = $1;
            $self->_cmd_flush(\$line);

            my $x = $self->_getline();
            $x =~ /\A\+ / or $self->panic($x);
            $offset = $idx+1;
        }
        my $line = substr($$args, $offset);
        $self->_cmd_extend_(\$line);
    }
}


# $self->_cmd_extend_lit($lit)
#   Append the literal $lit to the command buffer.  $lit must be a
#   scalar reference.
sub _cmd_extend_lit($$) {
    my ($self, $lit) = @_;
    my $len = length($$lit);
    my $d = $self->{_Z_DEFLATE};

    # create a full flush point for long literals, cf. RFC 4978 section 4
    my $z_flush = $len > $BUFSIZE ? 1 : 0;
    my $strlen = "{$len$self->{_LITPLUS}}$CRLF";

    if ($self->{_LITPLUS} ne '') {
        $self->_cmd_extend_(\$strlen);
        if ($z_flush and defined $d) {
            $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK
                or $self->panic("Can't flush deflation stream: ", $d->msg());
        }
    }
    else {
        # server doesn't supports LITERAL+
        $self->_cmd_flush(\$strlen, ($z_flush ? Z_FULL_FLUSH : ()));
        my $x = $self->_getline();
        $x =~ /\A\+ / or $self->panic($x);
    }

    $self->_cmd_extend_($lit);
    if ($z_flush and defined $d) {
        $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK
            or $self->panic("Can't flush deflation stream: ", $d->msg());
    }
}


# $self->_cmd_flush([$crlf], [$z_flush])
#   Append $crlf (default: $CRLF) to the command buffer, flush the
#   deflation stream by creating a flush point of type $z_flush
#   (default: Z_SYNC_FLUSH) if there is a compression layer, and finally
#   send the command to the server.
sub _cmd_flush($;$$) {
    my $self = shift;
    $self->_cmd_extend_( $_[0] // \$CRLF );
    my $z_flush = $_[1] // Z_SYNC_FLUSH; # the flush point type to use
    my ($stdin, $ssl) = @$self{qw/S _SSL/};

    if ($self->{debug}) {
        # remove $CRLF and literals
        my ($offset, $litlen) = (0, $self->{_INBUFDBGLEN} // 0);
        while ( (my $idx = index($self->{_INBUFDBG}, "\n", $offset+$litlen)) >= 0) {
            my $line = substr($self->{_INBUFDBG}, $offset+$litlen, $idx+1-$offset-$litlen);
            $line =~ s/$CRLF\z// or $self->panic();
            $self->logger('C: ', ($litlen > 0) ? '[...]' : '', $line);
            $litlen = $line =~ /\{([0-9]+)(\+)?\}\z/ ? $1 : 0;
            $offset = $idx+1;
        }
        $self->panic() if $offset+$litlen < length($self->{_INBUFDBG});
        undef $self->{_INBUFDBG};
        $self->{_INBUFDBGLEN} = $litlen;
    }

    if (defined (my $d = $self->{_Z_DEFLATE})) {
        $d->flush(\$self->{_INBUF}, $z_flush) == Z_OK
            or $self->panic("Can't flush deflation stream: ", $d->msg());
    }

    my ($offset, $length) = (0, length($self->{_INBUF}));
    while ($length > 0) {
        my $written = defined $ssl ?
            Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) :
            syswrite($stdin, $self->{_INBUF}, $length, $offset);
        $self->_ssl_error("write: $!") unless defined $written and $written > 0;

        $offset += $written;
        $length -= $written;
        $self->{_INRAWCOUNT} += $written;
    }
    undef $self->{_INBUF};
}


# $self->_cmd_extend_($args)
#   Append the scalar reference $args to the command buffer.  Usually
#   one should use the higher-level method _cmd_extend as it takes care
#   of literals if the server doesn't support LITERAL+.
sub _cmd_extend_($$) {
    my ($self, $args) = @_;
    $self->{_INCOUNT} += length($$args); # count IMAP traffic
    $self->{_INBUFDBG} .= $$args if $self->{debug};
    if (defined (my $d = $self->{_Z_DEFLATE})) {
        $d->deflate($args, \$self->{_INBUF}) == Z_OK or $self->panic("Deflation failed: ", $d->msg());
    }
    else {
        $self->{_INBUF} .= $$args;
    }
}


# $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 = shift;
    my $command = \$_[0];
    my $callback = $_[1];

    my $tag = $self->_cmd_init($command);
    $self->_cmd_flush();

    my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command;
    if (!defined $callback) {
        $self->_recv($tag, undef, $cmd);
    }
    else {
        my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1
                : $$command =~ /\AUID SEARCH / ? $tag # for RFC 4466's tag-string
                : undef;
        $self->_recv($tag, $callback, $cmd, $set);
    }
}


# $self->_recv($tag, [$callback, $command, $set])
#   Wait for a tagged response with the given $tag.  The $callback, if
#   provided, is used to process each untagged response.  $command and
#   $set can further limit the set of responses to apply the callback
#   to.
sub _recv($$;&$$) {
    my ($self, $tag, $callback, $cmd, $set) = @_;

    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, $callback, $cmd, $set);
        }
    }

    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->{_NEW} = 0;

    $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) = @_;

    $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
    my $pcache = $self->{_PCACHE}->{$mailbox} //= {};
    my $cache = $self->{_CACHE}->{$mailbox} //= {};
    $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY};

    $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';
}


sub _kibi($) {
    my $n = shift;
    if ($n < 1024) {
        $n;
    } elsif ($n < 1048576) {
        sprintf '%.2fK', $n / 1024.;
    } elsif ($n < 1073741824) {
        sprintf '%.2fM', $n / 1048576.;
    } else {
        sprintf '%.2fG', $n / 1073741824.;
    }

}



#############################################################################
# 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) ];
        $self->{_LITPLUS} = (grep { uc $_ eq 'LITERAL+' } @{$self->{_CAPABILITIES}}) ? '+' : '';
    }
    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_ASTRING_CHAR+//p ? ${^MATCH} : $self->_string($stream);
}

# Parse and consume an RFC 3501 list-mailbox (1*list-char / string).
sub _list_mailbox($$) {
    my ($self, $stream) = @_;
    return $$stream =~ s/\A$RE_LIST_CHAR+//p ? ${^MATCH} : $self->_string($stream);
}

# Parse and consume an RFC 3501 string (quoted / literal).
sub _string($$) {
    my ($self, $stream) = @_;
    if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) {
        # quoted
        my $str = $1;
        $str =~ s/\\([\x22\x5C])/$1/g;
        return $str;
    }
    elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
        # literal
        (my $lit, $$stream) = $self->_getline($1);
        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;
}

# Parse and consume an RFC 4466 tagged-ext-comp plus a trailing parenthesis
sub _tagged_ext_comp($$$) {
    my ($self, $stream, $ret) = @_;
    my $v = $$stream =~ s/\A\(// ? $self->_tagged_ext_comp(\$_, [])
          : $self->_astring(\$_);
    push @$ret, $v;
    if ($$stream =~ s/\A\)//) {
        return $ret;
    } elsif ($$stream =~ s/\A //) {
        $self->_tagged_ext_comp(\$_, $ret)
    } else {
        $self->panic($$stream);
    }
}

# $self->_resp($buf, [$callback, $cmd, $set] )
#   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 $callback = shift;
    my $cmd = shift;
    my $set = 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($_);
            $callback->($self->{_SELECTED}) if defined $self->{_SELECTED} and defined $callback and $cmd eq 'slurp';
        }
        elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) {
            $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
        }
        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};
                $self->{_NEW} += $1 - $cache->{EXISTS} if $1 > $cache->{EXISTS}; # new mails
            }
            $cache->{EXISTS} = $1;
            $callback->($self->{_SELECTED} // $self->panic(), EXISTS => $1) if defined $callback and $cmd eq 'slurp';
        }
        elsif (/\A([0-9]+) EXPUNGE\z/) {
            $self->panic() unless defined $cache->{EXISTS}; # sanity check
            # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
            if ($self->_enabled('QRESYNC')) {
                $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
                $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.");
            }
            # the new message was expunged before it was synced
            $self->{_NEW} = 0 if $self->{_NEW} == 1 and $cache->{EXISTS} == $1;
            $cache->{EXISTS}--; # explicit EXISTS responses are optional
        }
        elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
            $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
        }
        elsif (s/\AESEARCH( |\z)/$1/) {
            my $tag = $1 if s/\A \(TAG \"($RE_ASTRING_CHAR+)\"\)//;
            my $uid = s/\A UID// ? "UID" : undef;
            my @ret;
            while ($_ ne '') {
                # RFC 4466 "tagged-ext-label" is a valid RFC 3501 "atom"
                s/\A ($RE_ATOM_CHAR+) // or $self->panic();
                my $label = uc($1);
                my $value;
                if (s/\A([0-9,:]+)//) {
                    # RFC 4466 tagged-ext-simple
                    $value = $1;
                } elsif (s/\A\(//) {
                    # RFC 4466 "(" [tagged-ext-comp] ")"
                    $value = s/\A\)// ? [] : $self->_tagged_ext_comp(\$_, []);
                } else {
                    $self->panic();
                }
                # don't use a hash since some extensions might give more
                # than one response for a same key
                push @ret, $label => $value;
            }
            $callback->($uid, @ret) if defined $callback and $cmd eq 'SEARCH'
                and defined $set and $set eq $tag;
        }
        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->_list_mailbox(\$_);
            $self->panic($_) unless $_ eq '';
            $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
            undef $delim if uc $delim eq 'NIL';
            $self->panic($_) if defined $delim and $delim !~ s/\A"\\?(.)"\z/$1/;
            $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->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response")
                if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and
                   ($cmd eq 'NOTIFY' or $cmd eq 'slurp');
            $self->_update_cache_for($mailbox, %status);
            if (defined $callback) {
                if ($cmd eq 'STATUS') {
                    $callback->($mailbox, %status);
                } elsif ($cmd eq 'slurp') {
                    $callback->($mailbox);
                }
            }
        }
        elsif (s/\A([0-9]+) FETCH \(//) {
            $cache->{EXISTS} = $1 if $1 > $cache->{EXISTS};
            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;
            }

            $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
            my $uid = $mail{UID};

            if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
                defined $uid and # /!\ ignore unsolicited FETCH responses without UID, cf RFC 7162 section 3.2.4
                (!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 ];
            }
            if (defined $callback) {
                if ($cmd eq 'FETCH' or $cmd eq 'STORE') {
                    $callback->(\%mail) if defined $uid and in_set($uid, $set);
                } elsif ($cmd eq 'slurp') {
                    $callback->($self->{_SELECTED} // $self->panic(), FETCH => $seq)
                }
            }
        }
        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);
                }
            }
            $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp';
        }
    }
    elsif (s/\A\+// and ($_ eq '' or s/\A //)) {
        # Microsoft Exchange Server 2010 violates RFC 3501 by skipping the trailing ' ' for empty resp-text
        if (defined $callback and $cmd eq 'AUTHENTICATE') {
            my $x = $callback->($_);
            $self->_cmd_extend(\$x);
            $self->_cmd_flush();
        }
    }
    else {
        $self->panic("Unexpected response: ", $_);
    }
}


#############################################################################

return 1;