From f3675b5adf9bdb421d668fa7fd894128f2d70a07 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 26 Jul 2015 02:42:32 +0200 Subject: Add an option 'logfile' to log debug messages. --- imapsync | 77 ++++++++++++++++++++++++++++++++-------------------- imapsync.1 | 12 +++++--- lib/Net/IMAP/Sync.pm | 47 ++++++++++++++++++-------------- 3 files changed, 81 insertions(+), 55 deletions(-) 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(); } -- cgit v1.2.3