diff options
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 73 |
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; } |