From a03b8bfbd26f4c71eaff359d10576afe012d3de1 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 26 Jul 2015 20:02:01 +0200 Subject: Reformulate introduction in the manpage. --- imapsync.1 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/imapsync.1 b/imapsync.1 index 8c22222..0f286ce 100644 --- a/imapsync.1 +++ b/imapsync.1 @@ -12,12 +12,12 @@ imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers .B imapsync\fR performs stateful synchronization between two IMAP4rev1 servers. Such synchronization is made possible by the QRESYNC extension from -[RFC7162]; for convenience reasons support for LIST\-EXTENDED [RFC5258], -LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315] is also required. -Furthermore, support for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502] -is recommended: while they are not needed for \fBimapsync\fR to work, -these extensions greatly improve performance by reducing the number of -required round trips. +[RFC7162]; for convenience reasons servers must also support +LIST\-EXTENDED [RFC5258], LIST\-STATUS [RFC5819] and UIDPLUS [RFC4315]. +Furthermore, while \fBimapsync\fR can work with servers lacking support +for LITERAL+ [RFC2088] and MULTIAPPEND [RFC3502], these extensions +greatly improve performance by reducing the number of required round +trips hence are recommended. .PP Stateful synchronization is only possible for mailboxes supporting -- cgit v1.2.3 From 66b0682010cf24a4d2e92465dd57bcd795d21970 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 27 Jul 2015 22:02:17 +0200 Subject: No longer try to guess whether a mailbox was deleted or renamed. This was too error-prone. Instead, abort if a naming conflict occurs, and provide explicit commands --delete and --rename to delete or rename a mailbox. --- imapsync | 551 +++++++++++++++++++++++---------------------------- imapsync.1 | 57 ++++-- lib/Net/IMAP/Sync.pm | 19 +- 3 files changed, 303 insertions(+), 324 deletions(-) diff --git a/imapsync b/imapsync index 339979c..2a1bfcc 100755 --- a/imapsync +++ b/imapsync @@ -39,23 +39,28 @@ delete @ENV{qw/IFS CDPATH ENV BASH_ENV/}; my %CONFIG; sub usage(;$) { my $rv = shift // 0; - print STDERR "$NAME [OPTIONS] [--] [MAILBOX [..]]\n"; if ($rv) { - print STDERR "Try '$NAME --help' or consult the manpage for more information.\n"; + print STDERR "Usage: $NAME [OPTIONS] [COMMAND] [MAILBOX [..]]\n" + ."Try '$NAME --help' or consult the manpage for more information.\n"; } else { - print STDERR "Synchronize the given MAILBOXes between two QRESYNC-capable IMAP4rev1 servers.\n" - ."Options:\n" - ." --config=FILE Specify an alternate configuration file\n" - ." --repair List the database anomalies and try to repair them\n" - ." -q, --quiet Try to be quiet\n" - ." --debug Turn on debug mode\n" - ."Consult the manpage for more information.\n"; + print STDERR "Usage: $NAME [OPTIONS] [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --repair [MAILBOX [..]]\n" + ." or: $NAME [OPTIONS] --delete MAILBOX [..]\n" + ." or: $NAME [OPTIONS] --rename SOURCE DEST\n" + ."Consult the manpage for more information.\n"; } exit $rv; } -usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q repair debug help|h/); +usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q target=s@ debug help|h repair delete rename/); usage(0) if $CONFIG{help}; +my $COMMAND = do { + my @command = grep {exists $CONFIG{$_}} qw/repair delete rename/; + usage(1) if $#command>0; + $command[0] +}; +usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND eq 'rename' and $#ARGV != 1); +@ARGV = map {uc $_ eq 'INBOX' ? 'INBOX' : $_ } @ARGV; # INBOX is case-insensitive my $CONF = read_config( delete $CONFIG{config} // $NAME @@ -207,7 +212,7 @@ logger(undef, ">>> $NAME $VERSION"); my $IMAP; foreach my $name (qw/local remote/) { my %config = %{$CONF->{$name}}; - $config{$_} = $CONFIG{$_} foreach keys %CONFIG; + $config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/; $config{enable} = 'QRESYNC'; $config{name} = $name; $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD; @@ -229,316 +234,258 @@ foreach my $name (qw/local remote/) { # 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)' ); + + my $list = '"" '; + my @params; + if (!defined $COMMAND or $COMMAND eq 'repair') { + $list .= '"*"' unless @ARGV; + @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)'); + } + $list .= $#ARGV == 0 ? Net::IMAP::Sync::quote($ARGV[0]) + : ('('.join(' ',map {Net::IMAP::Sync::quote($_)} @ARGV).')') if @ARGV; + @{$IMAP->{$name}}{qw/mailboxes delims/} = $client->list($list, @params); } -############################################################################# -# 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); +# Add a new mailbox to the database. +my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); + +# Get the index associated with a mailbox. +my $STH_GET_INDEX = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); + +# Ensure local and remote delimiter match +sub check_delim($) { + my $mbx = shift; + my ($lDelims, $rDelims) = map {$IMAP->{$_}->{delims}} qw/local remote/; + if (exists $lDelims->{$mbx} and exists $rDelims->{$mbx} and + ((defined $lDelims->{$mbx} xor defined $rDelims->{$mbx}) or + (defined $lDelims->{$mbx} and defined $rDelims->{$mbx} and $lDelims->{$mbx} ne $rDelims->{$mbx}))) { + my ($ld, $rd) = ($lDelims->{$mbx}, $rDelims->{$mbx}); + $ld =~ s/([\x22\x5C])/\\$1/g if defined $ld; + $rd =~ s/([\x22\x5C])/\\$1/g if defined $rd; + die "Error: Hierarchy delimiter for $mbx don't match: " + ."local \"". ($ld // '')."\", remote \"".($rd // '')."\"\n" } - return \%tree; + return exists $lDelims->{$mbx} ? $lDelims->{$mbx} : exists $rDelims->{$mbx} ? $rDelims->{$mbx} : undef; } -#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; + +# Return true if $mailbox exists on $name +sub mbx_exists($$) { + my ($name, $mailbox) = @_; 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; + +# Return true if $mailbox is subscribed to on $name +sub mbx_subscribed($$) { + my ($name, $mailbox) = @_; 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) or - msg('database', "WARNING: Can't rename $mbx to $mbx2[0]"); - $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; - } +############################################################################## +# Process --delete command +# +if (defined $COMMAND and $COMMAND eq 'delete') { + my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?}); + my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?}); + my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?}); + my $sth_delete_mapping = $DBH->prepare(q{DELETE FROM mapping WHERE idx = ?}); - 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) or - msg('database', "WARNING: Can't rename $mbx2 to $mbx2"); - $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); - } + foreach my $mailbox (@ARGV) { + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # delete $mailbox on servers where $mailbox exists. note that + # there is a race condition where the mailbox could have + # appeared meanwhile + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->delete($mailbox) if mbx_exists($name, $mailbox); } - $rv = 1; - } - while (my ($root, $children) = each %children) { - my $r = sync_tree($sth, $mbx.$root, %$children); - $rv ||= $r; + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $r1 = $sth_delete_mapping->execute($idx); + msg('database', "WARNING: `DELETE FROM mapping WHERE idx = $idx` failed") unless $r1; + my $r2 = $sth_delete_local->execute($idx); + msg('database', "WARNING: `DELETE FROM local WHERE idx = $idx` failed") unless $r2; + my $r3 = $sth_delete_remote->execute($idx); + msg('database', "WARNING: `DELETE FROM remote WHERE idx = $idx` failed") unless $r3; + my $r4 = $sth_delete_mailboxes->execute($idx); + msg('database', "WARNING: `DELETE FROM mailboxes WHERE idx = $idx` failed") unless $r4; + + $DBH->commit(); + msg('database', "Removed mailbox $mailbox") if $r4; + } } - return $rv; + exit 0; } -{ - my %delims; + +############################################################################## +# Process --rename command +# +elsif (defined $COMMAND and $COMMAND eq 'rename') { + my ($from, $to) = @ARGV; + + # get index of the original name + $STH_GET_INDEX->execute($from); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + # ensure the local and remote hierarchy delimiter match + my $delim = check_delim($from); + + # ensure the target name doesn't already exist on the servers. there + # is a race condition where the mailbox would be created before we + # issue the RENAME command, then the server would reply with a + # tagged NO response 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}); - } + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + if (mbx_exists($name, $to)) { + msg($name, "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; } } - 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(q{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; + # ensure the target name doesn't already exist in the database + $STH_GET_INDEX->execute($to); + if (defined $STH_GET_INDEX->fetch() and + (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + msg('database', "ERROR: Mailbox $to exists. Run `$NAME --delete $to` to delete."); + exit 1; } - 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 "Couldn't sync mailbox list.\n" if exists_mbx('local',$mbx) xor exists_mbx('remote',$mbx); + + # rename $from to $to on servers where $from exists. again there is + # a race condition, but if $to has been created meanwhile the server + # will reply with a tagged NO response + foreach my $name (qw/local remote/) { + next if defined $CONFIG{target} and !grep {$_ eq $name} @{$CONFIG{target}}; + $IMAP->{$name}->{client}->rename($from, $to) if mbx_exists($name, $from); + } + + # rename from to $to in the database + if (defined $idx and (!defined $CONFIG{target} or grep {$_ eq 'database'} @{$CONFIG{target}})) { + my $sth_rename_mailbox = $DBH->prepare(q{UPDATE mailboxes SET mailbox = ? WHERE idx = ?}); + my $r = $sth_rename_mailbox->execute($to, $idx); + msg('database', "WARNING: `UPDATE mailboxes SET mailbox = ".$DBH->quote($to)." WHERE idx = $idx` failed") unless $r; + + # for non-flat mailboxes, rename the children as well + if (defined $delim) { + my $prefix = $from.$delim; + my $sth_rename_children = $DBH->prepare(q{ + UPDATE mailboxes SET mailbox = ? || SUBSTR(mailbox,?) + WHERE SUBSTR(mailbox,1,?) = ? + }); + $sth_rename_children->execute($to, length($prefix), length($prefix), $prefix); } + + $DBH->commit(); + msg('database', "Renamed mailbox $from to $to") if $r; } + exit 0; } -# Synchronize subscription list -my @SUBSCRIPTIONS; + +############################################################################## +# Synchronize mailbox and subscription lists + +my @MAILBOXES; { - my $sth_search = $DBH->prepare(q{SELECT idx,subscribed FROM mailboxes WHERE mailbox = ?}); + my %mailboxes; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{local}->{mailboxes}}; + $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); - my %mailboxes; - $mailboxes{$_} = 1 foreach (keys %{$IMAP->{local}->{mailboxes}}, keys %{$IMAP->{remote}->{mailboxes}}); - - foreach my $mbx (keys %mailboxes) { - $sth_search->execute($mbx); - my $row = $sth_search->fetch(); - die if defined $sth_search->fetch(); # sanity check - - my ($lSubscribed,$rSubscribed) = map {subscribed_mbx($_,$mbx)} qw/local remote/; - if ($lSubscribed == $rSubscribed) { - if (defined $row) { - my ($idx,$status) = @$row; - if (defined $status and $status != $lSubscribed) { - $sth_subscribe->execute($lSubscribed, $idx) or - msg('database', "WARNING: Can't (un)subscribe $mbx"); - $DBH->commit(); - } - } - } - else { - my ($subscribed,$unsubscribed) = $lSubscribed ? qw/local remote/ : qw/remote local/; - 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) or - msg('database', "WARNING: Can't unsubscribe $mbx"); - $IMAP->{$subscribed}->{client}->unsubscribe($mbx); + @MAILBOXES = keys %mailboxes; + + foreach my $mailbox (@MAILBOXES) { + check_delim($mailbox); # ensure that the delimiter match + my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + + $STH_GET_INDEX->execute($mailbox); + my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + if ($lExists and $rExists) { + # $mailbox exists on both sides + my ($lSubscribed,$rSubscribed) = map {mbx_subscribed($_, $mailbox)} qw/local remote/; + if (defined $idx) { + if ($lSubscribed xor $rSubscribed) { + # mailbox is subscribed on only one server + if ($subscribed) { # unsubscribe + my $name = $lSubscribed ? 'local' : 'remote'; + $IMAP->{$name}->{client}->unsubscribe($mailbox); + } + else { # subscribe + my $name = $lSubscribed ? 'remote' : 'local'; + $IMAP->{$name}->{client}->subscribe($mailbox); + } + # toggle subscribtion in the database + $subscribed = $subscribed ? 0 : 1; + $sth_subscribe->execute($subscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $subscribed WHERE idx = $idx` failed"); $DBH->commit(); - $lSubscribed = $rSubscribed = 0; } - else { - # $mbx was UNSUBSCRIBEd before, SUBSCRIBE it now - msg($unsubscribed, "Subscribe to mailbox $mbx"); - $sth_subscribe->execute(1,$idx) or - msg('database', "WARNING: Can't subscribe $mbx"); - $IMAP->{$unsubscribed}->{client}->subscribe($mbx); + # $mailbox is either subscribed on both servers, or subscribed on both + elsif ($lSubscribed xor $subscribed) { + # update the database if needed + $sth_subscribe->execute($lSubscribed, $idx) or + msg('database', "WARNING: `UPDATE mailboxes SET subscribed = $lSubscribed WHERE idx = $idx` failed"); $DBH->commit(); - $lSubscribed = $rSubscribed = 1; } } else { - # $mbx is unknown; assume the user wants to SUBSCRIBE - msg($unsubscribed, "Subscribe to mailbox $mbx"); - $IMAP->{$unsubscribed}->{client}->subscribe($mbx); - $lSubscribed = $rSubscribed = 1; + # add new mailbox; subscribe on both servers if $mailbox is subscribed on one of them + my $subscribed = ($lSubscribed or $rSubscribed) ? 1 : 0; + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed and !$lSubscribed; + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed and !$rSubscribed; + $DBH->commit(); } } - push @SUBSCRIPTIONS, $mbx if $lSubscribed; - } -} - -# Clean database: remove mailboxes that no longer exist -{ - my $sth = $DBH->prepare(q{SELECT idx,mailbox,subscribed FROM mailboxes}); - my $sth_delete_mailboxes = $DBH->prepare(q{DELETE FROM mailboxes WHERE idx = ?}); - my $sth_delete_local = $DBH->prepare(q{DELETE FROM local WHERE idx = ?}); - my $sth_delete_remote = $DBH->prepare(q{DELETE FROM remote WHERE idx = ?}); - my $sth_delete_mapping = $DBH->prepare(q{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}; + elsif ($lExists and !$rExists) { + # $mailbox is on 'local' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('local', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{remote}->{client}->create($mailbox); + $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; + $DBH->commit(); + } + elsif (!$lExists and $rExists) { + # $mailbox is on 'remote' only + if (defined $idx) { + msg('database', "ERROR: Mailbox $mailbox exists. Run `$NAME --delete $mailbox` to delete."); + exit 1; + } + my $subscribed = mbx_subscribed('remote', $mailbox); + $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); + $IMAP->{local}->{client}->create($mailbox); + $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; $DBH->commit(); } } } - +my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/; +undef $IMAP; ############################################################################# # 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, + SELECT mailbox, m.idx as idx, 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 @@ -551,9 +498,6 @@ my $STH_GET_CACHE_BY_IDX = $DBH->prepare(q{ WHERE m.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(q{SELECT lUID FROM mapping WHERE idx = ? and rUID = ?}); my $STH_GET_REMOTE_UID = $DBH->prepare(q{SELECT rUID FROM mapping WHERE idx = ? and lUID = ?}); @@ -571,7 +515,6 @@ my $STH_UPDATE_LOCAL = $DBH->prepare(q{UPDATE local SET UIDNEXT = ?, HIGHESTMO my $STH_UPDATE_REMOTE = $DBH->prepare(q{UPDATE remote SET UIDNEXT = ?, HIGHESTMODSEQ = ? WHERE idx = ?}); # Add a new mailbox. -my $STH_INSERT_MAILBOX= $DBH->prepare(q{INSERT INTO mailboxes (mailbox,subscribed) VALUES (?,?)}); my $STH_INSERT_LOCAL = $DBH->prepare(q{INSERT INTO local (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)}); my $STH_INSERT_REMOTE = $DBH->prepare(q{INSERT INTO remote (idx,UIDVALIDITY,UIDNEXT,HIGHESTMODSEQ) VALUES (?,?,0,0)}); @@ -650,9 +593,20 @@ sub delete_mapping($$) { # Check and repair synchronization of a mailbox between the two servers # (in a very crude way, by downloading all existing UID with their flags) -my @REPAIR; -sub repair($$) { - my ($idx, $mailbox) = @_; +sub repair($) { + my $mailbox = shift; + + $STH_GET_INDEX->execute($mailbox); + my ($idx) = $STH_GET_INDEX->fetchrow_array(); + die if defined $STH_GET_INDEX->fetch(); # sanity check + + return unless defined $idx; # not in the database + $lIMAP->select($mailbox); + $rIMAP->select($mailbox); + + $STH_GET_CACHE_BY_IDX->execute($idx); + my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // return; # no cache + die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check # get all existing UID with their flags my ($lVanished, $lModified) = $lIMAP->pull_updates(1); @@ -665,10 +619,6 @@ sub repair($$) { my (@rToRemove, %rToUpdate, @rMissing); my @delete_mapping; - $STH_GET_CACHE_BY_IDX->execute($idx); - my $cache = $STH_GET_CACHE_BY_IDX->fetchrow_hashref() // die "Missing cache for index $idx"; - die if defined $STH_GET_CACHE_BY_IDX->fetch(); # sanity check - # process each pair ($lUID,$rUID) found in the mapping table, and # compare with the result from the IMAP servers to detect anomalies @@ -1024,11 +974,14 @@ sub wait_notifications(;$) { } +############################################################################# # Resume interrupted mailbox syncs. +# my ($MAILBOX, $IDX); $STH_LIST_INTERRUPTED->execute(); while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { ($IDX, $MAILBOX) = @$row; + next unless grep { $_ eq $MAILBOX } @MAILBOXES; msg(undef, "Resuming interrupted sync for $MAILBOX"); my %lUIDs; @@ -1075,8 +1028,10 @@ while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { } - +############################################################################# # Initialize $lIMAP and $rIMAP states to detect mailbox dirtyness. +# +my %KNOWN_INDEXES; $STH_GET_CACHE->execute(); while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { $lIMAP->set_cache($row->{mailbox}, @@ -1089,22 +1044,13 @@ while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { UIDNEXT => $row->{rUIDNEXT}, HIGHESTMODSEQ => $row->{rHIGHESTMODSEQ} ); - push @REPAIR, $row->{mailbox} if $CONFIG{repair} and - (!@ARGV or grep { $_ eq $row->{mailbox} } @ARGV); + $KNOWN_INDEXES{$row->{idx}} = 1; } -while (@REPAIR) { - $MAILBOX = shift @REPAIR; - - $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); - repair($IDX, $MAILBOX); +if (defined $COMMAND and $COMMAND eq 'repair') { + repair($_) foreach @MAILBOXES; + exit 0; } -exit 0 if $CONFIG{repair}; while(1) { @@ -1116,28 +1062,23 @@ while(1) { sync_messages($IDX, $MAILBOX); } else { - $MAILBOX = $lIMAP->next_dirty_mailbox(@ARGV) // $rIMAP->next_dirty_mailbox(@ARGV) // last; + $MAILBOX = $lIMAP->next_dirty_mailbox(@MAILBOXES) // $rIMAP->next_dirty_mailbox(@MAILBOXES) // 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 + die unless defined $IDX; # sanity check; $lIMAP->select($MAILBOX); $rIMAP->select($MAILBOX); - # new mailbox - if (!defined $IDX) { - my $subscribed = (grep { $_ eq $MAILBOX} @SUBSCRIPTIONS) ? 1 : 0; - $STH_INSERT_MAILBOX->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 - + if (!$KNOWN_INDEXES{$IDX}) { $STH_INSERT_LOCAL->execute( $IDX, $lIMAP->uidvalidity($MAILBOX)); $STH_INSERT_REMOTE->execute($IDX, $rIMAP->uidvalidity($MAILBOX)); - # don't commit before the first mapping (lUID,rUID) + # no need to commit before the first mapping (lUID,rUID) + $KNOWN_INDEXES{$IDX} = 1; } elsif (sync_known_messages($IDX, $MAILBOX)) { # sync updates to known messages before fetching new messages @@ -1152,7 +1093,7 @@ while(1) { } } # clean state! - exit 0 unless $CONFIG{watch}; + exit 0 unless defined $COMMAND and $COMMAND eq 'watch'; wait_notifications(900); } diff --git a/imapsync.1 b/imapsync.1 index 0f286ce..e274943 100644 --- a/imapsync.1 +++ b/imapsync.1 @@ -4,7 +4,7 @@ imapsync \- IMAP-to-IMAP synchronization program for QRESYNC-capable servers .SH SYNOPSIS -.B imapsync\fR [\fIOPTION\fR ...] [\fIMAILBOX\fR ...] +.B imapsync\fR [\fIOPTION\fR ...] [\fICOMMAND\fR] [\fIMAILBOX\fR ...] .SH DESCRIPTION @@ -69,6 +69,7 @@ Go back to step 2 if the server sent some updates in the meantime. .IP \n+[step]. Go back to step 1 to proceed with the next unsynchronized mailbox. +.SH COMMANDS .PP By default \fBimapsync\fR synchronizes each mailbox listed by the \(lqLIST "" "*"\(rq IMAP command; @@ -86,16 +87,15 @@ their flags have changed in the meantime. Finally, after propagating the offline changes for these messages, \fBimapsync\fR resumes the synchronization for the rest of the mailbox. -.SH OPTIONS -.TP -.B \-\-config=\fR\fIFILE\fR -Specify an alternate configuration file. Relative paths start from -\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME -environment variable is unset. +.PP +Specifying one of the commands below makes \fBimapsync\fR perform an +action other than the default QRESYNC-based synchronization. .TP -.B \-\-repair +.B \-\-repair \fR[\fIMAILBOX\fR ...] List the database anomalies and try to repair them. +(Consider only the given \fIMAILBOX\fRes if non-optional arguments are +provided.) This is done by performing a so\-called \(lqfull synchronization\(rq, namely 1/ download all UIDs along with their flags from both the local and remote servers, 2/ ensure that each entry in the database corresponds @@ -106,6 +106,37 @@ duplicate). Flag conflicts are solved by updating each message to the union of both lists. +.TP +.B \-\-delete \fIMAILBOX\fR [...] +Delete the given \fIMAILBOX\fRes on each target (by default each server +plus the database, unless \fB\-\-target\fR specifies otherwise) where +it exists. +Note that per [RFC3501] deletion is not recursive: \fIMAILBOX\fR's +children are not deleted. + +.TP +.B \-\-rename \fISOURCE\fR \fIDEST\fR +Rename the mailbox \fISOURCE\fR to \fIDEST\fR on each target (by default +each server plus the database, unless \fB\-\-target\fR specifies +otherwise) where it exists. +\fBimapsync\fR aborts if \fIDEST\fR already exists on either target. +Note that per [RFC3501] the renaming is recursive: \fISOURCE\fR's +children are moved to become \fIDEST\fR's children instead. + + +.SH OPTIONS +.TP +.B \-\-config=\fR\fIFILE\fR +Specify an alternate configuration file. Relative paths start from +\fI$XDG_CONFIG_HOME\fR, or \fI~/.config\fR if the XDG_CONFIG_HOME +environment variable is unset. + +.TP +.B \fB\-\-target=\fR{local,remote,database} +Limit the scope of a \fB\-\-delete\fR or \fB\-\-rename\fR command +to the given target. Can be repeated to act on multiple targets. By +default all three targets are considered. + .TP .B \-q\fR, \fB\-\-quiet\fR Try to be quiet. @@ -231,21 +262,11 @@ Authorities, used for server certificate verification. .SH KNOWN BUGS AND LIMITATIONS -.IP \[bu] 2 -Mailbox deletion and renaming are not very well tested yet. .IP \[bu] Using \fBimapsync\fR on two identical servers with a non-existent or empty database will duplicate each message due to absence of local/remote UID association. .IP \[bu] -Detecting whether a mailbox has been renamed or deleted while -\fBimapsync\fR wasn't running is done by looking for a mailbox with same -UIDVALIDITY. [RFC3501] describes the purpose of UIDVALIDITY as to let -clients know when to invalidate their UID cache. In particular, there -is no requirement that two mailboxes can't share same UIDVALIDITY. -However such a possibility would defeat \fBimapsync\fR's heuristic to -detect whether a mailbox has been renamed or deleted offline. -.IP \[bu] \fBimapsync\fR is single threaded and doesn't use IMAP command pipelining. Performance improvement could be achieved by sending independent commands to each server in parallel, and for a given server, diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 3216483..c1bccbf 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -520,11 +520,13 @@ sub create($$) { my ($self, $mailbox) = @_; $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("CREATE ".quote($mailbox)); + $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; } sub delete($$) { my ($self, $mailbox) = @_; $self->fail("Server is read-only.") if $self->{'read-only'}; - #$self->_send("DELETE ".quote($mailbox)); + $self->_send("DELETE ".quote($mailbox)); + $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; delete $self->{_CACHE}->{$mailbox}; delete $self->{_PCACHE}->{$mailbox}; } @@ -533,12 +535,24 @@ sub delete($$) { # $self->rename($oldname, $newname) # RENAME the mailbox $oldname to $newname. Requires the 'read-only' # flag to be unset. +# /!\ Requires a LIST command to be issued to determine the hierarchy +# delimiter for the original name. sub rename($$$) { my ($self, $from, $to) = @_; + my $delim = $self->{_CACHE}->{$from}->{DELIMITER} if defined $self->{_CACHE}->{$from}; $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("RENAME ".quote($from).' '.quote($to)); + $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; $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) { + # 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}; + } + } } @@ -550,11 +564,13 @@ sub subscribe($$) { my ($self, $mailbox) = @_; $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("SUBSCRIBE ".quote($mailbox)); + $self->log("Subscribed to mailbox ".$mailbox) unless $self->{quiet}; } sub unsubscribe($$) { my ($self, $mailbox) = @_; $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("UNSUBSCRIBE ".quote($mailbox)); + $self->log("Unsubscribed to mailbox ".$mailbox) unless $self->{quiet}; } @@ -1456,6 +1472,7 @@ sub _resp($$;$$$) { $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive undef $delim if uc $delim eq 'NIL'; $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim; + $self->_update_cache_for($mailbox, DELIMITER => $delim); $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST'; } elsif (s/\ASTATUS //) { -- cgit v1.2.3 From 2a3287ab0b04341adcb8187b75cf35ac3f07d24f Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 27 Jul 2015 22:49:07 +0200 Subject: bugfix: Don't exist with the children's exist status upon error. --- lib/Net/IMAP/Sync.pm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index c1bccbf..677f991 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -386,9 +386,8 @@ sub new($%) { # Log out when the Net::IMAP::Sync object is destroyed. sub DESTROY($) { my $self = shift; - if (defined $self->{STDIN} and $self->{STDIN}->opened() and - defined $self->{STDOUT} and $self->{STDOUT}->opened()) { - $self->logout(); + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); } } -- cgit v1.2.3 From 67b2781d691d107f92409ac6fd9aeef97593ffa1 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 27 Jul 2015 22:52:21 +0200 Subject: Drop the 'read-only' option. It didn't really work since STORE commands are answered with a tagged OK response for instance. --- lib/Net/IMAP/Sync.pm | 35 ++++++++--------------------------- 1 file changed, 8 insertions(+), 27 deletions(-) diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 677f991..3faab63 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -47,7 +47,6 @@ my %OPTIONS = ( 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(YES|NO)\z/i, SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, SSL_cipher_list => qr/\A(\P{Control}+)\z/, SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, @@ -210,10 +209,6 @@ our $IMAP_text; # # - '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[]). @@ -225,9 +220,6 @@ sub new($%) { my $self = { @_ }; bless $self, $class; - # whether we're allowed to to use read-write command - $self->{'read-only'} = uc ($self->{'read-only'} // 'NO') ne 'YES' ? 0 : 1; - # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' # (cf RFC 3501 section 3) $self->{_STATE} = ''; @@ -479,14 +471,12 @@ sub search($$) { # $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. +# Issue a SELECT or EXAMINE command for the $mailbox. 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); + $self->_select_or_examine('SELECT', $mailbox); } sub examine($$) { my $self = shift; @@ -514,16 +504,14 @@ sub noop($) { # $self->create($mailbox) # $self->delete($mailbox) -# CREATE or DELETE $mailbox. Requires the 'read-only' flag to be unset. +# CREATE or DELETE $mailbox. sub create($$) { my ($self, $mailbox) = @_; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("CREATE ".quote($mailbox)); $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; } sub delete($$) { my ($self, $mailbox) = @_; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("DELETE ".quote($mailbox)); $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; delete $self->{_CACHE}->{$mailbox}; @@ -532,14 +520,12 @@ sub delete($$) { # $self->rename($oldname, $newname) -# RENAME the mailbox $oldname to $newname. Requires the 'read-only' -# flag to be unset. +# RENAME the mailbox $oldname to $newname. # /!\ Requires a LIST command to be issued to determine the hierarchy # delimiter for the original name. sub rename($$$) { my ($self, $from, $to) = @_; my $delim = $self->{_CACHE}->{$from}->{DELIMITER} if defined $self->{_CACHE}->{$from}; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("RENAME ".quote($from).' '.quote($to)); $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from}; @@ -557,17 +543,14 @@ sub rename($$$) { # $self->subscribe($mailbox) # $self->unsubscribe($mailbox) -# SUBSCRIBE or UNSUBSCRIBE $mailbox. Requires the 'read-only' flag to -# be unset. +# SUBSCRIBE or UNSUBSCRIBE $mailbox. sub subscribe($$) { my ($self, $mailbox) = @_; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("SUBSCRIBE ".quote($mailbox)); $self->log("Subscribed to mailbox ".$mailbox) unless $self->{quiet}; } sub unsubscribe($$) { my ($self, $mailbox) = @_; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->_send("UNSUBSCRIBE ".quote($mailbox)); $self->log("Unsubscribed to mailbox ".$mailbox) unless $self->{quiet}; } @@ -639,7 +622,6 @@ sub append($$@) { my $self = shift; my $mailbox = shift; return unless @_; - $self->fail("Server is read-only.") if $self->{'read-only'}; $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") if $self->incapable('UIDPLUS'); @@ -1234,9 +1216,8 @@ sub _open_mailbox($$) { # $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. +# Issue a SELECT or EXAMINE command for the $mailbox. Upon success, +# change the state to SELECTED, otherwise go back to AUTH. sub _select_or_examine($$$) { my $self = shift; my $command = shift; -- cgit v1.2.3 From 36b7d017145bac2f883cca12289e66b6b369a5e3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 27 Jul 2015 23:45:09 +0200 Subject: Enable fine-grained control on the mailboxes to consider. Add 3 options: - list-mailbox - list-select-opts - ignore-mailbox The first two control the initial LIST command, while the last one is a regular expression to filter out mailboxes to exclude from the LIST response. --- imapsync | 11 +++++++++-- imapsync.1 | 46 ++++++++++++++++++++++++++++++++++++++++++++-- lib/Net/IMAP/Sync.pm | 7 ++++--- 3 files changed, 57 insertions(+), 7 deletions(-) diff --git a/imapsync b/imapsync index 2a1bfcc..cc34287 100755 --- a/imapsync +++ b/imapsync @@ -66,7 +66,11 @@ usage(1) if defined $COMMAND and (($COMMAND eq 'delete' and !@ARGV) or $COMMAND my $CONF = read_config( delete $CONFIG{config} // $NAME , [qw/_ local remote/] , database => qr/\A(\P{Control}+)\z/ - , logfile => qr/\A(\P{Control}+)\z/ ); + , logfile => qr/\A(\/\P{Control}+)\z/ + , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/ + , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/ + ); my ($DBFILE, $LOCKFILE, $LOGGER_FD); { @@ -238,7 +242,8 @@ foreach my $name (qw/local remote/) { my $list = '"" '; my @params; if (!defined $COMMAND or $COMMAND eq 'repair') { - $list .= '"*"' unless @ARGV; + $list = '('.uc($CONF->{_}->{'list-select-opts'}).') '.$list if defined $CONF->{_}->{'list-select-opts'}; + $list .= (defined $CONF->{_}->{'list-mailbox'} ? '('.$CONF->{_}->{'list-mailbox'}.')' : '*') unless @ARGV; @params = ('SUBSCRIBED', 'STATUS (UIDVALIDITY UIDNEXT HIGHESTMODSEQ)'); } $list .= $#ARGV == 0 ? Net::IMAP::Sync::quote($ARGV[0]) @@ -404,6 +409,8 @@ my @MAILBOXES; my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); @MAILBOXES = keys %mailboxes; + @MAILBOXES = grep !/$CONF->{_}->{'ignore-mailbox'}/, @MAILBOXES + if defined $CONF->{_}->{'ignore-mailbox'}; foreach my $mailbox (@MAILBOXES) { check_delim($mailbox); # ensure that the delimiter match diff --git a/imapsync.1 b/imapsync.1 index e274943..59093ef 100644 --- a/imapsync.1 +++ b/imapsync.1 @@ -73,8 +73,14 @@ Go back to step 1 to proceed with the next unsynchronized mailbox. .PP By default \fBimapsync\fR synchronizes each mailbox listed by the \(lqLIST "" "*"\(rq IMAP command; -providing extra arguments limits the synchronization to the given -\fIMAILBOX\fRes only. +the \fIlist-mailbox\fR, \fIlist-select-opts\fR and \fIignore-mailbox\fR +options from the configuration file can be used to shrink that list and +save bandwidth. +However if some extra argument are provided on the command line, +\fBimapsync\fR ignores said options and synchronizes the given +\fIMAILBOX\fRes instead. Note that each \fIMAILBOX\fR is taken \(lqas +is\(rq; in particular, it must be UTF-7 encoded, unquoted, and the list +wildcards \(oq*\(cq and \(oq%\(cq are not interpolated. .PP If the synchronization was interrupted during a previous run while some @@ -181,6 +187,42 @@ This option is only available in the default section. (Default: \(lq\fIhost\fR.db\)\(rq, where \fIhost\fR is taken from the \(lq[remote]\(rq or \(lq[local]\(rq sections, in that order. +.TP +.I list-mailbox +A space separated list of mailbox patterns to use when issuing the +initial LIST command (overridden by the \fIMAILBOX\fRes given as +command-line arguments). +Note that each pattern containing special characters such as spaces or +brackets (see [RFC3501] for the exact syntax) must be quoted. +Furthermore, non-ASCII names must be UTF\-7 encoded. +Two wildcards are available: a \(oq*\(cq character matches zero or more +characters, while a \(oq%\(cq character matches zero or more characters +up to the mailbox's hierarchy delimiter. +This option is only available in the default section. +(The default pattern, \(lq*\(rq, matches all visible mailboxes on the +server.) + +.TP +.I list-select-opts +An optional space separated list of selectors for the initial LIST +command. (Requires a server supporting the LIST-EXTENDED [RFC5258] +extension.) Useful values are +\(lqSUBSCRIBED\(rq (to list only subscribed mailboxes), +\(lqREMOTE\(rq (to also list remote mailboxes on a server supporting +mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes +with children matching one of the \fIlist-mailbox\fR pattern above). +This option is only available in the default section. + +.TP +.I ignore-mailbox +An optional Perl Compatible Regular Expressions (PCRE) covering +mailboxes to exclude: +any (UTF-7 encoded, unquoted) mailbox listed in the initial LIST +responses is ignored if it matches the given expression. +Note that the \fIMAILBOX\fRes given as command-line arguments bypass the +check and are always considered for synchronization. +This option is only available in the default section. + .TP .I logfile A file name to use to log debug and informational messages. This option is diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 3faab63..48f61c1 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -78,10 +78,11 @@ sub read_config($$%) { foreach my $section (@$sections) { my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section $configs{$section} = $conf; - next unless defined $section and $section ne '_'; - die "No such section $section\n" unless defined $h->{$section}; - $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}}; + 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'; -- cgit v1.2.3 From 42435907201ccfa1b1f465d0ef447454f1d8c08e Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 28 Jul 2015 00:12:14 +0200 Subject: Update default config file. --- imapsync.sample | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/imapsync.sample b/imapsync.sample index e563e94..296f766 100644 --- a/imapsync.sample +++ b/imapsync.sample @@ -1,20 +1,23 @@ -; database = imap.guilhem.org.db +# database = imap.guilhem.org.db +#list-mailbox = "*" +list-select-opts = SUBSCRIBED +ignore-mailbox = ^virtual/ [local] type = tunnel command = /usr/lib/dovecot/imap [remote] -; type = imaps +# type = imaps host = imap.guilhem.org -; port = 993 +# port = 993 username = guilhem password = xxxxxxxxxxxxxxxx -; SSL options -;SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1 -;SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605 -;SSL_verify_trusted_peer = YES +# SSL options +#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1 +#SSL_fingerprint = sha256$62E436BB329C46A628314C49BDA7C2A2E86C57B2021B9A964B8FABB6540D3605 +#SSL_verify_trusted_peer = YES SSL_ca_path = /etc/ssl/certs -; vim:ft=dosini +# vim:ft=dosini -- cgit v1.2.3 From fed8c5f21771b27c4b268e1820ed05a51012fc76 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 28 Jul 2015 00:12:44 +0200 Subject: Update systemd service file. --- imapsync.service | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/imapsync.service b/imapsync.service index af63425..725f23b 100644 --- a/imapsync.service +++ b/imapsync.service @@ -1,9 +1,12 @@ [Unit] Description=IMAP-to-IMAP Syncronization service -After=network.target +Wants=network-online.target +After=network-online.target [Service] ExecStart=/usr/bin/imapsync +RestartSec=60s +Restart=on-success [Install] WantedBy=default.target -- cgit v1.2.3 From ebeb0ba4c5cf3a6faccade5459db897ab7e50ecb Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 28 Jul 2015 00:47:32 +0200 Subject: typo --- imapsync.1 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/imapsync.1 b/imapsync.1 index 59093ef..b86c9e5 100644 --- a/imapsync.1 +++ b/imapsync.1 @@ -210,7 +210,7 @@ extension.) Useful values are \(lqSUBSCRIBED\(rq (to list only subscribed mailboxes), \(lqREMOTE\(rq (to also list remote mailboxes on a server supporting mailbox referrals), and \(lqRECURSIVEMATCH\(rq (to list parent mailboxes -with children matching one of the \fIlist-mailbox\fR pattern above). +with children matching one of the \fIlist-mailbox\fR patterns above). This option is only available in the default section. .TP -- cgit v1.2.3 From 5f2e99687c3d04f8a4e177995192c4a6f4a27478 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 28 Jul 2015 12:31:49 +0200 Subject: Don't set to a ignored mailbox. --- imapsync | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/imapsync b/imapsync index cc34287..ae05163 100755 --- a/imapsync +++ b/imapsync @@ -987,8 +987,8 @@ sub wait_notifications(;$) { my ($MAILBOX, $IDX); $STH_LIST_INTERRUPTED->execute(); while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { + next unless grep { $_ eq $row->[1] } @MAILBOXES; # skip ignored mailbox ($IDX, $MAILBOX) = @$row; - next unless grep { $_ eq $MAILBOX } @MAILBOXES; msg(undef, "Resuming interrupted sync for $MAILBOX"); my %lUIDs; -- cgit v1.2.3 From cdb79844048406e4084496dfca4346ea9f111ba3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:10:28 +0200 Subject: Don't push non-existing mailboxes to @MAILBOXES. --- imapsync | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/imapsync b/imapsync index ae05163..d46c262 100755 --- a/imapsync +++ b/imapsync @@ -408,13 +408,13 @@ my @MAILBOXES; $mailboxes{$_} = 1 foreach keys %{$IMAP->{remote}->{mailboxes}}; my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); - @MAILBOXES = keys %mailboxes; - @MAILBOXES = grep !/$CONF->{_}->{'ignore-mailbox'}/, @MAILBOXES - if defined $CONF->{_}->{'ignore-mailbox'}; + foreach my $mailbox (keys %mailboxes) { + next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox !~ /$CONF->{_}->{'ignore-mailbox'}/o; + my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + next unless $lExists or $rExists; - foreach my $mailbox (@MAILBOXES) { check_delim($mailbox); # ensure that the delimiter match - my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; + push $mailbox, @MAILBOXES; $STH_GET_INDEX->execute($mailbox); my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); -- cgit v1.2.3 From 4f8810e937e70dfb5bbd4d58e111e26178d767e6 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:01:35 +0200 Subject: wibble --- imapsync | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/imapsync b/imapsync index d46c262..8bff447 100755 --- a/imapsync +++ b/imapsync @@ -492,15 +492,15 @@ undef $IMAP; # Get all cached states from the database. my $STH_GET_CACHE = $DBH->prepare(q{ - SELECT mailbox, m.idx as idx, - l.UIDVALIDITY as lUIDVALIDITY, l.UIDNEXT as lUIDNEXT, l.HIGHESTMODSEQ as lHIGHESTMODSEQ, - r.UIDVALIDITY as rUIDVALIDITY, r.UIDNEXT as rUIDNEXT, r.HIGHESTMODSEQ as rHIGHESTMODSEQ + SELECT mailbox, m.idx AS idx, + 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 }); my $STH_GET_CACHE_BY_IDX = $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 + 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 WHERE m.idx = ? }); -- cgit v1.2.3 From 076792d13dbc93d374a0bbbb63901c5610278e7d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:07:07 +0200 Subject: Reformulation. --- imapsync.1 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/imapsync.1 b/imapsync.1 index b86c9e5..d794d1a 100644 --- a/imapsync.1 +++ b/imapsync.1 @@ -306,13 +306,14 @@ Authorities, used for server certificate verification. .IP \[bu] Using \fBimapsync\fR on two identical servers with a non-existent or -empty database will duplicate each message due to absence of +empty database will duplicate each message due to the absence of local/remote UID association. .IP \[bu] \fBimapsync\fR is single threaded and doesn't use IMAP command -pipelining. Performance improvement could be achieved by sending -independent commands to each server in parallel, and for a given server, -by sending independent commands (such as flag updates) in a pipeline. +pipelining. Synchronization could be boosted by sending independent +commands (such as the initial LIST/STATUS command) to each server in +parallel, and for a given server, by sending independent commands (such +as flag updates) in a pipeline. .IP \[bu] Because the IMAP protocol doesn't have a specific response code for when a message is moved to another mailbox (using the MOVE command from -- cgit v1.2.3 From 483073796c9e3b14deed5b24afdb029ca0e9a48c Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:39:33 +0200 Subject: typo --- imapsync | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/imapsync b/imapsync index 8bff447..498fb82 100755 --- a/imapsync +++ b/imapsync @@ -409,12 +409,12 @@ my @MAILBOXES; my $sth_subscribe = $DBH->prepare(q{UPDATE mailboxes SET subscribed = ? WHERE idx = ?}); foreach my $mailbox (keys %mailboxes) { - next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox !~ /$CONF->{_}->{'ignore-mailbox'}/o; + next if defined $CONF->{_}->{'ignore-mailbox'} and $mailbox =~ /$CONF->{_}->{'ignore-mailbox'}/o; my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; next unless $lExists or $rExists; check_delim($mailbox); # ensure that the delimiter match - push $mailbox, @MAILBOXES; + push @MAILBOXES, $mailbox; $STH_GET_INDEX->execute($mailbox); my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); -- cgit v1.2.3 From d1c7440ee9c925e036472044c74b3b8d9268cd99 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:39:58 +0200 Subject: Don't initialize cache for ignore mailboxes. --- imapsync | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/imapsync b/imapsync index 498fb82..ae6bc79 100755 --- a/imapsync +++ b/imapsync @@ -1041,6 +1041,7 @@ while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) { my %KNOWN_INDEXES; $STH_GET_CACHE->execute(); while (defined (my $row = $STH_GET_CACHE->fetchrow_hashref())) { + next unless grep {$row->{mailbox} eq $_} @MAILBOXES; $lIMAP->set_cache($row->{mailbox}, UIDVALIDITY => $row->{lUIDVALIDITY}, UIDNEXT => $row->{lUIDNEXT}, @@ -1061,7 +1062,7 @@ if (defined $COMMAND and $COMMAND eq 'repair') { while(1) { - while(1) { + while(@MAILBOXES) { my $cache; my $update = 0; if (defined $MAILBOX and ($lIMAP->is_dirty($MAILBOX) or $rIMAP->is_dirty($MAILBOX))) { -- cgit v1.2.3 From 0c1aa3921e1736ab29caa9b77e62446c40d9214a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 00:57:14 +0200 Subject: Ignore mailboxes with '\NoSelect' attribute. --- imapsync | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/imapsync b/imapsync index ae6bc79..9bcc7b5 100755 --- a/imapsync +++ b/imapsync @@ -280,15 +280,15 @@ sub check_delim($) { # Return true if $mailbox exists on $name sub mbx_exists($$) { my ($name, $mailbox) = @_; - my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $flags and !grep {lc $_ eq lc '\NonExistent'} @$flags) ? 1 : 0; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and !grep {lc $_ eq lc '\NonExistent'} @$attrs) ? 1 : 0; } # Return true if $mailbox is subscribed to on $name sub mbx_subscribed($$) { my ($name, $mailbox) = @_; - my $flags = $IMAP->{$name}->{mailboxes}->{$mailbox}; - return (defined $flags and grep {lc $_ eq lc '\Subscribed'} @$flags) ? 1 : 0; + my $attrs = $IMAP->{$name}->{mailboxes}->{$mailbox}; + return (defined $attrs and grep {lc $_ eq lc '\Subscribed'} @$attrs) ? 1 : 0; } @@ -413,8 +413,14 @@ my @MAILBOXES; my ($lExists, $rExists) = map {mbx_exists($_,$mailbox)} qw/local remote/; next unless $lExists or $rExists; + my @attrs = do { + my %attrs = map {$_ => 1} (@{$IMAP->{local}->{mailboxes}->{$mailbox} // []}, + @{$IMAP->{remote}->{mailboxes}->{$mailbox} // []}); + keys %attrs; + }; + check_delim($mailbox); # ensure that the delimiter match - push @MAILBOXES, $mailbox; + push @MAILBOXES, $mailbox unless grep {lc $_ eq lc '\NoSelect'} @attrs; $STH_GET_INDEX->execute($mailbox); my ($idx,$subscribed) = $STH_GET_INDEX->fetchrow_array(); -- cgit v1.2.3 From a76acfe7af03ea9087c3c063c315b52109c41f10 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 01:16:51 +0200 Subject: Add a $try parameter to create, delete, rename, etc. And no longer crash when trying to create a mailbox that already exists. This could happen for instance if list-select-opts contains 'SUBSCRIBE' and the mailbox is not subscribed on one side. --- imapsync | 4 +-- lib/Net/IMAP/Sync.pm | 90 +++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 66 insertions(+), 28 deletions(-) diff --git a/imapsync b/imapsync index 9bcc7b5..45b214f 100755 --- a/imapsync +++ b/imapsync @@ -471,7 +471,7 @@ my @MAILBOXES; } my $subscribed = mbx_subscribed('local', $mailbox); $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{remote}->{client}->create($mailbox); + $IMAP->{remote}->{client}->create($mailbox, 1); $IMAP->{remote}->{client}->subscribe($mailbox) if $subscribed; $DBH->commit(); } @@ -483,7 +483,7 @@ my @MAILBOXES; } my $subscribed = mbx_subscribed('remote', $mailbox); $STH_INSERT_MAILBOX->execute($mailbox, $subscribed); - $IMAP->{local}->{client}->create($mailbox); + $IMAP->{local}->{client}->create($mailbox, 1); $IMAP->{local}->{client}->subscribe($mailbox) if $subscribed; $DBH->commit(); } diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 48f61c1..509ad5b 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -503,32 +503,47 @@ sub noop($) { } -# $self->create($mailbox) -# $self->delete($mailbox) +# $self->create($mailbox, [$try]) +# $self->delete($mailbox, [$try]) # CREATE or DELETE $mailbox. -sub create($$) { - my ($self, $mailbox) = @_; - $self->_send("CREATE ".quote($mailbox)); - $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; +# 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) = @_; - $self->_send("DELETE ".quote($mailbox)); - $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; +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) +# $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 for the original name. -sub rename($$$) { - my ($self, $from, $to) = @_; +sub rename($$$;$) { + my ($self, $from, $to, $try) = @_; my $delim = $self->{_CACHE}->{$from}->{DELIMITER} if defined $self->{_CACHE}->{$from}; - $self->_send("RENAME ".quote($from).' '.quote($to)); - $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; + 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) { @@ -539,21 +554,44 @@ sub rename($$$) { $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) -# $self->unsubscribe($mailbox) +# $self->subscribe($mailbox, [$try]) +# $self->unsubscribe($mailbox, [$try]) # SUBSCRIBE or UNSUBSCRIBE $mailbox. -sub subscribe($$) { - my ($self, $mailbox) = @_; - $self->_send("SUBSCRIBE ".quote($mailbox)); - $self->log("Subscribed to mailbox ".$mailbox) unless $self->{quiet}; +# If $try is set, print a warning but don't crash if the command fails. +sub subscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; } -sub unsubscribe($$) { - my ($self, $mailbox) = @_; - $self->_send("UNSUBSCRIBE ".quote($mailbox)); - $self->log("Unsubscribed to mailbox ".$mailbox) unless $self->{quiet}; +sub unsubscribe($$;$) { + my ($self, $mailbox, $try) = @_; + my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); + if ($IMAP_cond eq 'OK') { + $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; + } + else { + my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; + $try ? $self->warn($msg) : $self->fail($msg); + } + return $r; } @@ -1149,7 +1187,7 @@ sub _send($$;&) { $IMAP_cond = $1; $IMAP_text = $1.' '.$x; $self->_resp_text($x); - $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK'; + $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; $r = $1; last; } -- cgit v1.2.3 From 7f7a29ef79915a86d3f5bd3533e3a49ac6f36cb6 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 01:26:16 +0200 Subject: Don't try to rename children of mailboxes with \NoInferiors or \HasNoChildren attribute. --- lib/Net/IMAP/Sync.pm | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 509ad5b..2a25720 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -539,14 +539,18 @@ sub delete($$;$) { # 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 for the original name. +# delimiter and the mailbox attributes for the original name. sub rename($$$;$) { my ($self, $from, $to, $try) = @_; - my $delim = $self->{_CACHE}->{$from}->{DELIMITER} if defined $self->{_CACHE}->{$from}; + 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) { + 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; @@ -1484,15 +1488,16 @@ sub _resp($$;$$$) { $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 ($delim, $attrs) = ($2, $1); + my @attrs = defined $attrs ? split(/ /, $attrs) : (); my $mailbox = $self->_astring(\$_); $self->panic($_) unless $_ eq ''; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive undef $delim if uc $delim eq 'NIL'; $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim; $self->_update_cache_for($mailbox, DELIMITER => $delim); - $callback->($mailbox, $delim, @flags) if defined $callback and $cmd eq 'LIST'; + $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(\$_); -- cgit v1.2.3 From 7a5ef2ffc002e7976fae34d08f296ace993211c8 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 30 Jul 2015 01:39:30 +0200 Subject: Log out before exiting. --- imapsync | 5 ++++- lib/Net/IMAP/Sync.pm | 23 +++++++++++++---------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/imapsync b/imapsync index 45b214f..b0226c3 100755 --- a/imapsync +++ b/imapsync @@ -1111,4 +1111,7 @@ while(1) { wait_notifications(900); } -END { cleanup(); } +END { + $_->logout() foreach grep defined, ($lIMAP, $rIMAP); + cleanup(); +} diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 2a25720..47c6258 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -380,7 +380,7 @@ sub new($%) { sub DESTROY($) { my $self = shift; foreach (qw/STDIN STDOUT/) { - $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); } } @@ -490,7 +490,8 @@ sub examine($$) { # Issue a LOGOUT command. Change the state to LOGOUT. sub logout($) { my $self = shift; - $self->_send('LOGOUT'); + # don't bother if the connection is already closed + $self->_send('LOGOUT') if $self->{STDIN}->opened(); $self->{_STATE} = 'LOGOUT'; undef $self; } @@ -1100,10 +1101,15 @@ sub _getline($;$) { my $self = shift; my $msg = shift // ''; - my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); - $x =~ s/\r\n\z// or $self->panic($x); - $self->logger("S: $msg", $x) if $self->{debug}; - return $x; + if ($self->{STDOUT}->opened()) { + my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!"); + $x =~ s/\r\n\z// or $self->panic($x); + $self->logger("S: $msg", $x) if $self->{debug}; + return $x; + } + else { + undef $self; + } } @@ -1452,10 +1458,7 @@ sub _resp($$;$$$) { if (s/\A\* //) { if (s/\ABYE //) { - foreach (qw/STDIN STDOUT/) { - $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); - } - exit 0; + undef $self; } elsif (s/\A(?:OK|NO|BAD) //) { $self->_resp_text($_); -- cgit v1.2.3