aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net')
-rw-r--r--lib/Net/IMAP/Sync.pm123
1 files changed, 76 insertions, 47 deletions
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 0b95276..bb99dcb 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -23,7 +23,6 @@ use strict;
use Config::Tiny ();
use List::Util 'first';
use Socket 'SO_KEEPALIVE';
-use POSIX 'strftime';
use Exporter 'import';
BEGIN {
@@ -50,45 +49,55 @@ my %OPTIONS = (
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/,
+ SSL_verify_peer => qr/\A(TRUE|FALSE)\z/i,
);
#############################################################################
# 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.
+# read_config($conffile, $sections, %opts)
+# Read $conffile's default section, then each section in the array
+# reference $section (which takes precedence). %opts extends %OPTIONS
+# and maps each option to a regexp validating its values.
sub read_config($$%) {
my $conffile = shift;
- my $section = shift;
+ my $sections = shift;
my %opts = (%OPTIONS, @_);
+ $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile
+ unless $conffile =~ /\A\//; # relative path
+
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;
+
+ my %configs;
+ foreach my $section (@$sections) {
+ my $conf = { %{$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}};
+
+ # 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;
+ return \%configs;
}
@@ -215,6 +224,16 @@ sub new($%) {
my $self = { @_ };
bless $self, $class;
+ # 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} = '';
+
if ($self->{type} eq 'preauth') {
require 'IPC/Open2.pm';
my $command = $self->{command} // $self->fail("Missing preauth command");
@@ -232,9 +251,12 @@ sub new($%) {
$socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
}
else {
+ require 'IO/Socket/SSL.pm';
+ if (defined (my $vrfy = delete $self->{SSL_verify_peer})) {
+ $args{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE';
+ }
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");
@@ -275,16 +297,6 @@ sub new($%) {
# 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);
@@ -306,8 +318,12 @@ sub new($%) {
require 'IO/Socket/SSL.pm';
$self->_send('STARTTLS');
+ my %sslargs;
+ if (defined (my $vrfy = delete $self->{SSL_verify_peer})) {
+ $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE';
+ }
my $fpr = delete $self->{SSL_fingerprint};
- my %sslargs = %$self{ grep /^SSL_/, keys %$self };
+ $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
@@ -384,12 +400,10 @@ sub DESTROY($) {
sub log($@) {
my $self = shift;
return unless @_;
- my $prefix = strftime "%b %e %H:%M:%S", localtime;
- $prefix .= " $self->{name}" if defined $self->{name};
+ my $prefix = defined $self->{name} ? $self->{name} : '';
$prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
$prefix .= ': ';
- my $stderr = $self->{STDERR};
- print $stderr $prefix, @_, "\n";
+ $self->{STDERR}->say($prefix, @_);
}
@@ -665,6 +679,15 @@ sub append($$$@) {
}
+# $self->fetch($set, $flags, [$callback])
+# Issue an UID FETCH command with the given UID $set, $flags, and
+# optional $callback.
+sub fetch($$$$) {
+ my ($self, $set, $flags, $callback) = @_;
+ $self->_send("UID FETCH $set $flags", $callback);
+}
+
+
# $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
@@ -815,13 +838,16 @@ sub next_dirty_mailbox($@) {
}
-# $self->pull_updates()
+# $self->pull_updates([$full])
+# If $full is set, FETCH FLAGS and MODSEQ for each UID up to
+# UIDNEXT-1.
# Get pending updates (unprocessed VANISHED responses and FLAG
# updates), and empty these lists from the cache.
# Finally, update the HIGHESTMODSEQ from the persistent cache to the
# value found in the internal cache.
-sub pull_updates($) {
+sub pull_updates($;$) {
my $self = shift;
+ my $full = shift // 0;
my $mailbox = $self->{_SELECTED} // $self->panic();
my $pcache = $self->{_PCACHE}->{$mailbox};
@@ -831,6 +857,9 @@ sub pull_updates($) {
$self->{_VANISHED} = [];
}
else {
+ $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)")
+ if $full and $pcache->{UIDNEXT} > 1;
+
my @missing;
while (%{$self->{_MODIFIED}}) {
while (my ($uid,$v) = each %{$self->{_MODIFIED}}) {
@@ -838,9 +867,9 @@ sub pull_updates($) {
# 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];
+ next unless $uid < $pcache->{UIDNEXT} # out of bounds
+ and ($full or $v->[0] > $pcache->{HIGHESTMODSEQ}); # already seen
+ $modified{$uid} = $full ? $v : $v->[1];
} else {
push @missing, $uid;
}
@@ -979,7 +1008,7 @@ sub push_flag_updates($$@) {
}
unless ($self->{quiet}) {
- $self->log("Updated flags ($flags) for UID ".compact_set(@ok));
+ $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok;
$self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '.
"trying again later") if %failed;
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-03 16:08:37 +0000