, [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/
$CONFIG{target} = {};
$CONFIG{target}->{$_} = 1 foreach qw/local remote database/;
}
+ $CONF->{$_}->{'list-reference'} //= "" foreach qw/local remote/;
}
my $DBH;
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
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;
}
} 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}),
# 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}),
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}) {
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
projects / interimap.git / commitdiff