Merge branch 'master' into debian

1 files changed, 105 insertions, 90 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 3b9e10e..65a0c10 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,7 +20,7 @@ package Net::IMAP::InterIMAP v0.0.2;
 use warnings;
 use strict;
 
-use Compress::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
+use Compress::Zlib qw/Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
 use Config::Tiny ();
 use Errno 'EWOULDBLOCK';
 use IO::Select ();
@@ -221,6 +221,15 @@ sub new($%) {
     my $self = { @_ };
     bless $self, $class;
 
+    foreach (keys %$self) {
+        next unless defined $self->{$_};
+        if (uc $self->{$_} eq 'YES') {
+            $self->{$_} = 1;
+        } elsif (uc $self->{$_} eq 'NO') {
+            $self->{$_} = 0;
+        }
+    }
+
     # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
     # (cf RFC 3501 section 3)
     $self->{_STATE} = '';
@@ -246,7 +255,7 @@ sub new($%) {
             open STDOUT, '>&', $wd or $self->panic("Can't dup: $!");
 
             my $stderr2;
-            if (uc ($self->{'null-stderr'} // 'NO') eq 'YES') {
+            if ($self->{'null-stderr'} // 0) {
                 open $stderr2, '>&', *STDERR;
                 open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
             }
@@ -271,28 +280,13 @@ sub new($%) {
         }
     }
     else {
+        require 'IO/Socket/INET.pm';
         my %args = (Proto => 'tcp', Blocking => 1);
         $args{PeerHost} = $self->{host} // $self->fail("Missing option host");
         $args{PeerPort} = $self->{port} // $self->fail("Missing option port");
 
-        my $socket;
-        if ($self->{type} eq 'imap') {
-            require 'IO/Socket/INET.pm';
-            $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
-        }
-        else {
-            require 'IO/Socket/SSL.pm';
-            if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
-                $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
-            }
-            my $fpr = delete $self->{SSL_fingerprint};
-            $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
-            $socket = IO::Socket::SSL->new(%args)
-                or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
-
-            # ensure we're talking to the right server
-            $self->_fingerprint_match($socket, $fpr) if defined $fpr;
-        }
+        my $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
+        $self->_start_ssl($socket) if $self->{type} eq 'imaps';
 
         $socket->sockopt(SO_KEEPALIVE, 1);
         $self->{$_} = $socket for qw/STDOUT STDIN/;
@@ -347,31 +341,17 @@ sub new($%) {
         $self->{_STATE} = 'UNAUTH';
         my @caps = $self->capabilities();
 
-        if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1
+        if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # RFC 2595 section 5.1
             $self->fail("Server did not advertise STARTTLS capability.")
                 unless grep {$_ eq 'STARTTLS'} @caps;
-
-            require 'IO/Socket/SSL.pm';
-            $self->_send('STARTTLS');
-
-            my %sslargs;
-            if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) {
-                $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO';
-            }
-            my $fpr = delete $self->{SSL_fingerprint};
-            $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
-            IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs)
-                or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
-
-            # ensure we're talking to the right server
-            $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr;
+            $self->_start_ssl($self->{STDIN}) if $self->{type} eq 'imaps';
 
             # refresh the previous CAPABILITY list since the previous one could have been spoofed
             delete $self->{_CAPABILITIES};
             @caps = $self->capabilities();
         }
 
-        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps);
+        my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? $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;
@@ -411,9 +391,9 @@ sub new($%) {
     $self->{_STATE} = 'AUTH';
 
     # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
-    if (uc ($self->{compress} // 'NO') eq 'YES') {
+    if ($self->{compress} // 1 and
+            my @algos = grep defined, map { /^COMPRESS=(.+)/i ? uc $1 : undef } @{$self->{_CAPABILITIES}}) {
         my @supported = qw/DEFLATE/; # supported compression algorithms
-        my @algos = grep defined, map { /^COMPRESS=(.+)/ ? uc $1 : undef } @{$self->{_CAPABILITIES}};
         my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported;
         if (!defined $algo) {
             $self->warn("Couldn't find a suitable compression algorithm. Not enabling compression.");
@@ -425,16 +405,11 @@ sub new($%) {
                 $self->panic($IMAP_text) unless $r eq 'OK';
 
                 if ($algo eq 'DEFLATE') {
-                    my ($status, $d, $i);
                     my %args = ( -WindowBits => 0 - MAX_WBITS );
-                    ($d, $status) = Compress::Zlib::deflateInit(%args);
-                    $self->panic("Can't create deflation stream: ", $d->msg())
-                        unless defined $d and $status == Z_OK;
-
-                    ($i, $status) = Compress::Zlib::inflateInit(%args);
-                    $self->panic("Can't create inflation stream: ", $i->msg())
-                        unless defined $i and $status == Z_OK;
-                    @$self{qw/_Z_DEFLATE _Z_INFLATE/} = ($d, $i);
+                    $self->{_Z_DEFLATE} = Compress::Zlib::deflateInit(%args) //
+                        $self->panic("Can't create deflation stream");
+                    $self->{_Z_INFLATE} = Compress::Zlib::inflateInit(%args) //
+                        $self->panic("Can't create inflation stream");
                 }
                 else {
                     $self->fail("Unsupported compression algorithm: $algo");
@@ -458,6 +433,22 @@ sub new($%) {
 }
 
 
+# Print traffic statistics
+sub stats($) {
+    my $self = shift;
+    my $msg = 'IMAP traffic (bytes):';
+    $msg .= ' recv '._kibi($self->{_OUTCOUNT});
+    $msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}).
+            ', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')'
+      if defined $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0;
+    $msg .= ' sent '._kibi($self->{_INCOUNT});
+    $msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}).
+            ', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')'
+      if defined $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0;
+    $self->log($msg);
+}
+
+
 # Log out when the Net::IMAP::InterIMAP object is destroyed.
 sub DESTROY($) {
     my $self = shift;
@@ -467,16 +458,7 @@ sub DESTROY($) {
         $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
     }
 
-    unless ($self->{quiet}) {
-        my $msg = "Connection closed";
-        $msg .= " in=$self->{_INCOUNT}";
-        $msg .= " (raw=$self->{_INRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).")"
-          if defined $self->{_INRAWCOUNT} and $self->{_INCOUNT} > 0 and $self->{_INCOUNT} != $self->{_INRAWCOUNT};
-        $msg .= ", out=$self->{_OUTCOUNT}";
-        $msg .= " (raw=$self->{_OUTRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).")"
-          if defined $self->{_OUTRAWCOUNT} and $self->{_OUTCOUNT} > 0 and $self->{_OUTCOUNT} != $self->{_OUTRAWCOUNT};
-        $self->log($msg);
-    }
+    $self->stats() unless $self->{quiet};
 }
 
 
