From: Guilhem Moulin <guilhem@fripost.org>
Date: Sun, 26 Jul 2015 00:42:32 +0000 (+0200)
Subject: Add an option 'logfile' to log debug messages.
X-Git-Url: https://git.g-eek.se/?a=commitdiff_plain;h=f3675b5adf9bdb421d668fa7fd894128f2d70a07;p=interimap.git

Add an option 'logfile' to log debug messages.
---

diff --git a/imapsync b/imapsync
index 00beec7..d24723d 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/;
@@ -48,8 +48,9 @@ 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 +64,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 +102,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 +175,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 +198,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 +607,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 +622,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 +634,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 +686,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 +699,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 +708,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 +717,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 +746,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 +802,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 +813,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 +848,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 +869,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 +902,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 +938,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 +1010,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 fec830e..f4f6965 100644
--- a/imapsync.1
+++ b/imapsync.1
@@ -129,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 +167,11 @@ 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 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.
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 7c76996..26303a6 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -23,6 +23,7 @@ use strict;
 use Config::Tiny ();
 use IO::Select ();
 use List::Util 'first';
+use POSIX 'strftime';
 use Socket 'SO_KEEPALIVE';
 
 use Exporter 'import';
@@ -207,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.
@@ -220,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 = { @_ };
@@ -228,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} = '';
@@ -386,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, ': ', @_);
 }
 
 
@@ -770,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};
 }
 
@@ -845,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];
 }
@@ -1058,7 +1063,7 @@ sub _getline($;$) {
 
     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;
 }
 
@@ -1121,7 +1126,7 @@ sub _send($$;&) {
 
         $litplus //= $self->_capable('LITERAL+') ? '+' : '';
         push @command,       $str, "{$len$litplus}", "\r\n";
-        $self->log($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
+        $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
         $dbg_cmd = 'C: [...]';
 
         unless ($litplus) {
@@ -1134,7 +1139,7 @@ sub _send($$;&) {
         push @command, $lit;
     }
     push @command, $command, "\r\n";
-    $self->log($dbg_cmd, $command) if $self->{debug};
+    $self->logger($dbg_cmd, $command) if $self->{debug};
     $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
     $self->{STDIN}->flush();
 
@@ -1264,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($_);
@@ -1534,7 +1539,7 @@ sub _resp($$;$$$) {
     elsif (s/\A\+ //) {
         if (defined $callback and $cmd eq 'AUTHENTICATE') {
             my $x = $callback->($_);
-            print STDERR "C: ", $x, "\n" if $self->{debug};
+            $self->logger("C: ", $x) if $self->{debug};
             $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
             $self->{STDIN}->flush();
         }