Refactor logging logic.

Also, introduce new option 'logger-prefix' to determine the prefix of
each log line.

Closes: #942725.

1 files changed, 47 insertions, 26 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 2d1f644..bb27009 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -17,6 +17,7 @@
 #----------------------------------------------------------------------
 
 package Net::IMAP::InterIMAP v0.0.5;
+use v5.10.0;
 use warnings;
 use strict;
 
@@ -280,7 +281,8 @@ our $IMAP_text;
 #
 #   - 'name': An optional instance name to include in log messages.
 #
-#   - 'logger-fd': An optional filehandle to use for debug output.
+#   - 'logger-fd': An optional filehandle to use for debug output
+#     (default: STDERR).
 #
 #   - 'keepalive': Whether to enable sending of keep-alive messages.
 #     (type=imap or type=imaps).
@@ -289,6 +291,7 @@ sub new($%) {
     my $class = shift;
     my $self = { @_ };
     bless $self, $class;
+    require 'Time/HiRes.pm' if defined $self->{'logger-fd'};
 
     # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
     # (cf RFC 3501 section 3)
@@ -378,11 +381,6 @@ sub new($%) {
     # are considered.
     $self->{_MODIFIED} = {};
 
-    if (defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno
-            and $self->{'logger-fd'}->fileno != fileno STDERR) {
-        require 'Time/HiRes.pm';
-    }
-
     # wait for the greeting
     my $x = $self->_getline();
     $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x);
@@ -539,32 +537,55 @@ sub DESTROY($) {
 
 # $self->log($message, [...])
 # $self->logger($message, [...])
-#   Log a $message.  The latter method is used to log in the 'logger-fd', and
-#   add timestamps.
+#   Log a $message.  The latter method is used to log in the 'logger-fd'
+#   (and adds timestamps).
 sub log($@) {
     my $self = shift;
     return unless @_;
-    $self->logger(@_) if defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno
-        and $self->{'logger-fd'}->fileno != fileno STDERR;
-    my $prefix = $self->{name} // '';
-    $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
-    $prefix .= ': ' unless $prefix eq '';
-    print STDERR $prefix, @_, "\n";
+    my $prefix = _logger_prefix($self);
+    if (defined (my $fd = $self->{'logger-fd'})) {
+        say $fd _date(), " ", $prefix, @_;
+    }
+    say STDERR $prefix, @_;
 }
 sub logger($@) {
     my $self = shift;
-    return unless @_ and defined $self->{'logger-fd'};
-    my $prefix = '';
-    if (defined $self->{'logger-fd'}->fileno and defined $self->{'logger-fd'}->fileno
-            and $self->{'logger-fd'}->fileno != fileno STDERR) {
-        my ($s, $us) = Time::HiRes::gettimeofday();
-        $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us";
-        $prefix .= ' ' if defined $self->{name} or $self->{_STATE} eq 'SELECTED';
-    }
-    $prefix .= $self->{name} if defined $self->{name};
-    $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
-    $prefix .= ': ' unless $prefix eq '';
-    $self->{'logger-fd'}->say($prefix, @_);
+    return unless @_;
+    my $prefix = _logger_prefix($self);
+    if (defined (my $fd = $self->{'logger-fd'})) {
+        say $fd _date(), " ", $prefix, @_;
+    } else {
+        say STDERR $prefix, @_;
+    }
+}
+sub _date() {
+    my ($s, $us) = Time::HiRes::gettimeofday();
+    my $t = POSIX::strftime("%b %e %H:%M:%S", localtime($s));
+    return "$t.$us"; # millisecond precision
+}
+
+# $self->_logger_prefix()
+#   Format a prefix for logging with printf(3)-like sequences:
+#     %n: the object name
+#     %m: mailbox, either explicit named or selected
+sub _logger_prefix($) {
+    my $self = shift;
+    my $format = $self->{'logger-prefix'} // return "";
+
+    my %seq = ( "%" => "%", m => $self->{mailbox}, n => $self->{name} );
+    $seq{m} //= $self->{_SELECTED} // die
+        if defined $self->{_STATE} and $self->{_STATE} eq 'SELECTED';
+
+    do {} while
+        # rewrite conditionals (loop because of nesting)
+        $format =~ s#%\? ([[:alpha:]]) \?
+                ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )* )
+         (?: \& ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )*) )?
+            \?# ($seq{$1} // "") ne "" ? $2 : ($3 // "") #agex;
+
+    $format =~ s#\\([&?\\])#$1#g; # unescape remaining '&', '?' and '\'
+    $format =~ s#%([%mn])# $seq{$1} #ge;
+    return $format;
 }