@@ -1208,17 +1190,51 @@ sub push_flag_updates($$@) {
 # Private methods
 
 
-# $self->_fingerprint_match($socket, $fingerprint)
-#   Croak unless the fingerprint of the peer certificate of the
-#   IO::Socket::SSL object doesn't match the given $fingerprint.
-sub _fingerprint_match($$$) {
-    my ($self, $socket, $fpr) = @_;
+# $self->_start_ssl($socket)
+#   Upgrade the $socket to IO::Socket::SSL.
+sub _start_ssl($$) {
+    my ($self, $socket) = @_;
+    require 'IO/Socket/SSL.pm';
+    require 'Net/SSLeay.pm';
+
+    my %sslargs = (SSL_create_ctx_callback => sub($) {
+        my $ctx = shift;
+        my $rv;
+
+        # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html
+        $rv = Net::SSLeay::CTX_get_options($ctx)
+            | Net::SSLeay::OP_SINGLE_ECDH_USE()
+            | Net::SSLeay::OP_SINGLE_DH_USE()
+            | Net::SSLeay::OP_NO_SSLv2()
+            | Net::SSLeay::OP_NO_SSLv3()
+            | Net::SSLeay::OP_NO_COMPRESSION();
+        Net::SSLeay::CTX_set_options($ctx, $rv);
+
+        # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html
+        $rv = Net::SSLeay::CTX_get_mode($ctx)
+            | Net::SSLeay::MODE_AUTO_RETRY() # don't fail SSL_read on renegociation
+            | Net::SSLeay::MODE_RELEASE_BUFFERS();
+        Net::SSLeay::CTX_set_mode($ctx, $rv);
+    });
+
+    my $fpr = delete $self->{SSL_fingerprint};
+    my $vrfy = delete $self->{SSL_verify_trusted_peer};
+    $sslargs{SSL_verify_mode} = ($vrfy // 1) ? Net::SSLeay::VERIFY_PEER() : Net::SSLeay::VERIFY_NONE();
+    $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self;
+
+    IO::Socket::SSL->start_SSL($socket, %sslargs)
+        or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR");
+
+    # ensure we're talking to the right server
+    if (defined $fpr) {
+        my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
+        my $fpr2 = $socket->get_fingerprint($algo);
+        $fpr =~ s/.*\$//;
+        $fpr2 =~ s/.*\$//;
+        $self->fail("Fingerprint don't match!  MiTM in action?")
+                unless uc $fpr eq uc $fpr2;
+    }
 
-    my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256';
-    my $fpr2 = $socket->get_fingerprint($algo);
-    $fpr =~ s/.*\$//;
-    $fpr2 =~ s/.*\$//;
-    $self->fail("Fingerprint don't match!  MiTM in action?") unless uc $fpr eq uc $fpr2;
 }
 
 
@@ -1242,21 +1258,12 @@ sub _getline($;$) {
             # (read at most 2^14 bytes, the maximum length of an SSL
             # frame, to ensure to guaranty that there is no pending data)
             my $n = $stdout->sysread(my $buf,16384,0);
-            unless (defined $n) {
-                next unless $! == EWOULDBLOCK and
-                    (ref $stdout ne 'IO::Socket::SSL' or
-                        # sysread might fail if must finish a SSL handshake first
-                        ($IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_READ() or
-                         $IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_WRITE()));
-                $self->panic("Can't read: $!")
-            }
+            $self->panic("Can't read: $!") unless defined $n;
             $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
             $self->{_OUTRAWCOUNT} += $n;
 
             if (defined (my $i = $self->{_Z_INFLATE})) {
-                my ($out, $status) = $i->inflate($buf);
-                $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK;
-                $buf = $out;
+                $buf = $i->inflate($buf) // $self->panic("Inflation failed: ", $i->msg());
             }
             $self->{_OUTBUF} = $buf;
         }
@@ -1345,9 +1352,7 @@ sub _write($@) {
 sub _z_flush($;$) {
     my ($self,$t) = @_;
     my $d = $self->{_Z_DEFLATE} // return;
-    my ($out, $status) = $d->flush($t);
-    $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
-    $self->_write($out);
+    $self->_write( $d->flush($t) // $self->panic("Can't flush deflation stream: ", $d->msg()) );
 }
 
 
@@ -1378,9 +1383,8 @@ sub _send_cmd($) {
             $line = substr($command, $offset, $idx-1-$offset);
             $litlen = $litplus ? ($line =~ s/\{([0-9]+)\}\z/{$1+}/ ? $1 : $self->panic())
                                : ($line =~  /\{([0-9]+)\}\z/       ? $1 : $self->panic());
-            $z_flush2 = ($litlen > 4096 and                     # large literal
-                (uc ($self->{'use-binary'} // 'YES') eq 'NO'
-                        or $line =~ /~\{[0-9]+\}\z/)            # literal8, RFC 3516 BINARY
+            $z_flush2 = ($litlen > 4096 and                              # large literal
+                ($self->{'use-binary'} // 1 or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY
             ) ? 1 : 0;
         }
         $self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug};
@@ -1393,11 +1397,7 @@ sub _send_cmd($) {
         else {
             for (my $i = 0; $i <= $#data; $i++) {
                 $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
-
-                my ($out, $status) = $d->deflate($data[$i]);
-                $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
-                $self->_write($out);
-
+                $self->_write( $d->deflate($data[$i]) // $self->panic("Deflation failed: ", $d->msg()) );
                 $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
             }
         }
@@ -1555,6 +1555,21 @@ sub _select_or_examine($$$;$$) {
 }
 
 
+sub _kibi($) {
+    my $n = shift;
+    if ($n < 1024) {
+        $n;
+    } elsif ($n < 1048576) {
+        sprintf '%.2fK', $n / 1024.;
+    } elsif ($n < 1073741824) {
+        sprintf '%.2fM', $n / 1048576.;
+    } else {
+        sprintf '%.2fG', $n / 1073741824.;
+    }
+
+}
+
+
 
 #############################################################################
 # Parsing methods