aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-ximapsync94
-rw-r--r--imapsync.119
-rw-r--r--lib/Net/IMAP/Sync.pm132
3 files changed, 151 insertions, 94 deletions
diff --git a/imapsync b/imapsync
index 00beec7..fec37f0 100755
--- a/imapsync
+++ b/imapsync
@@ -25,9 +25,9 @@ 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 List::Util 'first';
+use POSIX 'strftime';
use lib 'lib';
use Net::IMAP::Sync qw/read_config compact_set $IMAP_text $IMAP_cond/;
@@ -39,17 +39,31 @@ delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
my %CONFIG;
sub usage(;$) {
my $rv = shift // 0;
- print STDERR "TODO $NAME usage\n";
+ print STDERR "$NAME [OPTIONS] [--] [MAILBOX [..]]\n";
+ if ($rv) {
+ print STDERR "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"
+ ." -1, --oneshot Exit as soon as all mailboxes are synchronized\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";
+ }
exit $rv;
}
-usage(1) unless GetOptions(\%CONFIG, qw/debug help|h config=s quiet|q oneshot|1 repair/);
+usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q oneshot|1 repair debug help|h/);
usage(0) if $CONFIG{help};
my $CONF = read_config( delete $CONFIG{config} // $NAME
, [qw/_ local remote/]
- , database => qr/\A(\P{Control}+)\z/ );
-my ($DBFILE, $LOCKFILE);
+ , database => qr/\A(\P{Control}+)\z/
+ , logfile => qr/\A(\P{Control}+)\z/ );
+my ($DBFILE, $LOCKFILE, $LOGGER_FD);
{
$DBFILE = $CONF->{_}->{database} if defined $CONF->{_};
@@ -63,29 +77,36 @@ my ($DBFILE, $LOCKFILE);
$dir = $1;
$DBFILE = $dir .'/'. $DBFILE;
unless (-d $dir) {
- mkdir $dir, 0700 or die "Cannot mkdir $dir: $!\n";
+ mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n";
}
}
$LOCKFILE = $DBFILE =~ s/([^\/]+)\z/.$1.lck/r;
+
+ if (defined $CONF->{_} and defined $CONF->{_}->{logfile}) {
+ open $LOGGER_FD, '>>', $CONF->{_}->{logfile}
+ or die "Can't open $CONF->{_}->{logfile}: $!\n";
+ $LOGGER_FD->autoflush(1);
+ }
}
my $DBH;
# Clean after us
sub cleanup() {
- print STDERR "Cleaning up...\n" if $CONFIG{debug};
+ logger("Cleaning up...") if $CONFIG{debug};
unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
+ close $LOGGER_FD if defined $LOGGER_FD;
$DBH->disconnect() if defined $DBH;
}
-$SIG{$_} = sub { cleanup(); print STDERR "$!\n"; exit 1; } foreach qw/INT TERM/;
-$SIG{$_} = sub { cleanup(); print STDERR "$!\n"; exit 0; } foreach qw/HUP/;
+$SIG{$_} = sub { cleanup(); msg($!); exit 1; } foreach qw/INT TERM/;
+$SIG{$_} = sub { cleanup(); msg($!); exit 0; } foreach qw/HUP/;
#############################################################################
# Lock the database
{
if (-f $LOCKFILE) {
- open my $lock, '<', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ open my $lock, '<', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
my $pid = <$lock>;
close $lock;
chomp $pid;
@@ -94,7 +115,7 @@ $SIG{$_} = sub { cleanup(); print STDERR "$!\n"; exit 0; } foreach qw/HUP/;
die $msg, "\n";
}
- open my $lock, '>', $LOCKFILE or die "Cannot open $LOCKFILE: $!\n";
+ open my $lock, '>', $LOCKFILE or die "Can't open $LOCKFILE: $!\n";
print $lock $$, "\n";
close $lock;
}
@@ -167,9 +188,18 @@ $DBH->do('PRAGMA foreign_keys = ON');
sub msg($@) {
my $name = shift;
return unless @_;
+ logger($name, @_) if defined $LOGGER_FD and $LOGGER_FD ne \*STDERR;
my $prefix = defined $name ? "$name: " : '';
print STDERR $prefix, @_, "\n";
}
+sub logger($@) {
+ my $name = shift;
+ return unless @_ and defined $LOGGER_FD;
+ my $prefix = strftime "%b %e %H:%M:%S ", localtime;
+ $prefix .= "$name: " if defined $name;
+ $LOGGER_FD->say($prefix, @_);
+}
+logger(undef, ">>> $NAME $VERSION");
#############################################################################
@@ -181,6 +211,7 @@ foreach my $name (qw/local remote/) {
$config{$_} = $CONFIG{$_} foreach keys %CONFIG;
$config{enable} = 'QRESYNC';
$config{name} = $name;
+ $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
$IMAP->{$name} = { client => Net::IMAP::Sync::->new(%config) };
my $client = $IMAP->{$name}->{client};
@@ -589,7 +620,7 @@ sub download_missing($$$@) {
my $uid = $mail->{UID};
my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
$from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
- print STDERR "$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})\n" unless $CONFIG{quiet};
+ msg("$source($mailbox): UID $uid from <$from> ($mail->{INTERNALDATE})") unless $CONFIG{quiet};
callback_new_message($idx, $mailbox, $source, $mail, \@uids, $buff, \$bufflen)
});
@@ -604,8 +635,8 @@ sub flag_conflict($$$$$) {
my %flags = map {$_ => 1} (split(/ /, $lFlags), split(/ /, $rFlags));
my $flags = join ' ', sort(keys %flags);
- warn "WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ".
- "and remote UID $rUID ($rFlags). Setting both to the union ($flags).\n";
+ msg("WARNING: Conflicting flag update in $mailbox for local UID $lUID ($lFlags) ".
+ "and remote UID $rUID ($rFlags). Setting both to the union ($flags).");
return $flags
}
@@ -616,7 +647,7 @@ sub delete_mapping($$) {
my ($idx, $lUID) = @_;
my $r = $STH_DELETE_MAPPING->execute($idx, $lUID);
die if $r > 1; # sanity check
- warn "WARNING: Can't delete (idx,lUID) = ($idx,$lUID) from the database\n" if $r == 0;
+ msg("WARNING: Can't delete (idx,lUID) = ($idx,$lUID) from the database") if $r == 0;
}
@@ -668,7 +699,7 @@ sub repair($$) {
}
else {
# conflict
- warn "WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.\n"
+ msg("WARNING: Missed flag update in $mailbox for (lUID,rUID) = ($lUID,$rUID). Repairing.")
if $lModified->{$lUID}->[0] <= $cache->{lHIGHESTMODSEQ} and
$rModified->{$rUID}->[0] <= $cache->{rHIGHESTMODSEQ};
# set both $lUID and $rUID to the union of $lFlags and $rFlags
@@ -681,7 +712,7 @@ sub repair($$) {
}
elsif (!defined $lModified->{$lUID} and !defined $rModified->{$rUID}) {
unless ($lVanished{$lUID} and $rVanished{$rUID}) {
- warn "WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing.\n";
+ msg("WARNING: Pair (lUID,rUID) = ($lUID,$rUID) vanished from $mailbox. Repairing.");
push @delete_mapping, $lUID;
}
}
@@ -690,7 +721,7 @@ sub repair($$) {
if ($lVanished{$lUID}) {
push @rToRemove, $rUID;
} else {
- warn "local($mailbox): WARNING: UID $lUID disappeared. Downloading remote UID $rUID again.\n";
+ msg("local($mailbox): WARNING: UID $lUID disappeared. Downloading remote UID $rUID again.");
push @rMissing, $rUID;
}
}
@@ -699,7 +730,7 @@ sub repair($$) {
if ($rVanished{$rUID}) {
push @lToRemove, $lUID;
} else {
- warn "remote($mailbox): WARNING: UID $rUID disappeared. Downloading local UID $lUID again.\n";
+ msg("remote($mailbox): WARNING: UID $rUID disappeared. Downloading local UID $lUID again.");
push @lMissing, $lUID;
}
}
@@ -728,15 +759,15 @@ sub repair($$) {
# Process UID found in IMAP but not in the mapping table.
- warn "remote($mailbox): WARNING: No match for vanished local UID $_. Ignoring.\n" foreach keys %lVanished;
- warn "local($mailbox): WARNING: No match for vanished remote UID $_. Ignoring.\n" foreach keys %rVanished;
+ msg("remote($mailbox): WARNING: No match for vanished local UID $_. Ignoring.") foreach keys %lVanished;
+ msg("local($mailbox): WARNING: No match for vanished remote UID $_. Ignoring.") foreach keys %rVanished;
foreach my $lUID (keys %$lModified) {
- warn "remote($mailbox): WARNING: No match for modified local UID $lUID. Downloading again.\n";
+ msg("remote($mailbox): WARNING: No match for modified local UID $lUID. Downloading again.");
push @lMissing, $lUID;
}
foreach my $rUID (keys %$rModified) {
- warn "local($mailbox): WARNING: No match for modified remote UID $rUID. Downloading again.\n";
+ msg("local($mailbox): WARNING: No match for modified remote UID $rUID. Downloading again.");
push @rMissing, $rUID;
}
@@ -784,7 +815,7 @@ sub sync_known_messages($$) {
my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
if (!defined $rUID) {
- warn "remote($mailbox): WARNING: No match for vanished local UID $lUID. Ignoring.\n";
+ msg("remote($mailbox): WARNING: No match for vanished local UID $lUID. Ignoring.");
}
elsif (!exists $rVanished{$rUID}) {
push @rToRemove, $rUID;
@@ -795,7 +826,7 @@ sub sync_known_messages($$) {
my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
if (!defined $lUID) {
- warn "local($mailbox): WARNING: No match for vanished remote UID $rUID. Ignoring.\n";
+ msg("local($mailbox): WARNING: No match for vanished remote UID $rUID. Ignoring.");
}
elsif (!exists $lVanished{$lUID}) {
push @lToRemove, $lUID;
@@ -830,7 +861,7 @@ sub sync_known_messages($$) {
my ($rUID) = $STH_GET_REMOTE_UID->fetchrow_array();
die if defined $STH_GET_REMOTE_UID->fetchrow_arrayref(); # sanity check
if (!defined $rUID) {
- warn "remote($mailbox): WARNING: No match for modified local UID $lUID. Try '--repair'.\n";
+ msg("remote($mailbox): WARNING: No match for modified local UID $lUID. Try '--repair'.");
}
elsif (defined (my $rFlags = $rModified->{$rUID})) {
unless ($lFlags eq $rFlags) {
@@ -851,7 +882,7 @@ sub sync_known_messages($$) {
my ($lUID) = $STH_GET_LOCAL_UID->fetchrow_array();
die if defined $STH_GET_LOCAL_UID->fetchrow_arrayref(); # sanity check
if (!defined $lUID) {
- warn "local($mailbox): WARNING: No match for modified remote UID $rUID. Try '--repair'.\n";
+ msg("local($mailbox): WARNING: No match for modified remote UID $rUID. Try '--repair'.");
}
elsif (!exists $lModified->{$lUID}) {
# conflicts are taken care of above
@@ -884,7 +915,7 @@ sub callback_new_message($$$$;$$$) {
my $length = length $mail->{RFC822};
if ($length == 0) {
- warn "$name($mailbox): WARNING: Ignoring new 0-length message (UID $mail->{UID})\n";
+ msg("$name($mailbox): WARNING: Ignoring new 0-length message (UID $mail->{UID})");
return;
}
@@ -920,8 +951,7 @@ sub callback_new_message_flush($$$@) {
my ($lUIDs, $rUIDs) = $name eq 'local' ? (\@sUID,\@tUID) : (\@tUID,\@sUID);
for (my $k=0; $k<=$#messages; $k++) {
- print STDERR "Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox\n"
- if $CONFIG{debug};
+ logger("Adding mapping (lUID,rUID) = ($lUIDs->[$k],$rUIDs->[$k]) for $mailbox") if $CONFIG{debug};
$STH_INSERT_MAPPING->execute($idx, $lUIDs->[$k], $rUIDs->[$k]);
}
$DBH->commit(); # commit only once per batch
@@ -993,7 +1023,7 @@ my ($MAILBOX, $IDX);
$STH_LIST_INTERRUPTED->execute();
while (defined (my $row = $STH_LIST_INTERRUPTED->fetchrow_arrayref())) {
($IDX, $MAILBOX) = @$row;
- print STDERR "Resuming interrupted sync for $MAILBOX\n";
+ msg("Resuming interrupted sync for $MAILBOX");
my %lUIDs;
$STH_GET_INTERRUPTED_BY_IDX->execute($IDX);
diff --git a/imapsync.1 b/imapsync.1
index eda493a..f4f6965 100644
--- a/imapsync.1
+++ b/imapsync.1
@@ -71,7 +71,8 @@ Go back to step 2 if the server sent some updates in the meantime.
Go back to step 1 to proceed with the next unsynchronized mailbox.
.PP
-By default \fBimapsync\fR synchronizes each subscribed mailbox;
+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.
@@ -128,10 +129,9 @@ Try to be quiet.
.TP
.B \-\-debug
-Turn on debug mode.
-Note that all IMAP traffic (excluding literals) is then printed to the
-error output. Depending on the chosen authentication mechanism,
-this might include authentication credentials.
+Turn on debug mode. Debug messages are written to the given \fIlogfile\fR.
+Note that this include all IMAP traffic (except literals). Depending on the
+chosen authentication mechanism, this might include authentication credentials.
.TP
.B \-h\fR, \fB\-\-help\fR
@@ -168,6 +168,11 @@ This option is only available in the default section.
\(lq[remote]\(rq or \(lq[local]\(rq sections, in that order.
.TP
+.I logfile
+A file name to use to log debug and informational messages. This option is
+only available in the default section.
+
+.TP
.I type
One of \(lqimap\(rq, \(lqimaps\(rq or \(lqtunnel\(rq.
\fItype\fR=imap and \fItype\fR=imaps are respectively used for IMAP and
@@ -246,6 +251,10 @@ Authorities, used for server certificate verification.
.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
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 9db339b..26303a6 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -21,7 +21,9 @@ use warnings;
use strict;
use Config::Tiny ();
+use IO::Select ();
use List::Util 'first';
+use POSIX 'strftime';
use Socket 'SO_KEEPALIVE';
use Exporter 'import';
@@ -206,9 +208,6 @@ our $IMAP_text;
# advertise "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.
@@ -219,6 +218,8 @@ our $IMAP_text;
# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
# BODY.PEEK[]).
#
+# - 'logger-fd': An optional filehandle to use for debug output.
+#
sub new($%) {
my $class = shift;
my $self = { @_ };
@@ -227,9 +228,6 @@ sub new($%) {
# whether we're allowed to to use read-write command
$self->{'read-only'} = uc ($self->{'read-only'} // 'NO') ne 'YES' ? 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} = '';
@@ -335,11 +333,12 @@ sub new($%) {
@caps = $self->capabilities();
}
- $self->fail("Logins are disabled.") if grep {$_ eq 'LOGINDISABLED'} @caps;
- my @mechs = grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps;
+ my @mechs = ('LOGIN', 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;
+ $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and
+ grep {$_ eq 'LOGINDISABLED'} @caps;
my ($command, $callback);
my ($username, $password) = @$self{qw/username password/};
@@ -384,27 +383,35 @@ sub new($%) {
}
-# Close handles when the Net::IMAP::Sync object is destroyed.
+# 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();
}
- $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened()
- and $self->{STDERR} ne \*STDERR;
}
# $self->log($message, [...])
-# Log a $message.
+# $self->logger($message, [...])
+# Log a $message. The latter method is used to log in the 'logger-fd', and
+# add timestamps.
sub log($@) {
my $self = shift;
return unless @_;
+ $self->logger(@_) if defined $self->{'logger-fd'} and $self->{'logger-fd'} ne \*STDERR;
my $prefix = defined $self->{name} ? $self->{name} : '';
$prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
- $prefix .= ': ';
- $self->{STDERR}->say($prefix, @_);
+ print STDERR $prefix, ': ', @_, "\n";
+}
+sub logger($@) {
+ my $self = shift;
+ return unless @_ and defined $self->{'logger-fd'};
+ my $prefix = strftime "%b %e %H:%M:%S ", localtime;
+ $prefix .= defined "$self->{name}" ? $self->{name} : '';
+ $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
+ $self->{'logger-fd'}->say($prefix, ': ', @_);
}
@@ -708,24 +715,35 @@ sub notify($@) {
my $command = 'NOTIFY ';
$command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
$self->_send($command);
+ $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT});
}
# $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.
+# See if the server has sent some unprocessed data; try to as many
+# lines as possible, process them, 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 $stdout = $self->{STDOUT};
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++
+
+ while (1) {
+ # Unprocessed data within the current SSL frame would cause
+ # select(2) to block/timeout due to the raw socket not being
+ # ready.
+ unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) {
+ my $sel = IO::Select::->new($stdout);
+ my ($ok) = $self->{_SEL_OUT}->can_read(0);
+ return $read unless defined $ok;
+ }
+
+ $self->_resp( $self->_getline() );
+ $read++;
}
- $self->{STDOUT}->blocking(1) // $self->panic("Can't turn off non-blocking IO: $!");
- return $read;
}
@@ -757,8 +775,8 @@ sub set_cache($$%) {
$cache->{$k} = $v;
}
- $self->log("Update last clean state for $mailbox: ".
- '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')')
+ $self->logger("Update last clean state for $mailbox: ".
+ '('.join(' ', map {"$_ $cache->{$_}"} keys %$cache).')')
if $self->{debug};
}
@@ -832,8 +850,8 @@ sub next_dirty_mailbox($@) {
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!");
+ @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty))
+ : $self->logger("Clean state!");
}
return $dirty[0];
}
@@ -1038,13 +1056,14 @@ sub _fingerprint_match($$$) {
# $self->_getline([$msg])
# Read a line from the handle and strip the trailing CRLF.
+# /!\ Don't use this method with non-blocking IO!
sub _getline($;$) {
my $self = shift;
my $msg = shift // '';
- my $x = $self->{STDOUT}->getline() // return; # non-blocking IO
+ my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
$x =~ s/\r\n\z// or $self->panic($x);
- $self->log("S: $msg", $x) if $self->{debug};
+ $self->logger("S: $msg", $x) if $self->{debug};
return $x;
}
@@ -1098,42 +1117,47 @@ sub _send($$;&) {
# 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.' ';
+ my $litplus;
+ my @command = ("$tag ");
+ my $dbg_cmd = "C: $command[0]";
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");
+ $litplus //= $self->_capable('LITERAL+') ? '+' : '';
+ push @command, $str, "{$len$litplus}", "\r\n";
+ $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
+ $dbg_cmd = 'C: [...]';
+
+ unless ($litplus) {
+ $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
$self->{STDIN}->flush();
my $x = $self->_getline();
$x =~ /\A\+ / or $self->panic($x);
+ @command = ();
}
- $self->{STDIN}->print($lit);
- $prefix = '';
+ push @command, $lit;
}
- $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $command) if $self->{debug};
- $self->{STDIN}->print($prefix, $command, "\r\n");
+ push @command, $command, "\r\n";
+ $self->logger($dbg_cmd, $command) if $self->{debug};
+ $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
$self->{STDIN}->flush();
+
my $r;
# wait for the answer
- while (defined($_ = $self->_getline())) {
- if (s/\A\Q$tag\E (OK|NO|BAD) //) {
+ while (1) {
+ my $x = $self->_getline();
+ if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) {
$IMAP_cond = $1;
- $IMAP_text = $1.' '.$_;
- $self->_resp_text($_);
+ $IMAP_text = $1.' '.$x;
+ $self->_resp_text($x);
$self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK';
$r = $1;
last;
}
else {
- $self->_resp($_, $cmd, $set, $callback);
+ $self->_resp($x, $cmd, $set, $callback);
}
}
@@ -1245,7 +1269,7 @@ sub _resp_text($$) {
local $_ = shift;
if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) {
- print STDERR $_, "\n";
+ $self->log($_);
}
elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) {
$self->fail($_);
@@ -1311,16 +1335,10 @@ sub _string($$) {
}
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;
- }
+ $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
+ # read a the rest of the response
$$stream = $self->_getline('[...]');
- return join ('', @acc);
+ return $lit;
}
else {
$self->panic($$stream);
@@ -1521,8 +1539,8 @@ sub _resp($$;$$$) {
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->logger("C: ", $x) if $self->{debug};
+ $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
$self->{STDIN}->flush();
}
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-03 21:21:36 +0000