Merge branch 'master' into debian

1 files changed, 75 insertions, 57 deletions

diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm
index 9db339b..26303a6 100644
--- a/lib/Net/IMAP/Sync.pm
+++ b/lib/Net/IMAP/Sync.pm
@@ -21,7 +21,9 @@ use warnings;
 use strict;
 
 use Config::Tiny ();
+use IO::Select ();
 use List::Util 'first';
+use POSIX 'strftime';
 use Socket 'SO_KEEPALIVE';
 
 use Exporter 'import';
@@ -206,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.
@@ -219,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 = { @_ };
@@ -227,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} = '';
@@ -335,11 +333,12 @@ sub new($%) {
             @caps = $self->capabilities();
         }
 
-        $self->fail("Logins are disabled.") if grep {$_ eq 'LOGINDISABLED'} @caps;
-        my @mechs = grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps;
+        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps);
         my $mech = (grep defined, map {my $m = $_; (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
+                                               grep {$_ eq 'LOGINDISABLED'} @caps;
 
         my ($command, $callback);
         my ($username, $password) = @$self{qw/username password/};
@@ -384,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, ': ', @_);
 }
 
 
@@ -708,24 +715,35 @@ sub notify($@) {
     my $command = 'NOTIFY ';
     $command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
     $self->_send($command);
+    $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT});
 }
 
 
 # $self->slurp()
-#   Turn on non-blocking IO, try to as many lines as possible, then turn
-#   non-blocking IO back off and return the number of lines read.
+#   See if the server has sent some unprocessed data; try to as many
+#   lines as possible, process them, and return the number of lines
+#   read.
 #   This is mostly useful when waiting for notifications while no
 #   command is progress, cf. RFC 5465 (NOTIFY).
 sub slurp($) {
     my $self = shift;
+
+    my $stdout = $self->{STDOUT};
     my $read = 0;
-    $self->{STDOUT}->blocking(0) // $self->panic("Can't turn on non-blocking IO: $!");
-    while (defined (my $x = $self->_getline())) {
-        $self->_resp($x);
-        $read++
+
+    while (1) {
+        # Unprocessed data within the current SSL frame would cause
+        # select(2) to block/timeout due to the raw socket not being
+        # ready.
+        unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) {
+            my $sel = IO::Select::->new($stdout);
+            my ($ok) = $self->{_SEL_OUT}->can_read(0);
+            return $read unless defined $ok;
+        }
+
+        $self->_resp( $self->_getline() );
+        $read++;
     }
-    $self->{STDOUT}->blocking(1) // $self->panic("Can't turn off non-blocking IO: $!");
-    return $read;
 }
 
 
@@ -757,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};
 }
 
@@ -832,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];
 }
@@ -1038,13 +1056,14 @@ sub _fingerprint_match($$$) {
 
 # $self->_getline([$msg])
 #   Read a line from the handle and strip the trailing CRLF.
+#   /!\ Don't use this method with non-blocking IO!
 sub _getline($;$) {
     my $self = shift;
     my $msg = shift // '';
 
-    my $x = $self->{STDOUT}->getline() // return; # non-blocking IO
+    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;
 }
 
@@ -1098,42 +1117,47 @@ sub _send($$;&) {
     # literals, mark literals as such and then the whole command in one
     # go, otherwise send literals one at a time
     my $tag = sprintf '%06d', $self->{_TAG}++;
-    my $prefix = $tag.' ';
+    my $litplus;
+    my @command = ("$tag ");
+    my $dbg_cmd = "C: $command[0]";
     while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
         my ($str, $len) = ($1, $2);
         my $lit = substr $command, 0, $len, ''; # consume the literal
 
-        if ($self->_capable('LITERAL+')) { # RFC 2088 LITERAL+
-            $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len+}") if $self->{debug};
-            $self->{STDIN}->print($prefix, $str, "{$len+}\r\n");
-        }
-        else {
-            $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $str, "{$len}") if $self->{debug};
-            $self->{STDIN}->print($prefix, $str, "{$len}\r\n");
+        $litplus //= $self->_capable('LITERAL+') ? '+' : '';
+        push @command,       $str, "{$len$litplus}", "\r\n";
+        $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
+        $dbg_cmd = 'C: [...]';
+
+        unless ($litplus) {
+            $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
             $self->{STDIN}->flush();
             my $x = $self->_getline();
             $x =~ /\A\+ / or $self->panic($x);
+            @command = ();
         }
-        $self->{STDIN}->print($lit);
-        $prefix = '';
+        push @command, $lit;
     }
-    $self->log('C: ', ($prefix ne '' ? $prefix : '[...]'), $command) if $self->{debug};
-    $self->{STDIN}->print($prefix, $command, "\r\n");
+    push @command, $command, "\r\n";
+    $self->logger($dbg_cmd, $command) if $self->{debug};
+    $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
     $self->{STDIN}->flush();
 
+
     my $r;
     # wait for the answer
-    while (defined($_ = $self->_getline())) {
-        if (s/\A\Q$tag\E (OK|NO|BAD) //) {
+    while (1) {
+        my $x = $self->_getline();
+        if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) {
             $IMAP_cond = $1;
-            $IMAP_text = $1.' '.$_;
-            $self->_resp_text($_);
+            $IMAP_text = $1.' '.$x;
+            $self->_resp_text($x);
             $self->fail($IMAP_text, "\n") unless defined wantarray or $IMAP_cond eq 'OK';
             $r = $1;
             last;
         }
         else {
-            $self->_resp($_, $cmd, $set, $callback);
+            $self->_resp($x, $cmd, $set, $callback);
         }
     }
 
@@ -1245,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($_);
@@ -1311,16 +1335,10 @@ sub _string($$) {
     }
     elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
         # literal
-        my $count = $1;
-        my @acc;
-        my $buf;
-        while ($count > 0) {
-            my $n = $self->{STDOUT}->read($buf, $count);
-            push @acc, $buf;
-            $count -= $n;
-        }
+        $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
+        # read a the rest of the response
         $$stream = $self->_getline('[...]');
-        return join ('', @acc);
+        return $lit;
     }
     else {
         $self->panic($$stream);
@@ -1521,8 +1539,8 @@ sub _resp($$;$$$) {
     elsif (s/\A\+ //) {
         if (defined $callback and $cmd eq 'AUTHENTICATE') {
             my $x = $callback->($_);
-            print STDERR "C: ", $x, "\n" if $self->{debug};
-            $self->{STDIN}->print($x, "\r\n");
+            $self->logger("C: ", $x) if $self->{debug};
+            $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
             $self->{STDIN}->flush();
         }
     }