Merge branch 'master' into debian

1 files changed, 72 insertions, 37 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 19895c4..bb27009 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -1,6 +1,6 @@
 #----------------------------------------------------------------------
 # A minimal IMAP4 client for QRESYNC-capable servers
-# Copyright © 2015-2018 Guilhem Moulin <guilhem@fripost.org>
+# Copyright © 2015-2019 Guilhem Moulin <guilhem@fripost.org>
 #
 # This program is free software: you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -17,10 +17,11 @@
 #----------------------------------------------------------------------
 
 package Net::IMAP::InterIMAP v0.0.5;
+use v5.10.0;
 use warnings;
 use strict;
 
-use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
+use Compress::Raw::Zlib qw/Z_OK Z_STREAM_END Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
 use Config::Tiny ();
 use Errno qw/EEXIST EINTR/;
 use Net::SSLeay 1.73 ();
@@ -92,11 +93,9 @@ sub xdg_basedir($$$$) {
     return $path if $path =~ /\A\//;
 
     my $basedir = $ENV{$xdg_variable};
-    unless (defined $basedir) {
-        my @getent = getpwuid($>);
-        $basedir = $getent[7] ."/". $default;
-    }
+    $basedir = ($ENV{HOME} // "") ."/". $default unless defined $basedir;
     die "No such directory: ", $basedir unless -d $basedir;
+
     $basedir .= "/".$subdir;
     $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir";
     $basedir = $1;
@@ -282,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).
@@ -291,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)
@@ -380,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);
@@ -409,8 +405,8 @@ sub new($%) {
             @caps = $self->capabilities();
         }
 
-        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? $1 : undef } @caps);
-        my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef}
+        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? uc($1) : undef } @caps);
+        my $mech = (grep defined, map {my $m = uc($_); (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
@@ -438,8 +434,21 @@ sub new($%) {
             $self->fail("Unsupported authentication mechanism: $mech");
         }
 
+        my $dbg; 
         delete $self->{password}; # no need to remember passwords
+        if (($self->{debug} // 0) == 1) {
+            $dbg = $self->{debug}--;
+            my $cmd = $command =~ /\A(LOGIN) / ? $1
+                    : $command =~ /\A(AUTHENTICATE \S+)(?: .*)?\z/ ? $1
+                    : $self->panic();
+            $self->logger('C: xxx ', $cmd, ' [REDACTED]');
+        }
         $self->_send($command, $callback);
+        if (defined $dbg) {
+            $self->logger('S: xxx ', $IMAP_text);
+            $self->{debug} = $dbg;
+        }
+
         unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) {
             # refresh the CAPABILITY list since the previous one had only pre-login capabilities
             delete $self->{_CAPABILITIES};
@@ -509,6 +518,7 @@ sub stats($) {
 
 # Destroy a Net::IMAP::InterIMAP object.
 sub DESTROY($) {
+    local($., $@, $!, $^E, $?);
     my $self = shift;
     $self->{_STATE} = 'LOGOUT';
 
@@ -527,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';
+    return unless @_;
+    my $prefix = _logger_prefix($self);
+    if (defined (my $fd = $self->{'logger-fd'})) {
+        say $fd _date(), " ", $prefix, @_;
+    } else {
+        say STDERR $prefix, @_;
     }
-    $prefix .= $self->{name} if defined $self->{name};
-    $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
-    $prefix .= ': ' unless $prefix eq '';
-    $self->{'logger-fd'}->say($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;
 }
 
 
@@ -1678,6 +1711,7 @@ sub _start_ssl($$) {
     }
 
     @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
+    undef $self; # the verify callback has reference to $self, free it now
 }
 
 
@@ -1710,8 +1744,9 @@ sub _getline($;$) {
             $self->{_OUTRAWCOUNT} += $n;
 
             if (defined (my $i = $self->{_Z_INFLATE})) {
-                $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or
-                    $self->panic("Inflation failed: ", $i->msg());
+                my $r = $i->inflate($buf, $self->{_OUTBUF});
+                $self->panic("Inflation failed: $r ", $i->msg())
+                    unless $r == Z_OK or $r == Z_STREAM_END;
             }
             else {
                 $self->{_OUTBUF} = $buf;
@@ -1828,8 +1863,8 @@ sub _cmd_extend($$) {
         $self->_cmd_extend_($args);
     }
     else {
-        # server supports LITERAL+: flush the command before each
-        # literal
+        # server doesn't supports LITERAL+: flush the command before
+        # each literal
         my ($offset, $litlen) = (0, 0);
         while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) {
             my $line = substr($$args, $offset, $idx+1-$offset);