aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-07-23 04:18:47 +0200
committerGuilhem Moulin <guilhem@fripost.org>2015-07-23 04:35:56 +0200
commite3198504c14ed04edc4f3c317e880602a35385a1 (patch)
tree80e0139df69b7131cb498ab7f6fd4b9c0e8d7a3a
parentc02f784c7510205465d9d19784e6613ad661d428 (diff)
First attempt.
Diffstat
-rw-r--r--Changelog5
-rwxr-xr-ximapsync796
-rw-r--r--lib/Net/IMAP/Sync.pm1495
3 files changed, 2296 insertions, 0 deletions
diff --git a/Changelog b/Changelog
new file mode 100644
index 0000000..4c3a493
--- /dev/null
+++ b/Changelog
@@ -0,0 +1,5 @@
+imapsync (0.1) upstream;
+
+ * Initial release.
+
+ -- Guilhem Moulin <guilhem@guilhem.org> Thu, 23 Jul 2015 04:15:47 +0200
diff --git a/imapsync b/imapsync
new file mode 100755
index 0000000..eb8f652
--- /dev/null
+++ b/imapsync
@@ -0,0 +1,796 @@
+#!/usr/bin/perl -T
+
+#----------------------------------------------------------------------
+# A minimal IMAP4 client for QRESYNC-capable servers
+# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+our $VERSION = '0.1';
+my $NAME = 'imapsync';
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
+ bundling auto_version/;
+
+use List::Util 'first';
+use DBI ();
+use POSIX 'strftime';
+
+use lib 'lib';
+use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
+
+# Clean up PATH
+$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
+delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
+
+my %CONFIG;
+sub usage(;$) {
+ my $rv = shift // 0;
+ print STDERR "TODO $NAME usage\n";
+ exit $rv;
+}
+usage(1) unless GetOptions(\%CONFIG, qw/debug help|h quiet|q oneshot|1/);
+usage(0) if $CONFIG{help};
+
+
+my $CONFFILE = 'sync.ini';
+my $CACHEDIR = './imapsync.cache'; # XXX use a config option
+my $DBFILE = "$CACHEDIR/imap.guilhem.org.db";
+my $LOCKFILE = "$CACHEDIR/.imap.guilhem.org.lck";
+my ($DBH, $IMAP);
+
+
+# Clean after us
+sub clean() {
+ print STDERR "Cleaning...\n" if $CONFIG{debug};
+ unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
+ undef $_ foreach grep defined, map {$IMAP->{$_}->{client}} keys %$IMAP;
+ $DBH->disconnect() if defined $DBH;
+}
+$SIG{$_} = sub { clean(); die "$!\n"; } foreach qw/INT TERM/;
+
+
+#############################################################################
+# Lock the database
+{
+ if (!-d $CACHEDIR) {
+ mkdir $CACHEDIR, 0700 or die "Cannot mkdir $CACHEDIR: $!\n";
+ }
+ elsif (-f $LOCKFILE) {
+ open my $lock, '<', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ my $pid = <$lock>;
+ close $lock;
+ chomp $pid;
+ my $msg = "LOCKFILE '$LOCKFILE' exists.";
+ $msg .= " (Is PID $pid running?)" if defined $pid and $pid =~ /^[0-9]+$/;
+ die $msg, "\n";
+ }
+
+ open my $lock, '>', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ print $lock $$, "\n";
+ close $lock;
+}
+
+
+#############################################################################
+# Open the database and create tables
+
+$DBH = DBI::->connect("dbi:SQLite:dbname=$DBFILE", undef, undef, {
+ AutoCommit => 0,
+ RaiseError => 1,
+ sqlite_see_if_its_a_number => 1, # see if the bind values are numbers or not
+});
+$DBH->do('PRAGMA foreign_keys = ON');
+
+
+{
+ my @schema = (
+ mailboxes => [
+ q{idx INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT},
+ q{mailbox TEXT NOT NULL CHECK (mailbox != '') UNIQUE},
+ q{subscribed BOOLEAN NOT NULL}
+ ],
+ local => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)},
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ remote => [
+ q{idx INTEGER NOT NULL PRIMARY KEY REFERENCES mailboxes(idx)},
+ q{UIDVALIDITY UNSIGNED INT NOT NULL CHECK (UIDVALIDITY > 0)},
+ q{UIDNEXT UNSIGNED INT NOT NULL CHECK (UIDNEXT > 0)},
+ q{HIGHESTMODSEQ UNSIGNED BIGINT NOT NULL CHECK (HIGHESTMODSEQ > 0)}
+ # one-to-one correspondence between local.idx and remote.idx
+ ],
+ mapping => [
+ q{idx INTEGER NOT NULL REFERENCES mailboxes(idx)},
+ q{lUID UNSIGNED INT NOT NULL CHECK (lUID > 0)},
+ q{rUID UNSIGNED INT NOT NULL CHECK (rUID > 0)},
+ q{PRIMARY KEY (idx,lUID)},
+ q{UNIQUE (idx,rUID)}
+ # also, lUID < local.UIDNEXT and rUID < remote.UIDNEXT
+ # mapping.idx must be found among local.idx (and remote.idx)
+ ],
+ );
+
+ # Invariants:
+ # * UIDVALIDITY never changes.
+ # * All changes for UID < {local,remote}.UIDNEXT and MODSEQ <
+ # {local,remote}.HIGHESTMODSEQ have been propagated.
+ # * No local (resp. remote) new message will ever have a UID <= local.UIDNEXT
+ # (resp. <= remote.UIDNEXT).
+ # * Any idx in `local` must be present in `remote` and vice-versa.
+ # * Any idx in `mapping` must be present in `local` and `remote`.
+ while (@schema) {
+ my $table = shift @schema;
+ my $schema = shift @schema;
+ my $sth = $DBH->table_info(undef, undef, $table, 'TABLE', {Escape => 1});
+ my $row = $sth->fetch();
+ die if defined $sth->fetch(); # sanity check
+ unless (defined $row) {
+ $DBH->do("CREATE TABLE $table (".join(', ',@$schema).")");
+ $DBH->commit();
+ }
+ }
+}
+
+sub msg($@) {
+ my $name = shift;
+ return unless @_;
+ my $prefix = strftime "%b %e %H:%M:%S", localtime;
+ $prefix .= " $name" if defined $name;
+ $prefix .= ': ';
+ print STDERR $prefix, @_, "\n";
+}
+
+
+#############################################################################
+# Connect to the local and remote IMAP servers
+
+foreach my $name (qw/local remote/) {
+ my %config = Net::IMAP::Sync::read_config($CONFFILE, $name);
+ $config{$_} = $CONFIG{$_} foreach keys %CONFIG;
+ $config{enable} = 'QRESYNC';
+ $config{name} = $name;
+
+ $IMAP->{$name} = { client => Net::IMAP::Sync::->new(%config) };
+ my $client = $IMAP->{$name}->{client};
+
+ die "Non $_-capable IMAP server.\n" foreach $client->incapable(qw/LIST-EXTENDED LIST-STATUS UIDPLUS/);
+ # XXX We should start by listing all mailboxes matching the user's LIST
+ # criterion, then issue "SET NOTIFY (mailboxes ... (...))". But this
+ # crashes the IMAP client:
+ # http://dovecot.org/pipermail/dovecot/2015-July/101473.html
+ #my $mailboxes = $client->list((uc $config{'subscribed-only'} eq 'TRUE' ? '(SUBSCRIBED)' : '' )
+ # .$config{mailboxes}, 'SUBSCRIBED');
+ # $client->notify('SELECTED', 'MAILBOXES ('.join(' ', keys %$mailboxes).')');
+ $client->notify(qw/SELECTED SUBSCRIBED/) unless $CONFIG{oneshot};
+ # XXX We shouldn't need to ask for STATUS responses here, and use
+ # NOTIFY's STATUS indicator instead. However Dovecot violates RFC
+ # 5464: http://dovecot.org/pipermail/dovecot/2015-July/101474.html
+ @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list(q{"" "*"}, 'SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)' );
+}
+
+
+#############################################################################
+# Synchronize mailbox and subscription lists
+
+sub make_tree(%);
+sub print_tree($%);
+sub mv_tree($$$%);
+sub sync_tree($$%);
+
+# Take a hash of delimiters, and recursively build a tree out of it.
+# For instance ( a => "/", b => "/", "a/c" => ".", "a/c.d" => "/", "a/d" => ".")
+# is transformed into the hash reference
+# { b => {},
+# { a => { "/c" => { ".d" => {} } }
+# , "/d" => {}
+# }
+# }
+sub make_tree(%) {
+ my %delims = @_;
+ my @list = sort {length($a) <=> length($b)} keys %delims;
+
+ my %tree;
+ foreach my $x (@list) {
+ next unless exists $delims{$x}; # already a children of something
+ my %children;
+ foreach (keys %delims) {
+ next unless defined $delims{$x} and s/\A\Q$x$delims{$x}\E/$delims{$x}/;
+ $children{$_} = delete $delims{"$x$_"};
+ }
+ delete $delims{$x};
+ $tree{$x} = make_tree(%children);
+ }
+ return \%tree;
+}
+#sub print_tree($%) {
+# my $indent = shift;
+# my %tree = @_;
+# while (my ($root, $children) = each %tree) {
+# print " "x$indent, '|- ', $root, "\n";
+# print_tree($indent+2, %$children);
+# }
+#}
+
+# Retrun true if $mailbox exists for $name that is, if doesn't have the
+# '\NonExistent' flag set.
+sub exists_mbx($$) {
+ my $name = shift;
+ my $mailbox = shift;
+ my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0;
+}
+# Retrun true if $mailbox is subscribed for $name.
+sub subscribed_mbx($$) {
+ my $name = shift;
+ my $mailbox = shift;
+ my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox};
+ return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0;
+}
+
+# Rename a root recursively in a tree
+sub mv_tree($$$%) {
+ my ($mailboxes, $mbx, $mbx2, %children) = @_;
+ $mailboxes->{$mbx2} = delete $mailboxes->{$mbx};
+ while (my ($root, $children) = each %children) {
+ mv_tree($mailboxes, $mbx.$root, $mbx2.$root, %children);
+ }
+}
+
+# Syncronize mailbox list
+# XXX DELETE and RENAME not tested
+sub sync_tree($$%) {
+ my ($sth, $mbx, %children) = @_;
+ my %exists = map { $_ => exists_mbx($_,$mbx) } qw/local remote/;
+
+ my $rv = 0;
+ if ($exists{local} xor $exists{remote}) {
+ my ($exists,$missing) = $exists{local} ? ('local','remote') : ('remote','local');
+ my ($sth_by_mbx, $sth_by_uidvalidity) = @$sth{($missing.'_by_mbx', $exists.'_by_uidvalidity')};
+
+ # check if there is an entry matching $mbx for $missing in the database
+ $sth_by_mbx->execute($mbx);
+ my $row_by_mbx = $sth_by_mbx->fetch();
+ die if defined $sth_by_mbx->fetch(); # sanity check
+
+ if (defined $row_by_mbx) {
+ # $mbx was seen on $missing during the previous round: it
+ # has either been DELETEd or RENAMEd to another name on
+ # $missing.
+
+ my %uidvalidities = $IMAP->{$missing}->{client}->uidvalidity();
+ my ($idx,$uidvalidity) = @$row_by_mbx;
+ my @mbx2 = grep { $uidvalidities{$_} == $uidvalidity and !exists_mbx($exists,$_) }
+ keys %uidvalidities;
+
+ if ($#mbx2 > 0) {
+ # XXX this is allowed by RFC3501, but we can't guess...
+ msg($missing, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
+ join(',',@mbx2), "\n",
+ "Dunno which one $mbx should be renamed to.");
+ exit 1;
+ }
+ elsif (@mbx2) {
+ # $mbx's known (from the DB) UIDVALIDITY is that of
+ # $missing's $mbx2, which is not in the database and
+ # doesn't exist on $exists
+ msg($exists, "Rename mailbox $mbx to $mbx2[0]");
+ $sth->{rename}->execute($mbx2[0],$idx);
+ $IMAP->{$exists}->{client}->rename($mbx, $mbx2[0]);
+ $DBH->commit();
+ mv_tree($IMAP->{$exists}->{mailboxes}, $mbx, $mbx2[0], %children);
+ $mbx = $mbx2[0];
+ }
+ else {
+ # $mbx's known (from the DB) UIDVALIDITY on $missing
+ # was not found in any of $missing's mailboxes.
+ msg($exists, "Delete mailbox $mbx");
+ push @{$IMAP->{$exists}->{mailboxes}->{$mbx}}, '\NonExistent';
+ $IMAP->{$exists}->{client}->delete($mbx);
+ }
+ }
+ else {
+ # $mbx was never seen on $missing: it has either been
+ # CREATEd or RENAMEd from another name on $exists.
+
+ my ($idx,$mbx2);
+ if (defined (my $uidvalidity = $IMAP->{$exists}->{client}->uidvalidity($mbx))) {
+ $sth_by_uidvalidity->execute($uidvalidity);
+ my $by_uidvalidity = $sth_by_uidvalidity->fetchall_arrayref();
+ if (defined $by_uidvalidity and $#$by_uidvalidity > 0) {
+ # XXX this is allowed by RFC3501, but we can't guess...
+ my @mbx2 = map {$_->[1]} @$by_uidvalidity;
+ msg($exists, "Multiple mailboxes have same UIDVALIDITY $uidvalidity: ",
+ join(',',@mbx2), "\n",
+ "Dunno which one $mbx should be renamed to.");
+ exit 1;
+ }
+ ($idx,$mbx2) = @{$by_uidvalidity->[0]} if defined $by_uidvalidity and @$by_uidvalidity;
+ }
+
+ if (defined $mbx2) {
+ # $mbx's UIDVALIDITY on $exists can be found in the
+ # database as associated with $mbx2, which exists on
+ # $missing but not on $exists
+ msg($missing, "Rename mailbox $mbx2 to $mbx");
+ $sth->{rename}->execute($mbx,$idx);
+ $IMAP->{$missing}->{client}->rename($mbx2, $mbx);
+ $DBH->commit();
+ mv_tree($IMAP->{$missing}->{mailboxes}, $mbx2, $mbx, %children);
+ }
+ else {
+ # $mbx's UIDVALIDITY on $exists has never been found in
+ # the database.
+ msg($missing, "Create mailbox $mbx");
+ $IMAP->{$missing}->{mailboxes}->{$mbx} =
+ grep {lc $_ ne lc '\NonExistent'} @{$IMAP->{$missing}->{mailboxes}->{$mbx} // []};
+ $IMAP->{$missing}->{client}->create($mbx);
+ }
+ }
+ $rv = 1;
+ }
+
+ while (my ($root, $children) = each %children) {
+ my $r = sync_tree($sth, $mbx.$root, %$children);
+ $rv ||= $r;
+ }
+ return $rv;
+}
+
+{
+ my %delims;
+ foreach my $name (qw/local remote/) {
+ while (my ($mbx, $sep) = each %{$IMAP->{$name}->{delims}}) {
+ if (!exists $delims{$mbx}) {
+ $delims{$mbx} = $sep;
+ } else {
+ die "Hierarchy delimeters for mailbox $mbx don't match!\n"
+ unless (!defined $sep and !defined $delims{$mbx}) or
+ (defined $sep and defined $delims{$mbx} and $sep eq $delims{$mbx});
+ }
+ }
+ }
+
+ my $tree = make_tree(%delims);
+ my %sth;
+ $sth{$_.'_by_mbx'} = $DBH->prepare("SELECT idx,UIDVALIDITY FROM mailboxes NATURAL JOIN $_ WHERE mailbox = ?")
+ foreach qw/local remote/;
+ $sth{$_.'_by_uidvalidity'} = $DBH->prepare("SELECT idx,mailbox FROM mailboxes NATURAL JOIN $_ WHERE UIDVALIDITY = ?")
+ foreach qw/local remote/;
+ $sth{rename} = $DBH->prepare("UPDATE mailboxes SET mailbox = ? WHERE idx = ?");
+
+ my $updated = 0;
+ while (my ($mbx,$children) = each %$tree) {
+ #print $mbx, "\n";
+ #print_tree(0, %$children);
+ my $u = sync_tree(\%sth, $mbx, %$children);
+ $updated ||= $u;
+ }
+
+ if ($updated) {
+ # refresh the mailbox list
+ foreach my $name (qw/local remote/) {
+ @{$IMAP->{$name}}{qw/mailboxes delims/} = $IMAP->{$name}->{client}->list(q{"" "*"}, 'SUBSCRIBED');
+ }
+ my %mailboxes;
+ $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
+ foreach my $mbx (keys %mailboxes) {
+ die "Could not sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx);
+ }
+ }
+}
+
+# Syncronize subscription list
+my @SUBSCRIPTIONS;
+{
+ my $sth_search = $DBH->prepare("SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?");
+ my $sth_subscribe = $DBH->prepare("UPDATE mailboxes SET subscribed = ? WHERE idx = ?");
+
+ my %mailboxes;
+ $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}});
+
+ foreach my $mbx (keys %mailboxes) {
+ if (subscribed_mbx('local',$mbx) xor subscribed_mbx('remote',$mbx)) {
+ my ($subscribed,$unsubscribed) = subscribed_mbx('local',$mbx) ? ('local','remote') : ('remote','local');
+
+ $sth_search->execute($mbx);
+ my $row = $sth_search->fetch();
+ die if defined $sth_search->fetch(); # sanity check
+
+ if (defined $row) {
+ my ($idx,$status) = @$row;
+ if ($status) {
+ # $mbx was SUBSCRIBEd before, UNSUBSCRIBE it now
+ msg($subscribed, "Unsubscribe to mailbox $mbx");
+ $sth_subscribe->execute(0,$idx);
+ $IMAP->{$subscribed}->{client}->unsubscribe($mbx);
+ $DBH->commit();
+ $IMAP->{$subscribed}->{mailboxes}->{$mbx} =
+ grep {lc $_ ne lc '\Subscribed'} @{$IMAP->{$subscribed}->{mailboxes}->{$mbx} // []};
+ }
+ else {
+ # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now
+ msg($unsubscribed, "Subscribe to mailbox $mbx");
+ $sth_subscribe->execute(1,$idx);
+ $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
+ $DBH->commit();
+ $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
+ push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
+ }
+ }
+ else {
+ # $mbx is unknown; assume the user wants to SUBSCRIBE
+ msg($unsubscribed, "Subscribe to mailbox $mbx");
+ $IMAP->{$unsubscribed}->{client}->subscribe($mbx);
+ $IMAP->{$unsubscribed}->{mailboxes}->{$mbx} //= [];
+ push @{$IMAP->{$unsubscribed}->{mailboxes}->{$mbx}}, '\Subscribed';
+ }
+ }
+ push @SUBSCRIPTIONS, $mbx if subscribed_mbx('local', $mbx) and
+ subscribed_mbx('remote',$mbx);
+ }
+}
+
+# Clean database: remove mailboxes that no longer exist
+{
+ my $sth = $DBH->prepare("SELECT idx,mailbox,subscribed FROM mailboxes");
+ my $sth_delete_mailboxes = $DBH->prepare("DELETE FROM mailboxes WHERE idx = ?");
+ my $sth_delete_local = $DBH->prepare("DELETE FROM local WHERE idx = ?");
+ my $sth_delete_remote = $DBH->prepare("DELETE FROM remote WHERE idx = ?");
+ my $sth_delete_mapping = $DBH->prepare("DELETE FROM mapping WHERE idx = ?");
+
+ my @idx;
+ $sth->execute();
+ while (defined (my $row = $sth->fetch)) {
+ my ($idx,$mbx,$subscribed) = @$row;
+ if (!exists_mbx('local',$mbx) and !exists_mbx('remote',$mbx)) {
+ $_->execute($idx) foreach ($sth_delete_mapping,$sth_delete_local,$sth_delete_remote);
+ $sth_delete_mailboxes->execute($idx) if
+ !exists $IMAP->{local}->{mailboxes}->{$mbx} and
+ !exists $IMAP->{remote}->{mailboxes}->{$mbx};
+ $DBH->commit();
+ }
+ }
+}
+
+
+
+#############################################################################
+# Synchronize messages
+# Consider only the mailboxes in @ARGV, if the list is non-empty.
+
+my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+undef $IMAP;
+
+
+# Get all cached states from the database.
+my $STH_GET_CACHE = $DBH->prepare(q{
+ SELECT mailbox,
+ l.UIDVALIDITY as lUIDVALIDITY, l.UIDNEXT as lUIDNEXT, l.HIGHESTMODSEQ as lHIGHESTMODSEQ,
+ r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ
+ FROM mailboxes m JOIN local l ON m.idx = l.idx JOIN remote r ON m.idx = r.idx
+});
+
+# Get the index associated with a mailbox.
+my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx FROM mailboxes WHERE mailbox = ?});
+
+# Find local/remote UID from the map.
+my $STH_GET_LOCAL_UID = $DBH->prepare("SELECT lUID FROM mapping WHERE idx = ? and rUID = ?");
+my $STH_GET_REMOTE_UID = $DBH->prepare("SELECT rUID FROM mapping WHERE idx = ? and lUID = ?");
+
+# Delete a (idx,lUID,rUID) association.
+# /!\ Don't commit before the messages have actually been EXPUNGEd on
+# both sides!
+my $STH_DELETE_MAPPING = $DBH->prepare("DELETE FROM mapping WHERE idx = ? and lUID = ?");
+
+# Update the HIGHESTMODSEQ.
+my $STH_UPDATE_LOCAL_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE local SET HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE_HIGHESTMODSEQ = $DBH->prepare(q{UPDATE remote SET HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Update the HIGHESTMODSEQ and UIDNEXT.
+my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?});
+
+# Add a new mailbox.
+my $STH_NEWMAILBOX = $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)});
+my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
+my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,?,?)});
+
+# Insert a (idx,lUID,rUID) association.
+my $STH_INSERT_MAPPING = $DBH->prepare("INSERT INTO mapping (idx,lUID,rUID) VALUES (?,?,?)");
+
+
+# Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness.
+$STH_GET_CACHE->execute();
+while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) {
+ $lIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{lUIDVALIDITY},
+ UIDNEXT => $row->{lUIDNEXT},
+ HIGHESTMODSEQ => $row->{lHIGHESTMODSEQ}
+ );
+ $rIMAP->set_cache($row->{mailbox},
+ UIDVALIDITY => $row->{rUIDVALIDITY},
+ UIDNEXT => $row->{rUIDNEXT},
+ HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ}
+ );
+}
+
+
+# Sync known messages. Since pull_updates is the last method call on
+# $lIMAP and $rIMAP, it is safe to call get_cache on either object after
+# this function, in order to update the HIGHESTMODSEQ.
+# Return true if an update was detected, and false otherwise
+sub sync_known_messages($) {
+ my $idx = shift;
+ my $update = 0;
+
+ # loop since processing might produce VANISHED or unsollicited FETCH responses
+ while (1) {
+ my ($lVanished, $lModified) = $lIMAP->pull_updates();
+ my ($rVanished, $rModified) = $rIMAP->pull_updates();
+
+ # repeat until we have nothing pending
+ return $update unless %$lModified or %$rModified or @$lVanished or @$rVanished;
+ $update = 1;
+
+ # process VANISHED messages
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (@$lVanished or @$rVanished) {
+ my %lVanished = map {$_ => 1} @$lVanished;
+ my %rVanished = map {$_ => 1} @$rVanished;
+
+ # For each vanished UID, get the corresponding one on the
+ # other side (from the DB); consider it as to be removed if
+ # it hasn't been removed already.
+
+ my (@lToRemove, @rToRemove);
+ foreach my $lUID (@$lVanished) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ }
+ elsif (!exists $rVanished{$rUID}) {
+ push @rToRemove, $rUID;
+ }
+ }
+ foreach my $rUID (@$rVanished) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ warn "WARNING: Couldn't find a matching lUID for (idx,rUID) = ($idx,$rUID)\n";
+ }
+ elsif (!exists $lVanished{$lUID}) {
+ push @lToRemove, $lUID;
+ }
+ }
+
+ $lIMAP->remove(@lToRemove) if @lToRemove;
+ $rIMAP->remove(@rToRemove) if @rToRemove;
+
+ # remove existing mappings
+ foreach my $lUID (@$lVanished, @lToRemove) {
+ my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
+ die if $r > 1; # sanity check
+ warn "WARNING: Couldn't delete (idx,lUID) pair ($idx,$lUID)\n" if $r == 0;
+ }
+ }
+
+ # process FLAG updates
+ # /!\ this might modify the VANISHED or MODIFIED cache!
+ if (%$lModified or %$rModified) {
+ my (%lToUpdate, %rToUpdate);
+
+ # Take flags updates on both sides, and get the
+ # corresponding UIDs on the other side (from the DB).
+ # If it wasn't modified there, make it such; if it was
+ # modified with the same flags list, ignore that message;
+ # otherwise there is a conflict, and take the union.
+ #
+ # Group by flags in order to limit the number of round
+ # trips.
+
+ while (my ($lUID,$lFlags) = each %$lModified) {
+ $STH_GET_REMOTE_UID->execute($idx, $lUID);
+ my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
+ die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $rUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,lUID) = ($idx,$lUID)\n";
+ }
+ elsif (defined (my $rFlags = $rModified->{$rUID})) {
+ unless ($lFlags eq $rFlags) {
+ my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
+ my $flags = join ' ', sort(keys %flags);
+ warn "WARNING: Conflicting FLAG update for lUID $lUID ($lFlags) and".
+ "rUID $rUID ($rFlags). Setting both to the union ($flags).\n";
+ $lToUpdate{$flags} //= [];
+ push @{$lToUpdate{$flags}}, $lUID;
+ $rToUpdate{$flags} //= [];
+ push @{$rToUpdate{$flags}}, $rUID;
+ }
+ }
+ else {
+ $rToUpdate{$lFlags} //= [];
+ push @{$rToUpdate{$lFlags}}, $rUID;
+ }
+ }
+ while (my ($rUID,$rFlags) = each %$rModified) {
+ $STH_GET_LOCAL_UID->execute($idx, $rUID);
+ my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
+ die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
+ if (!defined $lUID) {
+ warn "WARNING: Couldn't find a matching rUID for (idx,rUID) = ($idx,$rUID)\n";
+ }
+ elsif (!exists $lModified->{$lUID}) {
+ # conflicts are taken care of above
+ $lToUpdate{$rFlags} //= [];
+ push @{$lToUpdate{$rFlags}}, $lUID;
+ }
+ }
+
+ while (my ($lFlags,$lUIDs) = each %lToUpdate) {
+ $lIMAP->push_flag_updates($lFlags, @$lUIDs);
+ }
+ while (my ($rFlags,$rUIDs) = each %rToUpdate) {
+ $rIMAP->push_flag_updates($rFlags, @$rUIDs);
+ }
+ }
+ }
+}
+
+
+# Sync known and new messages
+sub sync_messages($$) {
+ my ($idx, $mailbox) = @_;
+
+ my %mapping;
+ foreach my $source (qw/remote local/) {
+ my $target = $source eq 'local' ? $rIMAP : $lIMAP;
+ my $multiappend;
+
+ my @newmails;
+ my $buffer = 0; # sum of the RFC822 sizes in @newmails
+
+ my (@sUID, @tUID);
+
+ # don't fetch again the messages we've just added
+ my @ignore = $source eq 'local' ? keys %mapping : values %mapping;
+
+ ($source eq 'local' ? $lIMAP : $rIMAP)->pull_new_messages(sub(%) {
+ my %mail = @_;
+ return unless exists $mail{RFC822}; # not for us
+
+ my @mail = ($mail{RFC822}, [ grep {lc $_ ne '\recent'} @{$mail{FLAGS}} ], $mail{INTERNALDATE});
+ push @sUID, $mail{UID};
+
+ # use MULTIAPPEND if possible (RFC 3502) to save round-trips
+ $multiappend //= !$target->incapable('MULTIAPPEND');
+
+ if (!$multiappend) {
+ my ($uid) = $target->append($mailbox, @mail);
+ push @tUID, $uid;
+ }
+ else {
+ # proceed by batch of 1MB to save roundtrips without blowing up the memory
+ if (@newmails and $buffer + length($mail{RFC822}) > 1048576) {
+ push @tUID, $target->append($mailbox, @newmails);
+ @newmails = ();
+ $buffer = 0;
+ }
+ push @newmails, @mail;
+ $buffer += length $mail{RFC822};
+ }
+ }, @ignore);
+ push @tUID, $target->append($mailbox, @newmails) if @newmails;
+
+ die unless $#sUID == $#tUID; # sanity check
+ foreach my $k (0 .. $#sUID) {
+ my ($lUID,$rUID) = $source eq 'local' ? ($sUID[$k],$tUID[$k]) : ($tUID[$k],$sUID[$k]);
+ die if exists $mapping{$lUID}; # sanity check
+ $mapping{$lUID} = $rUID;
+ }
+ }
+
+ # new mailbox
+ if (!defined $$idx) {
+ my $subscribed = grep { $_ eq $mailbox} @SUBSCRIPTIONS ? 1 : 0;
+ $STH_NEWMAILBOX->execute($mailbox, $subscribed);
+ $STH_GET_INDEX->execute($mailbox);
+ ($$idx) = $STH_GET_INDEX->fetchrow_array();
+ die if !defined $$idx or defined $STH_GET_INDEX->fetchrow_arrayref(); # sanity check
+
+ # there might be flag updates pending
+ sync_known_messages($$idx);
+ $STH_INSERT_LOCAL->execute($$idx, $lIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
+ $STH_INSERT_REMOTE->execute($$idx, $rIMAP->get_cache(qw/UIDVALIDITY UIDNEXT HIGHESTMODSEQ/));
+ }
+ else {
+ # update known mailbox
+ sync_known_messages($$idx);
+ $STH_UPDATE_LOCAL->execute($lIMAP->get_cache( qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
+ $STH_UPDATE_REMOTE->execute($rIMAP->get_cache(qw/UIDNEXT HIGHESTMODSEQ/), $$idx);
+ }
+
+ while (my ($lUID,$rUID) = each %mapping) {
+ $STH_INSERT_MAPPING->execute($$idx, $lUID, $rUID);
+ }
+ $DBH->commit();
+}
+
+
+
+# Wait for notifications on either IMAP server, up to $timout. Then
+# issue a NOOP so the connection doesn't terminate for inactivity.
+sub wait_notifications(;$) {
+ my $timeout = shift // 300;
+
+ while ($timeout > 0) {
+ my $r1 = $lIMAP->slurp();
+ my $r2 = $rIMAP->slurp();
+ last if $r1 or $r2; # got update!
+
+ sleep 1;
+ if (--$timeout == 0) {
+ $lIMAP->noop();
+ $rIMAP->noop();
+ }
+ }
+}
+
+
+my ($mailbox, $idx);
+while(1) {
+ while(1) {
+ my $cache;
+ my $update = 0;
+ if (defined $mailbox and ($lIMAP->is_dirty($mailbox) or $rIMAP->is_dirty($mailbox))) {
+ # $mailbox is dirty on either the local or remote mailbox
+ sync_messages(\$idx, $mailbox);
+ }
+ else {
+ $mailbox = $lIMAP->next_dirty_mailbox(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // last;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case insensitive
+
+ $STH_GET_INDEX->execute($mailbox);
+ ($idx) = $STH_GET_INDEX->fetchrow_array();
+ die if defined $STH_GET_INDEX->fetch(); # sanity check
+
+ $lIMAP->select($mailbox);
+ $rIMAP->select($mailbox);
+
+ # sync updates to known messages before fetching new messages
+ if (defined $idx and sync_known_messages($idx)) {
+ # get_cache is safe after pull_update
+ $STH_UPDATE_LOCAL_HIGHESTMODSEQ->execute( $lIMAP->get_cache('HIGHESTMODSEQ'), $idx);
+ $STH_UPDATE_REMOTE_HIGHESTMODSEQ->execute($rIMAP->get_cache('HIGHESTMODSEQ'), $idx);
+ $DBH->commit();
+ }
+ sync_messages(\$idx, $mailbox);
+ }
+ }
+ # clean state!
+ exit 0 if $CONFIG{oneshot};
+ wait_notifications(900);
+}
+
+END { clean (); }
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
new file mode 100644
index 0000000..b952546
--- /dev/null
+++ b/lib/Net/IMAP/Sync.pm
@@ -0,0 +1,1495 @@
+#----------------------------------------------------------------------
+# A minimal IMAP4 client for QRESYNC-capable servers
+# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+package Net::IMAP::Sync v0.0.1;
+use warnings;
+use strict;
+
+use Config::Tiny ();
+use List::Util 'first';
+use Socket 'SO_KEEPALIVE';
+use POSIX 'strftime';
+
+use Exporter 'import';
+BEGIN {
+ our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/;
+}
+
+
+# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'.
+my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/;
+my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/;
+my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
+
+# Map each option to a regexp validating its values.
+my %OPTIONS = (
+ host => qr/\A([0-9a-zA-Z:.-]+)\z/,
+ port => qr/\A([0-9]+)\z/,
+ type => qr/\A(imaps?|preauth)\z/,
+ STARTTLS => qr/\A(true|false)\z/i,
+ username => qr/\A([\x01-\x7F]+)\z/,
+ password => qr/\A([\x01-\x7F]+)\z/,
+ auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
+ command => qr/\A(\P{Control}+)\z/,
+ 'read-only' => qr/\A(TRUE|FALSE)\z/i,
+ SSL_ca_path => qr/\A(\P{Control}+)\z/,
+ SSL_cipher_list => qr/\A(\P{Control}+)\z/,
+ SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
+);
+
+
+#############################################################################
+# Utilities
+
+# read_config($conffile, $section, %opts)
+# Read $conffile's default section, then $section (which takes
+# precedence). %opts extends %OPTIONS and maps each option to a
+# regexp validating its values.
+sub read_config($$%) {
+ my $conffile = shift;
+ my $section = shift;
+ my %opts = (%OPTIONS, @_);
+
+ die "No such config file $conffile\n"
+ unless defined $conffile and -f $conffile and -r $conffile;
+
+ my $h = Config::Tiny::->read($conffile);
+ die "No such section $section\n" unless defined $h->{$section};
+
+ my $conf = $h->{_}; # default section
+ $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}};
+
+ # default values
+ $conf->{type} //= 'imaps';
+ $conf->{host} //= 'localhost';
+ $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef;
+ $conf->{auth} //= 'PLAIN LOGIN';
+ $conf->{STARTTLS} //= 'TRUE';
+
+ # untaint and validate the config
+ foreach my $k (keys %$conf) {
+ die "Invalid option $k\n" unless defined $opts{$k};
+ next unless defined $conf->{$k};
+ die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k};
+ $conf->{$k} = $1;
+ }
+ return %$conf;
+}
+
+
+# compact_set(@set).
+# Compact the UID or sequence number set @set, which must be
+# non-empty and may not contain '*'. (Duplicates are allowed, but
+# are removed).
+sub compact_set(@) {
+ my @set = sort {$a <=> $b} @_;
+ my $min = my $max = shift @set // die 'Empty range';
+ my $set;
+
+ while (@set) {
+ my $k = shift @set;
+ if ($k < $max) {
+ die "Non-sorted range: $k < $max"; # sanity check
+ }
+ elsif ($k == $max) { # skip duplicates
+ }
+ elsif ($k == $max + 1) {
+ $max++;
+ }
+ else {
+ $set .= ',' if defined $set;
+ $set .= $min == $max ? $min : "$min:$max";
+ $min = $max = $k;
+ }
+ }
+
+ $set .= ',' if defined $set;
+ $set .= $min == $max ? $min : "$min:$max";
+ return $set;
+}
+
+
+# in_set($x, $set)
+# Return true if the UID or sequence number $x belongs to the set $set.
+# /!\ The highest number in the mailbox, "*" should not appear by
+# itself (other than in a range).
+sub in_set($$) {
+ my ($x, $set) = @_;
+ foreach my $r (split /,/, $set) {
+ if ($r =~ /\A([0-9]+)\z/) {
+ return 1 if $x == $1;
+ }
+ elsif ($r eq '*' or $r eq '*:*') {
+ warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
+ return 1;
+ }
+ elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
+ return 1 if $1 <= $x;
+ }
+ elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) {
+ my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ return 1 if $min <= $x and $x <= $max;
+ }
+ }
+ return 0;
+}
+
+
+# quote($str)
+# Quote the given string if needed, or make it a (synchronizing)
+# literal. The literals will later be made non-synchronizing if the
+# server is LITERAL+-capable (RFC 2088).
+sub quote($) {
+ my $str = shift;
+ if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) {
+ return $str;
+ }
+ elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) {
+ $str =~ s/([\x22\x5C])/\\$1/g;
+ return "\"$str\"";
+ }
+ else {
+ return "{".length($str)."}\r\n".$str;
+ }
+}
+
+
+
+#############################################################################
+# Public interface
+# /!\ While this module can be used with non QRESYNC-capable (or non
+# QRESYNC-enabled) servers, there is no internal cache mapping sequence
+# numbers to UIDs, so EXPUNGE responses are ignored.
+
+# The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status
+# ('OK'/'NO'/'BAD') condition for the last command issued.
+our $IMAP_cond;
+
+# The response text for the last command issued (prefixed with the status
+# condition but without the tag).
+our $IMAP_text;
+
+
+# Create a new Net::IMAP::Sync object. Connect to the server,
+# upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and
+# update the CAPABILITY list.
+# In addition to the %OPTIONS above, valid parameters include:
+#
+# - 'debug': Enable debug messages.
+#
+# - 'enable': An extension or array reference of extensions to ENABLE
+# (RFC 5161) after entering AUTH state. Croak if the server did not
+# advertize "ENABLE" in its CAPABILITY list or does not reply with
+# an untagged ENABLED response with all the given extensions.
+#
+# - 'STDERR': Where to log debug and informational messages (default:
+# STDERR)
+#
+# - 'name': An optional instance name to include in log messages.
+#
+# - 'read-only': Use only commands that don't modify the server state.
+# In particular, use EXAMINE in place of SELECT for mailbox
+# selection.
+#
+# - 'extra-attrs': An attribute or list of extra attributes to FETCH
+# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
+# BODY.PEEK[]).
+#
+sub new($%) {
+ my $class = shift;
+ my $self = { @_ };
+ bless $self, $class;
+
+ if ($self->{type} eq 'preauth') {
+ require 'IPC/Open2.pm';
+ my $command = $self->{command} // $self->fail("Missing preauth command");
+ my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, split(/ /, $command))
+ or $self->panic("Can't fork: $!");
+ }
+ else {
+ my %args = (Proto => 'tcp', Blocking => 1);
+ $args{PeerHost} = $self->{host} // $self->fail("Missing option host");
+ $args{PeerPort} = $self->{port} // $self->fail("Missing option port");
+
+ my $socket;
+ if ($self->{type} eq 'imap') {
+ require 'IO/Socket/INET.pm';
+ $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
+ }
+ else {
+ my $fpr = delete $self->{SSL_fingerprint};
+ $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
+ require 'IO/Socket/SSL.pm';
+ $socket = IO::Socket::SSL->new(%args)
+ or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+
+ # ensure we're talking to the right server
+ $self->_fingerprint_match($socket, $fpr) if defined $fpr;
+ }
+
+ $socket->sockopt(SO_KEEPALIVE, 1);
+ $self->{$_} = $socket for qw/STDOUT STDIN/;
+ }
+ $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
+
+ # command counter
+ $self->{_TAG} = 0;
+
+ # internal cache, constantly updated to reflect the current server
+ # state for each mailbox
+ $self->{_CACHE} = {};
+
+ # persistent cache, describing the last clean (synced) state
+ $self->{_PCACHE} = {};
+
+ # list of UIDs for which the server a VANISHED or VANISHED (EARLIER)
+ # response. /!\ requires a QRESYNC-capable server!
+ # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
+ # are considered.
+ $self->{_VANISHED} = [];
+
+ # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH
+ # response with the FLAGS attribute. The \Recent flag is always
+ # omitted from the FLAG list. MODSEQ is always present, and the
+ # value [ MODSEQ, FLAGS ] is updated if another FETCH response with
+ # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG
+ # list of the message is considered unknown and should be retrieved
+ # manually.
+ # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT}
+ # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ}
+ # are considered.
+ $self->{_MODIFIED} = {};
+
+ # whether we're allowed to to use read-write command
+ $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1;
+
+ # where to log
+ $self->{STDERR} //= \*STDERR;
+
+ # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
+ # (cf RFC 3501 section 3)
+ $self->{_STATE} = '';
+
+ # wait for the greeting
+ my $x = $self->_getline();
+ $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
+ $IMAP_cond = $1;
+ $IMAP_text = $1.' '.$x;
+
+ # try to update the cache (eg, capabilities)
+ $self->_resp_text($x);
+
+ if ($IMAP_cond eq 'OK') {
+ # login required
+ $self->{_STATE} = 'UNAUTH';
+ my @caps = $self->capabilities();
+
+ if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'FALSE') { # RFC 2595 section 5.1
+ $self->fail("Server did not advertize STARTTLS capability.")
+ unless grep {$_ eq 'STARTTLS'} @caps;
+
+ require 'IO/Socket/SSL.pm';
+ $self->_send('STARTTLS');
+
+ my $fpr = delete $self->{SSL_fingerprint};
+ my %sslargs = %$self{ grep /^SSL_/, keys %$self };
+ IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
+ or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+
+ # ensure we're talking to the right server
+ $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr;
+
+ # refresh the previous CAPABILITY list since the previous one could have been spoofed
+ delete $self->{_CAPABILITIES};
+ @caps = $self->capabilities();
+ }
+
+ $self->fail("Logins are disabled.") if grep {$_ eq 'LOGINDISABLED'} @caps;
+ my @mechs = grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps;
+ my $mech = (grep defined, map {my $m = $_; grep {$m eq $_} @mechs ? $m : undef}
+ split(/ /, $self->{auth}))[0];
+ $self->fail("Failed to choose an authentication mechanism") unless defined $mech;
+
+ my ($command, $callback);
+ my ($username, $password) = @$self{qw/username password/};
+
+ if ($mech eq 'LOGIN') {
+ $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
+ $command = join ' ', 'LOGIN', quote($username), quote($password);
+ }
+ elsif ($mech eq 'PLAIN') {
+ require 'MIME/Base64.pm';
+ $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/;
+ $command = "AUTHENTICATE $mech";
+ my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, '');
+ $callback = sub($) {return $credentials};
+ }
+ else {
+ $self->fail("Unsupported authentication mechanism: $mech");
+ }
+
+ delete $self->{password}; # no need to remember passwords
+ $self->_send($command, $callback);
+ unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) {
+ # refresh the CAPABILITY list since the previous one had only pre-login capabilities
+ delete $self->{_CAPABILITIES};
+ $self->capabilities();
+ }
+ }
+
+ $self->{_STATE} = 'AUTH';
+ my @extensions = !defined $self->{enable} ? ()
+ : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
+ : ($self->{enable});
+ if (@extensions) {
+ $self->fail("Server did not advertize ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE');
+ $self->_send('ENABLE '.join(' ',@extensions));
+ my @enabled = @{$self->{_ENABLED} // []};
+ $self->fail("Could not ENABLE $_") foreach
+ grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions;
+ }
+
+ return $self;
+}
+
+
+# Close handles when the Net::IMAP::Sync object is destroyed.
+sub DESTROY($) {
+ my $self = shift;
+ foreach (qw/STDIN STDOUT/) {
+ $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
+ }
+ $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened()
+ and $self->{STDERR} ne \*STDERR;
+}
+
+
+# $self->log($message, [...])
+# Log a $message.
+sub log($@) {
+ my $self = shift;
+ return unless @_;
+ my $prefix = strftime "%b %e %H:%M:%S", localtime;
+ $prefix .= " $self->{name}" if defined $self->{name};
+ $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
+ $prefix .= ': ';
+ my $stderr = $self->{STDERR};
+ print $stderr $prefix, @_, "\n";
+}
+
+
+# $self->warn($warning, [...])
+# Log a $warning.
+sub warn($$@) {
+ my $self = shift;
+ $self->log('WARNING: ', @_);
+}
+
+
+# $self->fail($error, [...])
+# Log an $error and exit with return value 1.
+sub fail($$@) {
+ my $self = shift;
+ $self->log('ERROR: ', @_);
+ exit 1;
+}
+
+
+# $self->panic($error, [...])
+# Log a fatal $error including the position of the caller, and exit
+# with return value 255.
+sub panic($@) {
+ my $self = shift;
+ my @loc = caller;
+ my $msg = "PANIC at line $loc[2] in $loc[1]";
+ $msg .= ': ' if @_;
+ $self->log($msg, @_);
+ exit 255;
+}
+
+
+# $self->capabilities()
+# Return the capability list of the IMAP4 server. The list is cached,
+# and a CAPABILITY command is only issued if the cache is empty.
+sub capabilities($) {
+ my $self = shift;
+ $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}};
+ $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1');
+ return @{$self->{_CAPABILITIES}};
+}
+
+
+# $self->incapable(@capabilities)
+# In list context, return the list capabilties from @capabilities
+# which were NOT advertized by the server. In scalar context, return
+# the length of said list.
+sub incapable($@) {
+ my ($self, @caps) = @_;
+ my @mycaps = $self->capabilities();
+ grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps;
+}
+
+
+# $self->search($criterion)
+# Issue an UID SEARCH command with the given $criterion. Return the
+# list of matching UIDs.
+sub search($$) {
+ my ($self, $crit) = @_;
+ my @res;
+ $self->_send('UID SEARCH '.$crit, sub(@) {push @res, @_});
+ return @res
+}
+
+
+# $self->select($mailbox)
+# $self->examine($mailbox)
+# Issue a SELECT or EXAMINE command for the $mailbox. (Always use
+# EXAMINE if the 'read-only' flag is set.) Upon success, change the
+# state to SELECTED, otherwise go back to AUTH.
+sub select($$) {
+ my $self = shift;
+ my $mailbox = shift;
+ my $cmd = $self->{'read-only'} ? 'EXAMINE' : 'SELECT';
+ $self->_select_or_examine($cmd, $mailbox);
+}
+sub examine($$) {
+ my $self = shift;
+ my $mailbox = shift;
+ $self->_select_or_examine('EXAMINE', $mailbox);
+}
+
+
+# $self->logout()
+# Issue a LOGOUT command. Change the state to LOGOUT.
+sub logout($) {
+ my $self = shift;
+ $self->_send('LOGOUT');
+ $self->{_STATE} = 'LOGOUT';
+ undef $self;
+}
+
+
+# $self->noop()
+# Issue a NOOP command.
+sub noop($) {
+ shift->_send('NOOP');
+}
+
+
+# $self->create($mailbox)
+# $self->delete($mailbox)
+# CREATE or DELETE $mailbox. Requires the 'read-only' flag to be unset.
+sub create($$) {
+ my ($self, $mailbox) = @_;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ $self->_send("CREATE ".quote($mailbox));
+}
+sub delete($$) {
+ my ($self, $mailbox) = @_;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ #$self->_send("DELETE ".quote($mailbox));
+ delete $self->{_CACHE}->{$mailbox};
+ delete $self->{_PCACHE}->{$mailbox};
+}
+
+
+# $self->rename($oldname, $newname)
+# RENAME the mailbox $oldname to $newname. Requires the 'read-only'
+# flag to be unset.
+sub rename($$$) {
+ my ($self, $from, $to) = @_;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ $self->_send("RENAME ".quote($from).' '.quote($to));
+ $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from};
+ $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from};
+}
+
+
+# $self->subscribe($mailbox)
+# $self->unsubscribe($mailbox)
+# SUBSCRIBE or UNSUBSCRIBE $mailbox. Requires the 'read-only' flag to
+# be unset.
+sub subscribe($$) {
+ my ($self, $mailbox) = @_;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ $self->_send("SUBSCRIBE ".quote($mailbox));
+}
+sub unsubscribe($$) {
+ my ($self, $mailbox) = @_;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ $self->_send("UNSUBSCRIBE ".quote($mailbox));
+}
+
+
+# $self->list($criterion, @parameters)
+# Issue a LIST command with the given $criterion and @parameters.
+# Return a pair where the first component is a hash reference of
+# matching mailboxes and their flags, and the second component is a
+# hash reference of matching mailboxes and their hierarchy delimiter
+# (or undef for flat mailboxes).
+sub list($$@) {
+ my $self = shift;
+ my $crit = shift;
+ my %mailboxes;
+ my %delims;
+ $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''),
+ sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} );
+ return (\%mailboxes, \%delims);
+}
+
+
+# $self->remove($uid, [...])
+# Remove the given $uid list. Croak if the server did not advertize
+# "UIDPLUS" (RFC 4315) in its CAPABILITY list.
+# Successfully EXPUNGEd UIDs are removed from the pending VANISHED and
+# MODIFIED lists.
+# Return the list of UIDs that could not be EXPUNGEd.
+sub remove($@) {
+ my $self = shift;
+ my @set = @_;
+ $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.")
+ if $self->incapable('UIDPLUS');
+
+ my $set = compact_set(@set);
+ $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
+ $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS
+
+ my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
+
+ my @failed;
+ foreach my $uid (@set) {
+ if (exists $vanished{$uid}) {
+ # ignore succesfully EXPUNGEd messages
+ delete $vanished{$uid};
+ delete $self->{_MODIFIED}->{$uid};
+ } else {
+ push @failed, $uid;
+ }
+ }
+ $self->{_VANISHED} = [ keys %vanished ];
+
+ $self->warn("Could not EXPUNGE UID(s) ".compact_set(@failed)) if @failed;
+ return @failed;
+}
+
+
+# $self->append($mailbox, RFC822, [FLAGS, [INTERNALDATE, ...]])
+# Issue an APPEND command with the given mails. Croak if the server
+# did not advertize "UIDPLUS" (RFC 4315) in its CAPABILITY list.
+# Providing multiple mails is only allowed for servers advertizing
+# "MULTIAPPEND" (RFC 3502) in their CAPABILITY list.
+# Return the list of UIDs allocated for the new messages.
+sub append($$$@) {
+ my $self = shift;
+ my $mailbox = shift;
+ $self->fail("Server is read-only.") if $self->{'read-only'};
+ $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.")
+ if $self->incapable('UIDPLUS');
+
+ my @appends;
+ while (@_) {
+ my $rfc822 = shift;
+ my $flags = shift;
+ my $internaldate = shift;
+ my $append = '';
+ $append .= '('.join(' ',@$flags).') ' if defined $flags;
+ $append .= '"'.$internaldate.'" ' if defined $internaldate;
+ $append .= "{".length($rfc822)."}\r\n".$rfc822;
+ push @appends, $append;
+ }
+ $self->fail("Server did not advertize MULTIAPPEND (RFC 3502) capability.")
+ if $#appends > 0 and $self->incapable('MULTIAPPEND');
+
+ # dump the cache before issuing the command if we're appending to the current mailbox
+ my ($UIDNEXT, $EXISTS, $cache, %vanished);
+ if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
+ $cache = $self->{_CACHE}->{$mailbox};
+ $UIDNEXT = $cache->{UIDNEXT} // $self->panic();
+ $EXISTS = $cache->{EXISTS} // $self->panic();
+ %vanished = map {$_ => 1} @{$self->{_VANISHED}};
+ }
+
+ $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends));
+ $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text);
+ my ($uidvalidity, $uidset) = ($1, $2);
+ $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity);
+
+ my @uids;
+ foreach (split /,/, $uidset) {
+ if (/\A([0-9]+)\z/) {
+ $UIDNEXT = $1 + 1 if $UIDNEXT < $1;
+ push @uids, $1;
+ } elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1);
+ push @uids, ($min .. $max);
+ $UIDNEXT = $max + 1 if $UIDNEXT < $max;
+ } else {
+ $self->panic($_);
+ }
+ }
+ $self->fail("$uidset contains ".scalar(@uids)." elements while "
+ .scalar(@appends)." messages were appended.")
+ unless $#uids == $#appends;
+
+ # if $mailbox is the current mailbox we need to update the cache
+ if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
+ # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required
+ my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}};
+ delete $vanished2{$_} foreach keys %vanished;
+ my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile
+ $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS;
+ $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 0) < $UIDNEXT;
+ }
+
+ return @uids;
+}
+
+
+# $self->notify(@specifications)
+# Issue a NOTIFY command with the given mailbox @specifications (cf RFC
+# 5465 section 6) to be monitored. Croak if the server did not
+# advertize "NOTIFY" (RFC 5465) in its CAPABILITY list.
+sub notify($@) {
+ my $self = shift;
+ $self->fail("Server did not advertize NOTIFY (RFC 5465) capability.")
+ if $self->incapable('NOTIFY');
+ my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
+ # Be notified of new messages with EXISTS/RECENT responses, but
+ # don't receive unsolicited FETCH responses with a RFC822/BODY[].
+ # It costs us an extra roundtrip, but we need to sync FLAG updates
+ # and VANISHED responses in batch mode, update the HIGHESTMODSEQ,
+ # and *then* issue an explicit UID FETCH command to get new message,
+ # and process each FETCH response with a RFC822/BODY[] attribute as
+ # they arrive.
+ my $command = 'NOTIFY ';
+ $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
+ $self->_send($command);
+}
+
+
+# $self->slurp()
+# Turn on non-blocking IO, try to as many lines as possible, then turn
+# non-blocking IO back off and return the number of lines read.
+# This is mostly useful when waiting for notifications while no
+# command is progress, cf. RFC 5465 (NOTIFY).
+sub slurp($) {
+ my $self = shift;
+ my $read = 0;
+ $self->{STDOUT}->blocking(0) // $self->panic("Can't turn on non-blocking IO: $!");
+ while (defined (my $x = $self->_getline())) {
+ $self->_resp($x);
+ $read++
+ }
+ $self->{STDOUT}->blocking(1) // $self->panic("Can't turn off non-blocking IO: $!");
+ return $read;
+}
+
+
+# $self->set_cache( $mailbox, STATE )
+# Initialize or update the persistent cache, that is, associate a
+# known $mailbox with the last known (synced) state:
+# * UIDVALIDITY
+# * UIDNEXT: Any message the UID of which is at least UIDNEXT is
+# considered new and must be downloaded. (If 0 or missing, all
+# messages in $mailbox are considered new.) Note that while all
+# UIDs in the map are <UIDNEXT, the message with UID UIDNEXT-1 may
+# have been deleted hence may no longer be present in $mailbox.
+# * HIGHESTMODSEQ: Any change with MODSEQ <= HIGHESTMODSEQ have been
+# processed. (Note however that new messages may have a lower
+# MODSEQ.) Always present when UIDNEXT is present.
+sub set_cache($$%) {
+ my $self = shift;
+ my $mailbox = shift // $self->panic();
+ my $cache = $self->{_PCACHE}->{$mailbox} //= {};
+
+ my %status = @_;
+ while (my ($k, $v) = each %status) {
+ if ($k eq 'UIDVALIDITY') {
+ # try to detect UIDVALIDITY changes early (before starting the sync)
+ $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
+ "Need to invalidate the UID cache.")
+ if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
+ }
+ $cache->{$k} = $v;
+ }
+
+ $self->log("Update last clean state for $mailbox: ".
+ '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')')
+ if $self->{debug};
+}
+
+
+# $self->uidvalidity([$mailbox])
+# Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to
+# its UIDVALIDITY if $mailbox is omitted.
+sub uidvalidity($;$) {
+ my $self = shift;
+ my $mailbox = shift;
+ if (defined $mailbox) {
+ my $cache = $self->{_CACHE}->{$mailbox} // return;
+ return $cache->{UIDVALIDITY};
+ }
+ else {
+ my %uidvalidity;
+ while (my ($mbx,$cache) = each %{$self->{_CACHE}}) {
+ $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0;
+ }
+ return %uidvalidity;
+ }
+}
+
+
+# $self->set_cache(@attributes)
+# Return the persistent cache for the mailbox currently selected. If
+# some @attributes are given, return the list of values corresponding
+# to these attributes.
+# /!\ Should only be called right after pull_updates!
+# Croak if there are unprocessed VANISHED responses or FLAG updates.
+sub get_cache($@) {
+ my $self = shift;
+ $self->fail("Invalid method 'get_cache' in state $self->{_STATE}")
+ unless $self->{_STATE} eq 'SELECTED';
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+
+ $self->fail("Pending VANISHED responses!") if @{$self->{_VANISHED}};
+ $self->fail("Pending FLAG updates!") if %{$self->{_MODIFIED}};
+
+ my $cache = $self->{_PCACHE}->{$mailbox};
+ return @_ ? @$cache{@_} : %$cache;
+}
+
+
+# $self->is_dirty($mailbox)
+# Return true if there are pending updates for $mailbox, i.e., its
+# internal cache is newer than its persistent cache.
+sub is_dirty($$) {
+ my ($self, $mailbox) = @_;
+ my $cache = $self->{_CACHE}->{$mailbox} // return 1;
+ my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;
+
+ if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ}
+ and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and
+ defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT}
+ and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+
+# $self->next_dirty_mailbox(@mailboxes)
+# Return the name of a dirty mailbox, or undef if all mailboxes are
+# clean. If @mailbox is non-empty, only consider mailboxes in that
+# list.
+sub next_dirty_mailbox($@) {
+ my $self = shift;
+ my %mailboxes = map {$_ => 1} @_;
+ my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) }
+ keys %{$self->{_CACHE}};
+ if ($self->{debug}) {
+ @dirty ? $self->log("Dirty mailboxes: ".join(', ', @dirty))
+ : $self->log("Clean state!");
+ }
+ return $dirty[0];
+}
+
+
+# $self->pull_updates()
+# Get pending updates (unprocessed VANISHED responses and FLAG
+# updates), and empty these lists from the cache.
+# Finally, update the HIGHESTMODSEQ from the persistent cache to the
+# value found in the internal cache.
+sub pull_updates($) {
+ my $self = shift;
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+ my $pcache = $self->{_PCACHE}->{$mailbox};
+
+ my (@vanished, %modified);
+ unless (defined $pcache->{UIDNEXT} and defined $pcache->{HIGHESTMODSEQ}) {
+ $self->{_MODIFIED} = {};
+ $self->{_VANISHED} = [];
+ }
+ else {
+ my @missing;
+ while (%{$self->{_MODIFIED}}) {
+ while (my ($uid,$v) = each %{$self->{_MODIFIED}}) {
+ # don't filter on the fly (during FETCH responses) because
+ # FLAG updates can arrive while processing pull_new_messages
+ # for instance
+ if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH
+ next unless $uid < $pcache->{UIDNEXT} # out of bounds
+ and $v->[0] > $pcache->{HIGHESTMODSEQ}; # already seen
+ $modified{$uid} = $v->[1];
+ } else {
+ push @missing, $uid;
+ }
+ }
+ $self->{_MODIFIED} = {};
+ $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing;
+ @missing = ();
+ }
+
+ # do that afterwards since the UID FETCH command above can produce VANISHED responses
+ my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
+ my @vanished = keys %vanished;
+ $self->{_VANISHED} = [];
+
+ # ignore FLAG updates on VANISHED messages
+ delete @modified{@vanished};
+ }
+
+ # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT
+ # since there might be new messages)
+ $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ});
+
+ return (\@vanished, \%modified);
+}
+
+
+# $self->pull_new_messages($callback, @ignore)
+# FETCH new messages since the UIDNEXT found in the persistent cache
+# (or 1 in no such UIDNEXT is found), and process each response on the
+# fly with the callback.
+# If an @ignore list is supplied, then these messages are ignored from
+# the UID FETCH range.
+# Finally, update the UIDNEXT from the persistent cache to the value
+# found in the internal cache.
+# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ!
+sub pull_new_messages($$@) {
+ my $self = shift;
+ my $callback = shift;
+ my @ignore = sort { $a <=> $b } @_;
+ my @attrs = !defined $self->{'extra-attrs'} ? ()
+ : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}}
+ : ($self->{'extra-attrs'});
+ my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]';
+
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+ my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1;
+
+ my $range = '';
+ my $first;
+ foreach my $uid (@ignore) {
+ if ($since < $uid) {
+ $first //= $since;
+ $range .= ',' if $range ne '';
+ $range .= $since;
+ $range .= ':'.($uid-1) if $since < $uid-1;
+ $since = $uid+1;
+ }
+ elsif ($since == $uid) {
+ $since++;
+ }
+ }
+
+ $first //= $since;
+ $range .= ',' if $range ne '';
+ # 2^32-1: don't use '*' since the highest UID can be known already
+ $range .= "$since:4294967295";
+
+ my $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT};
+ $self->panic() unless defined $UIDNEXT and $UIDNEXT > 0; # sanity check
+
+ $self->_send("UID FETCH $range ($attrs)", $callback) if $first < $UIDNEXT;;
+
+ # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ
+ # since there might be pending updates)
+ $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{UIDNEXT});
+}
+
+
+# $self->push_flag_updates($flags, @set)
+# Change the flags to each UID in @set to $flags.
+# A flag update fails for mails being updated after the HIGHESTMODSEQ
+# found in the persistent cache; push such messages to the MODIFIED
+# list.
+sub push_flag_updates($$@) {
+ my $self = shift;
+ my $flags = shift;
+ my @set = @_;
+
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+ my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic();
+ my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)";
+
+ my %listed;
+ $self->_send($command, sub(%) { my %mail = @_; $listed{$mail{UID}}++; });
+
+ my %failed;
+ if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) {
+ foreach (split /,/, $1) {
+ if (/\A([0-9]+)\z/) {
+ $failed{$1} = 1;
+ }
+ elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ $failed{$_} = 1 foreach ($min .. $max);
+ }
+ else {
+ $self->panic($_);
+ }
+ }
+ }
+
+ foreach my $uid (@set) {
+ if ($failed{$uid}) {
+ # $uid was listed in the MODIFIED response code
+ $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates
+ delete $self->{_MODIFIED}->{$uid} if
+ # got a FLAG update for $uid; ignore it if it's $flags
+ defined $self->{_MODIFIED}->{$uid}->[1] and
+ $self->{_MODIFIED}->{$uid}->[1] eq $flags;
+ }
+ else {
+ # $uid wasn't listed in the MODIFIED response code
+ next unless defined $self->{_MODIFIED}->{$uid}; # already stored
+ $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check
+ if ($listed{$uid} == 1) {
+ # ignore succesful update
+ delete $self->{_MODIFIED}->{$uid};
+ }
+ elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) {
+ # got multiple FETCH responses for $uid, the last one with $flags
+ delete $self->{_MODIFIED}->{$uid};
+ }
+ }
+ }
+ return keys %failed;
+}
+
+
+#############################################################################
+# Private methods
+
+
+# $self->_fingerprint_match($socket, $fingerprint)
+# Croak unless the fingerprint of the peer certificate of the
+# IO::Socket::SSL object doesn't match the given $fingerprint.
+sub _fingerprint_match($$$) {
+ my ($self, $socket, $fpr) = @_;
+
+ my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
+ my $fpr2 = $socket->get_fingerprint($algo);
+ $fpr =~ s/.*\$//;
+ $fpr2 =~ s/.*\$//;
+ $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2;
+}
+
+
+# $self->_getline([$msg])
+# Read a line from the handle and strip the trailing CRLF.
+sub _getline($;$) {
+ my $self = shift;
+ my $msg = shift // '';
+
+ my $x = $self->{STDOUT}->getline() // return; # non-blocking IO
+ $x =~ s/\r\n\z// or $self->panic($x);
+ $self->log("S: $msg", $x) if $self->{debug};
+ return $x;
+}
+
+
+# $self->_update_cache( ATTRIBUTE => VALUE, [...] )
+# Update the internal cache for the currently selected mailbox with
+# the given attributes and values.
+sub _update_cache($%) {
+ my $self = shift;
+ $self->_update_cache_for($self->{_SELECTED}, @_);
+}
+
+
+# $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] )
+# Update the internal cache for $mailbox with the given attributes and
+# values.
+sub _update_cache_for($$%) {
+ my $self = shift;
+ my $mailbox = shift // $self->panic();
+ my $cache = $self->{_CACHE}->{$mailbox} //= {};
+
+ my %status = @_;
+ while (my ($k, $v) = each %status) {
+ if ($k eq 'UIDVALIDITY') {
+ # try to detect UIDVALIDITY changes early (before starting the sync)
+ $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ",
+ "Need to invalidate the UID cache.")
+ if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v;
+ $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v;
+ }
+ $cache->{$k} = $v;
+ }
+}
+
+
+# $self->_send($command, [$callback])
+# Send the given $command to the server, then wait for the response.
+# (The status condition and response text are respectively placed in
+# $IMAP_cond and $IMAP_text.) Each untagged response received in the
+# meantime is read, parsed and processed. The optional $callback, if
+# given, is executed with all untagged responses associated with the
+# command.
+# In void context, croak unless the server answers with a tagged 'OK'
+# response. Otherwise, return the condition status ('OK'/'NO'/'BAD').
+sub _send($$;&) {
+ my ($self, $command, $callback) = @_;
+ my $cmd = $command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $command;
+ my $set = $command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef;
+
+ # send the command; for servers supporting non-synchronizing
+ # literals, mark literals as such and then the whole command in one
+ # go, otherwise send literals one at a time
+ my $tag = sprintf '%06d', $self->{_TAG}++;
+ my $prefix = $tag.' ';
+ while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
+ my ($str, $len) = ($1, $2);
+ my $lit = substr $command, 0, $len, ''; # consume the literal
+
+ if ($self->_capable('LITERAL+')) { # RFC 2088 LITERAL+
+ $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len+}") if $self->{debug};
+ $self->{STDIN}->print($prefix, $str, "{$len+}\r\n");
+ }
+ else {
+ $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len}") if $self->{debug};
+ $self->{STDIN}->print($prefix, $str, "{$len}\r\n");
+ $self->{STDIN}->flush();
+ my $x = $self->_getline();
+ $x =~ /\A\+ / or $self->panic($x);
+ }
+ $self->{STDIN}->print($lit);
+ $prefix = '';
+ }
+ $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $command) if $self->{debug};
+ $self->{STDIN}->print($prefix, $command, "\r\n");
+ $self->{STDIN}->flush();
+
+ my $r;
+ # wait for the answer
+ while (defined($_ = $self->_getline())) {
+ if (s/\A\Q$tag\E (OK|NO|BAD) //) {
+ $IMAP_cond = $1;
+ $IMAP_text = $1.' '.$_;
+ $self->_resp_text($_);
+ $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK';
+ $r = $1;
+ last;
+ }
+ else {
+ $self->_resp($_, $cmd, $set, $callback);
+ }
+ }
+
+ if (defined $self->{_SELECTED}) {
+ my $mailbox = $self->{_SELECTED};
+ my $cache = $self->{_CACHE}->{$mailbox};
+ # can't keep track of the modification sequences
+ $self->fail("Mailbox $mailbox doesn't support MODSEQ.")
+ if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC');
+ $self->fail("Mailbox $mailbox does not support persistent UIDs.")
+ if defined $cache->{UIDNOTSTICKY};
+ }
+
+ return $r;
+}
+
+
+# $self->_capable($capability, [...])
+# Return true if each $capability is listed in the server's CAPABILITY
+# list.
+sub _capable($@) {
+ my $self = shift;
+ return 0 unless defined $self->{_CAPABILITIES};
+ foreach my $cap (@_) {
+ return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}};
+ }
+ return 1;
+}
+
+
+# $self->_capable($extension)
+# Return true if $extension has been enabled by the server, i.e., the
+# server sent an untagged ENABLED response including it.
+sub _enabled($$) {
+ my $self = shift;
+ my $ext = uc shift;
+ grep {$ext eq uc $_} @{$self->{_ENABLED} // []};
+}
+
+
+# $self->_open_mailbox($mailbox)
+# Initialize the internal and persistent caches for $mailbox, and mark
+# it as selected.
+sub _open_mailbox($$) {
+ my $self = shift;
+ my $mailbox = shift;
+
+ # it is safe to wipe cached VANISHED responses or FLAG updates,
+ # because interesting stuff must have made the mailbox dirty so
+ # we'll get back to it
+ $self->{_VANISHED} = [];
+ $self->{_MODIFIED} = {};
+
+ $self->{_SELECTED} = $mailbox;
+ $self->{_CACHE}->{$mailbox} //= {};
+
+ # always reset EXISTS to keep track of new mails
+ delete $self->{_CACHE}->{$mailbox}->{EXISTS};
+}
+
+
+# $self->_select_or_examine($command, $mailbox)
+# Issue a SELECT or EXAMINE command for the $mailbox. (Always use
+# EXAMINE if the 'read-only' flag is set.) Upon success, change the
+# state to SELECTED, otherwise go back to AUTH.
+sub _select_or_examine($$$) {
+ my $self = shift;
+ my $command = shift;
+ my $mailbox = shift;
+
+ my $pcache = $self->{_PCACHE}->{$mailbox} //= {};
+ my $cache = $self->{_CACHE}->{$mailbox} //= {};
+ $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY};
+
+ $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
+ $command .= ' '.quote($mailbox);
+ $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} "
+ ."1:".($pcache->{UIDNEXT}-1)."))"
+ if $self->_enabled('QRESYNC') and
+ ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 0) > 0;
+
+ if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) {
+ # A mailbox is currently selected and the server advertizes
+ # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox
+ # selection until the [CLOSED] response code has been received:
+ # all responses before the [CLOSED] response code refer to the
+ # previous mailbox ($self->{_SELECTED}), while all subsequent
+ # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
+ $self->{_SELECTED_DELAYED} = $mailbox;
+ }
+ else {
+ $self->_open_mailbox($mailbox);
+ }
+
+ $self->{_STATE} = 'AUTH';
+ if ($self->_send($command) eq 'OK') {
+ $self->{_STATE} = 'SELECTED';
+ } else {
+ delete $self->{_SELECTED};
+ }
+}
+
+
+
+#############################################################################
+# Parsing methods
+#
+
+# Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed.
+sub _resp_text($$) {
+ my $self = shift;
+ local $_ = shift;
+
+ if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) {
+ print STDERR $_, "\n";
+ }
+ elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) {
+ $self->fail($_);
+ }
+ elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) {
+ $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
+ }
+ elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] );
+ }
+ elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache($1 => 1);
+ }
+ elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
+ $self->_update_cache($1 => $2);
+ }
+ elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4551/7162 CONDSTORE/QRESYNC
+ $self->_update_cache(HIGHESTMODSEQ => $1);
+ }
+ elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4551/7162 CONDSTORE/QRESYNC
+ $self->_update_cache(NOMODSEQ => 1);
+ }
+ elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) {
+ # RFC 7162 CONDSTORE/QRESYNC
+ # Update the selected mailbox: previous responses refer to the
+ # previous mailbox ($self->{_SELECTED}), while all subsequent
+ # responses refer to the new mailbox $self->{_SELECTED_DELAYED}.
+ my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic();
+ $self->_open_mailbox($mailbox);
+ }
+ elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) {
+ # RFC 5465 NOTIFY
+ $self->fail($_);
+ }
+ elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) {
+ # RFC 4315 UIDPLUS
+ $self->_update_cache(UIDNOTSTICKY => 1);
+ }
+}
+
+# Parse and consume an RFC 3501 nstring (string / "NIL").
+sub _nstring($$) {
+ my ($self, $stream) = @_;
+ return $$stream =~ s/\ANIL// ? undef : $self->_string($stream);
+}
+
+# Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string).
+sub _astring($$) {
+ my ($self, $stream) = @_;
+ return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream);
+}
+
+# Parse and consume an RFC 3501 string (quoted / literal).
+sub _string($$) {
+ my ($self, $stream) = @_;
+ if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) {
+ # quoted
+ my $str = $1;
+ $str =~ s/\\([\x22\x5C])/$1/g;
+ return $str;
+ }
+ elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
+ # literal
+ my $count = $1;
+ my @acc;
+ my $buf;
+ while ($count > 0) {
+ my $n = $self->{STDOUT}->read($buf, $count);
+ push @acc, $buf;
+ $count -= $n;
+ }
+ $$stream = $self->_getline('[...]');
+ return join ('', @acc);
+ }
+ else {
+ $self->panic($$stream);
+ }
+}
+
+# Parse and consume an RFC 3501 "(" 1*address ")" / "NIL".
+sub _addresses($$) {
+ my ($self, $stream) = @_;
+ return undef if $$stream =~ s/\ANIL//;
+
+ my @addresses;
+ $$stream =~ s/\A\(// or $self->panic($$stream);
+ while ($$stream =~ s/\A ?\(//) {
+ my @addr;
+ push @addr, $self->_nstring($stream); # addr-name
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-adl
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-mailbox
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @addr, $self->_nstring($stream); # addr-host
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ push @addresses, \@addr;
+ }
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ return \@addresses;
+}
+
+# Parse and consume an RFC 3501 envelope
+sub _envelope($$) {
+ my ($self, $stream) = @_;
+ $$stream =~ s/\A\(// or $self->panic($$stream);
+
+ my @envelope;
+ push @envelope, $self->_nstring($stream); # env-date
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-subject
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-from
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-sender
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-reply-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-cc
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_addresses($stream); # env-bcc
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-in-reply-to
+ $$stream =~ s/\A // or $self->panic($$stream);
+ push @envelope, $self->_nstring($stream); # env-message-id
+
+ $$stream =~ s/\A\)// or $self->panic($$stream);
+ return \@envelope;
+}
+
+# $self->_resp($buf, [$cmd, $callback] )
+# Parse an untagged response line or a continuation request line.
+# (The trailing CRLF must be removed.) The internal cache is
+# automatically updated when needed.
+# If a command and callback are given, the callback is be executed
+# for each (parsed) responses associated with the command.
+sub _resp($$;$$$) {
+ my $self = shift;
+ local $_ = shift;
+ my $cmd = shift;
+ my $set = shift;
+ my $callback = shift;
+ my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED};
+
+ if (s/\A\* //) {
+ if (s/\ABYE //) {
+ exit 0;
+ }
+ elsif (s/\A(?:OK|NO|BAD) //) {
+ $self->_resp_text($_);
+ }
+ elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) {
+ $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ];
+ }
+ elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) {
+ $cache->{FLAGS} = [ split / /, $1 ];
+ }
+ elsif (/\A([0-9]+) RECENT\z/) {
+ $cache->{RECENT} = $1;
+ }
+ elsif (/\A([0-9]+) EXISTS\z/) {
+ # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT
+ if (defined $cache->{EXISTS}) {
+ $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS};
+ # the actual UIDNEXT is *at least* that
+ $cache->{UIDNEXT} += $1 - $cache->{EXISTS} if defined $cache->{UIDNEXT};
+ }
+ $cache->{EXISTS} = $1;
+ }
+ elsif (/\A([0-9]+) EXPUNGE\z/) {
+ # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
+ $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
+ $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC');
+ $cache->{EXISTS}--; # explicit EXISTS responses are optional
+ }
+ elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
+ $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
+ }
+ elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) {
+ my ($delim, $flags) = ($2, $1);
+ my @flags = defined $flags ? split(/ /, $flags) : ();
+ my $mailbox = $self->_astring(\$_);
+ $self->panic($_) unless $_ eq '';
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
+ undef $delim if uc $delim eq 'NIL';
+ $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim;
+ $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST';
+ }
+ elsif (s/\ASTATUS //) {
+ my $mailbox = $self->_astring(\$_);
+ /\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_);
+ my %status = split / /, $1;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
+ $self->_update_cache_for($mailbox, %status);
+ $callback->($mailbox, %status) if defined $callback and $cmd eq 'STATUS';
+ }
+ elsif (s/\A([0-9]+) FETCH \(//) {
+ $self->panic("$1 <= $cache->{EXISTS}") unless $1 <= $cache->{EXISTS}; # sanity check
+ my ($seq, $first) = ($1, 1);
+ my %mail;
+ while ($_ ne ')') {
+ unless (defined $first) {
+ s/\A // or $self->panic($_);
+ }
+ if (s/\AUID ([0-9]+)//) {
+ # always present, cf RFC 3501 section 6.4.8
+ $mail{UID} = $1;
+ # the actual UIDNEXT is *at least* that
+ $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} < $1;
+ }
+ if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC
+ # always present in unsolicited FETCH responses if QRESYNC has been enabled
+ $mail{MODSEQ} = $1;
+ $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1;
+ }
+ elsif (s/\AENVELOPE //) {
+ $mail{ENVELOPE} = $self->_envelope(\$_);
+ }
+ elsif (s/\AINTERNALDATE "([^"]+)"//) {
+ $mail{INTERNALDATE} = $1;
+ }
+ elsif (s/\A(?:RFC822|BODY\[\]) //) {
+ $mail{RFC822} = $self->_nstring(\$_);
+ }
+ elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
+ $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
+ }
+ undef $first;
+ }
+
+ my $uid = $mail{UID} // $self->panic(); # sanity check
+ $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
+
+ if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
+ (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or
+ ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) {
+ my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS};
+ $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ];
+ }
+ $callback->(%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set);
+ }
+ elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE
+ $self->{_ENABLED} //= [];
+ push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r));
+ }
+ elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC
+ my $earlier = defined $1 ? 1 : 0;
+ my $set = $2;
+ my $mailbox = $self->{_SELECTED} // $self->panic();
+ my $pcache = $self->{_PCACHE}->{$mailbox};
+ foreach (split /,/, $set) {
+ if (/\A([0-9]+)\z/) {
+ $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional
+ $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that
+ push @{$self->{_VANISHED}}, $1
+ if defined $pcache->{UIDNEXT} and $1 < $pcache->{UIDNEXT};
+ }
+ elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional
+ $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that
+ push @{$self->{_VANISHED}}, grep {$_ < $pcache->{UIDNEXT}} ($min .. $max)
+ if defined $pcache->{UIDNEXT};
+ }
+ }
+ }
+ }
+ elsif (s/\A\+ //) {
+ if (defined $callback and $cmd eq 'AUTHENTICATE') {
+ my $x = $callback->($_);
+ print STDERR "C: ", $x, "\n" if $self->{debug};
+ $self->{STDIN}->print($x, "\r\n");
+ $self->{STDIN}->flush();
+ }
+ }
+ else {
+ $self->panic("Unexpected response: ", $_);
+ }
+}
+
+
+#############################################################################
+
+return 1;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 04:45:18 +0000