New option 'list-reference' to specify a reference name.

This is useful for synchronizing multiple remote servers against
different namespaces belonging to the same local IMAP server (using a
different InterIMAP instance for each local namespace ↔ remote
synchronization, for instance with the newy provided systemd template
unit file).

1 files changed, 28 insertions, 17 deletions

diff --git a/interimap b/interimap
index 2dd0eb5..7054f88 100755
--- a/interimap
+++ b/interimap
@@ -79,6 +79,7 @@ my $CONF = do {
                , [qw/_ local remote/]
                , database => qr/\A(\P{Control}+)\z/
                , logfile => qr/\A(\/\P{Control}+)\z/
+               , 'list-reference' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]*)\z/
                , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
                , 'list-select-opts' => qr/\A([\x20\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]*)\z/
                , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
@@ -139,6 +140,7 @@ my ($DBFILE, $LOGGER_FD, %LIST);
         $CONFIG{target} = {};
         $CONFIG{target}->{$_} = 1 foreach qw/local remote database/;
     }
+    $CONF->{$_}->{'list-reference'} //= "" foreach qw/local remote/;
 }
 my $DBH;
 
@@ -231,20 +233,21 @@ sub print_delimiter($) {
     return "\"".$d."\"";
 }
 
-# Return the delimiter of the default namespace, and cache the result.
-# Use the cached value if present, otherwise issue a new LIST command
-# with the empty mailbox.
-sub get_delimiter($$) {
-    my ($name, $imap) = @_;
+# Return the delimiter of the default namespace or reference, and cache the
+# result.  Use the cached value if present, otherwise issue a new LIST
+# command with the empty mailbox.
+sub get_delimiter($$$) {
+    my ($name, $imap, $ref) = @_;
 
     # Use the cached value if present
     return $imap->{delimiter} if exists $imap->{delimiter};
 
-    my (undef, $d) = $imap->{client}->list("\"\" \"\"");
+    my (undef, $d) = $imap->{client}->list($ref." \"\""); # $ref is already quoted
     my @d = values %$d if defined $d;
     # While multiple LIST responses may happen in theory, we've issued a
     # single LIST command, so it's fair to expect a single reponse with
-    # a hierarchy delimiter of the root node.
+    # a hierarchy delimiter of the root node or reference (we can't
+    # match the root against the reference as it might not be rooted).
     fail($name, "Missing or unexpected (unsolicited) LIST response.") unless $#d == 0;
 
     return $imap->{delimiter} = $d[0]; # cache value and return it
@@ -254,16 +257,17 @@ sub get_delimiter($$) {
 sub list_mailboxes($) {
     my $name = shift;
     my $imap = $IMAP->{$name};
+    my $ref = Net::IMAP::InterIMAP::quote($CONF->{$name}->{'list-reference'});
 
     my $list = "";
     $list .= "(" .$LIST{'select-opts'}. ") " if defined $LIST{'select-opts'};
-    $list .= "\"\" ";
+    $list .= $ref." ";
 
     my @mailboxes = @{$LIST{mailbox}};
     my $cached_delimiter = exists $imap->{delimiter} ? 1 : 0;
     if (grep { index($_,"\x00") >= 0 } @mailboxes) {
         # some mailbox names contain null characters: substitute them with the hierarchy delimiter
-        my $d = get_delimiter($name, $imap) //
+        my $d = get_delimiter($name, $imap, $ref) //
             fail($name, "Mailbox name contains null characters but the namespace is flat!");
         s/\x00/$d/g foreach @mailboxes;
     }
@@ -291,7 +295,7 @@ sub list_mailboxes($) {
         } else {
             # didn't get a non-INBOX LIST reply so we need to explicitely query
             # the hierarchy delimiter
-            get_delimiter($name, $imap);
+            get_delimiter($name, $imap, $ref);
         }
     }
     logger($name, "Using ", print_delimiter($imap->{delimiter}),
@@ -299,7 +303,7 @@ sub list_mailboxes($) {
 
     # Ensure all LISTed delimiters (incl. INBOX's children, although they're
     # in a different namespace -- we treat INBOX itself separately, but not
-    # its children) match the one at the top level.
+    # its children) match the one at the top level (root or reference).
     my $d = $imap->{delimiter};
     foreach my $m (keys %$delims) {
         fail($name, "Mailbox $m has hierarchy delimiter ", print_delimiter($delims->{$m}),
@@ -457,25 +461,30 @@ sub db_get_mailbox_idx($) {
     return wantarray ? ($idx, $subscribed) : $idx;
 }
 
-# Transform mailbox name from internal representation (with \0 as hierarchy delimiters)
-# to a name understandable by the local/remote IMAP server.
+# Transform mailbox name from internal representation (with \0 as hierarchy delimiters
+# and without reference prefix) to a name understandable by the local/remote IMAP server.
 sub mbx_name($$) {
     my ($name, $mailbox) = @_;
-    my $x = $name // "local";
+    my $x = $name // "local"; # don't add reference if $name is undefined
     if (defined (my $d = $IMAP->{$x}->{delimiter})) {
         $mailbox =~ s/\x00/$d/g;
     } elsif (!exists $IMAP->{$x}->{delimiter} or index($mailbox,"\x00") >= 0) {
         die; # safety check
     }
-    return $mailbox;
+    return defined $name ? ($CONF->{$name}->{"list-reference"} . $mailbox) : $mailbox;
 }
 
 # Transform mailbox name from local/remote IMAP server to the internal representation
-# (with \0 as hierarchy delimiters).
+# (with \0 as hierarchy delimiters and without reference prefix).  Return undef if
+# the name doesn't start with the right reference.
 sub mbx_unname($$) {
     my ($name, $mailbox) = @_;
     return unless defined $mailbox;
 
+    my $ref = $CONF->{$name}->{"list-reference"};
+    return unless rindex($mailbox, $ref, 0) == 0; # not for us
+    $mailbox = substr($mailbox, length $ref);
+
     if (defined (my $d = $IMAP->{$name}->{delimiter})) {
         $mailbox =~ s/\Q$d\E/\x00/g;
     } elsif (!exists $IMAP->{$name}->{delimiter}) {
@@ -631,7 +640,9 @@ sub sync_mailbox_list() {
 
     foreach my $name (qw/local remote/) {
         foreach my $mbx (keys %{$IMAP->{$name}->{mailboxes}}) {
-            $mbx = mbx_unname($name, $mbx);
+            # exclude names not starting with the given LIST reference; for instance
+            # if "list-mailbox" specifies a name starting with a "breakout" character
+            $mbx = mbx_unname($name, $mbx) // next;
 
             # exclude ignored mailboxes (taken from the default config as it doesn't
             # make sense to ignore mailboxes from one side but not the other