From ebdf2537dc0eb1b54e4420c2bdd673110ced30d3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 26 Jul 2015 00:58:12 +0200 Subject: LOGINDISABLED only disables plain-text mechanisms. Also, LOGIN is always supported. --- lib/Net/IMAP/Sync.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'lib/Net/IMAP') diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 9db339b..cea647f 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -335,11 +335,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/}; -- cgit v1.2.3 From 71cddb9e85ae0ea2468c64687319677e6bc9746a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 26 Jul 2015 01:14:39 +0200 Subject: Clean how we're sending commands to the server. --- lib/Net/IMAP/Sync.pm | 55 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 28 deletions(-) (limited to 'lib/Net/IMAP') diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index cea647f..6c4b8a3 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -1043,7 +1043,7 @@ 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}; return $x; @@ -1099,42 +1099,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->log($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->log($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); } } @@ -1312,16 +1317,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); @@ -1523,7 +1522,7 @@ sub _resp($$;$$$) { 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->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!"); $self->{STDIN}->flush(); } } -- cgit v1.2.3 From 1c78a883849c5ffc4e2fbd84dc912dec18486759 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 26 Jul 2015 01:36:48 +0200 Subject: Don't use readline with non-blocking IO. Instead use the select(2) syscall to see if there data available while we're waiting for notifications. Except for SSL/TLS connections, where we have to check if there is unprocessed cached data in the current SSL frame. --- lib/Net/IMAP/Sync.pm | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) (limited to 'lib/Net/IMAP') diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index 6c4b8a3..7c76996 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -21,6 +21,7 @@ use warnings; use strict; use Config::Tiny (); +use IO::Select (); use List::Util 'first'; use Socket 'SO_KEEPALIVE'; @@ -709,24 +710,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; } @@ -1039,6 +1051,7 @@ 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 // ''; -- cgit v1.2.3 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. --- lib/Net/IMAP/Sync.pm | 47 ++++++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 21 deletions(-) (limited to 'lib/Net/IMAP') 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