Merge tag 'upstream/0.4' into debian

Upstream version 0.4

1 files changed, 91 insertions, 29 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 3270108..a773f08 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 Guilhem Moulin <guilhem@fripost.org>
+# Copyright © 2015-2018 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
@@ -16,15 +16,15 @@
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 #----------------------------------------------------------------------
 
-package Net::IMAP::InterIMAP v0.0.3;
+package Net::IMAP::InterIMAP v0.0.4;
 use warnings;
 use strict;
 
 use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
 use Config::Tiny ();
-use Errno 'EINTR';
+use Errno qw/EEXIST EINTR/;
 use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/;
-use Net::SSLeay ();
+use Net::SSLeay 1.73 ();
 use List::Util qw/all first/;
 use POSIX ':signal_h';
 use Socket qw/SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/;
@@ -35,7 +35,7 @@ BEGIN {
     Net::SSLeay::SSLeay_add_ssl_algorithms();
     Net::SSLeay::randomize();
 
-    our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond
+    our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond
                         slurp is_dirty has_new_mails/;
 }
 
@@ -45,7 +45,7 @@ my $RE_ATOM_CHAR    = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/;
 my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/;
 my $RE_TEXT_CHAR    = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
 
-my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-2])/;
+my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-3])/;
 
 # Map each option to a regexp validating its values.
 my %OPTIONS = (
@@ -76,6 +76,35 @@ my $CRLF = "\x0D\x0A";
 #############################################################################
 # Utilities
 
+# xdg_basedir($xdg_variable, $default, $subdir, $path)
+#   Return $path if $path is absolute.  Otherwise, return
+#   "$ENV{$xdg_variable}/$subdir/$path" (resp. "~/$default/$subdir/path"
+#   if the "$xdg_variable" environment variable is not set).
+#   An error is raised if "$ENV{$xdg_variable}" (resp. "~/$default") is
+#   not an existing absolute directory.
+#   If "$ENV{$xdg_variable}/$subdir" doesn't exist, it is created with
+#   mode 0700.
+sub xdg_basedir($$$$) {
+    my ($xdg_variable, $default, $subdir, $path) = @_;
+    $path =~ /\A(\p{Print}+)\z/ or die "Insecure $path";
+    $path = $1;
+    return $path if $path =~ /\A\//;
+
+    my $basedir = $ENV{$xdg_variable};
+    unless (defined $basedir) {
+        my @getent = getpwuid($>);
+        $basedir = $getent[7] ."/". $default;
+    }
+    die "No such directory: ", $basedir unless -d $basedir;
+    $basedir .= "/".$subdir;
+    $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir";
+    $basedir = $1;
+    unless (mkdir ($basedir, 0700)) {
+        die "Couldn't create $basedir: $!\n" unless $! == EEXIST;
+    }
+    return $basedir ."/". $path;
+}
+
 # read_config($conffile, $sections, %opts)
 #   Read $conffile's default section, then each section in the array
 #   reference $section (which takes precedence).  %opts extends %OPTIONS
@@ -85,9 +114,6 @@ sub read_config($$%) {
     my $sections = shift;
     my %opts = (%OPTIONS, @_);
 
-    $conffile = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") .'/'. $conffile
-        unless $conffile =~ /\A\//; # relative path
-
     die "No such config file $conffile\n"
         unless defined $conffile and -f $conffile and -r $conffile;
 
@@ -597,7 +623,7 @@ sub incapable($@) {
 #   Issue an UID SEARCH command with the given $criterion.  For the "normal"
 #   UID SEARCH command from RFC 3501, return the list of matching UIDs;
 #   for the extended UID SEARCH command from RFC 4731 (ensuring ESEARCH
-#   capability is the caller's responsibility), return an "UID"
+#   capability is the caller's responsibility), return an optional "UID"
 #   indicator followed by a hash containing search data pairs.
 sub search($$) {
     my ($self, $crit) = @_;
@@ -1573,13 +1599,19 @@ sub _ssl_verify($$$) {
     return $ok; # 1=accept cert, 0=reject
 }
 
-my %SSL_proto = (
-    'SSLv2' => Net::SSLeay::OP_NO_SSLv2(),
-    'SSLv3' => Net::SSLeay::OP_NO_SSLv3(),
-    'TLSv1' => Net::SSLeay::OP_NO_TLSv1(),
-    'TLSv1.1' => Net::SSLeay::OP_NO_TLSv1_1(),
-    'TLSv1.2' => Net::SSLeay::OP_NO_TLSv1_2()
-);
+my %SSL_proto;
+BEGIN {
+    sub _append_ssl_proto($$) {
+        my ($k, $v) = @_;
+        $SSL_proto{$k} = $v if defined $v;
+    }
+    _append_ssl_proto( "SSLv2",   eval { Net::SSLeay::OP_NO_SSLv2()   } );
+    _append_ssl_proto( "SSLv3",   eval { Net::SSLeay::OP_NO_SSLv3()   } );
+    _append_ssl_proto( "TLSv1",   eval { Net::SSLeay::OP_NO_TLSv1()   } );
+    _append_ssl_proto( "TLSv1.1", eval { Net::SSLeay::OP_NO_TLSv1_1() } );
+    _append_ssl_proto( "TLSv1.2", eval { Net::SSLeay::OP_NO_TLSv1_2() } );
+    _append_ssl_proto( "TLSv1.3", eval { Net::SSLeay::OP_NO_TLSv1_3() } );
+}
 
 # $self->_start_ssl($socket)
 #   Upgrade the $socket to SSL/TLS.
@@ -1588,7 +1620,7 @@ sub _start_ssl($$) {
     my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!");
     my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE();
 
-    $self->{SSL_protocols} //= q{!SSLv2 !SSLv3};
+    $self->{SSL_protocols} //= q{!SSLv2 !SSLv3 !TLSv1 !TLSv1.1};
     my ($proto_include, $proto_exclude) = (0, 0);
     foreach (split /\s+/, $self->{SSL_protocols}) {
         my $neg = s/^!// ? 1 : 0;
@@ -1603,7 +1635,7 @@ sub _start_ssl($$) {
         $proto_exclude |= $x;
     }
     my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto;
-    $self->log("Disabling SSL protocol: ".join(', ', sort @proto_exclude)) if $self->{debug};
+    $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug};
     $ssl_options |= $SSL_proto{$_} foreach @proto_exclude;
     $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION();
 
@@ -1649,6 +1681,7 @@ sub _start_ssl($$) {
                                                        $v == 0x0301 ? 'TLSv1' :
                                                        $v == 0x0302 ? 'TLSv1.1' :
                                                        $v == 0x0303 ? 'TLSv1.2' :
+                                                       $v == 0x0304 ? 'TLSv1.3' :
                                                                       '??'),
                                                       $v));
         $self->log(sprintf('SSL cipher: %s (%d bits)'
@@ -1946,7 +1979,7 @@ sub _send($$;&) {
     }
     else {
         my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1
-                : $$command =~ /\AUID SEARCH / ? "\"$tag\"" # RFC 4466's tag-string
+                : $$command =~ /\AUID SEARCH / ? $tag # for RFC 4466's tag-string
                 : undef;
         $self->_recv($tag, $callback, $cmd, $set);
     }
@@ -2234,6 +2267,21 @@ sub _envelope($$) {
     return \@envelope;
 }
 
+# Parse and consume an RFC 4466 tagged-ext-comp plus a trailing parenthesis
+sub _tagged_ext_comp($$$) {
+    my ($self, $stream, $ret) = @_;
+    my $v = $$stream =~ s/\A\(// ? $self->_tagged_ext_comp(\$_, [])
+          : $self->_astring(\$_);
+    push @$ret, $v;
+    if ($$stream =~ s/\A\)//) {
+        return $ret;
+    } elsif ($$stream =~ s/\A //) {
+        $self->_tagged_ext_comp(\$_, $ret)
+    } else {
+        $self->panic($$stream);
+    }
+}
+
 # $self->_resp($buf, [$callback, $cmd, $set] )
 #   Parse an untagged response line or a continuation request line.
 #   (The trailing CRLF must be removed.)  The internal cache is
@@ -2288,16 +2336,30 @@ sub _resp($$;&$$) {
         elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
             $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH';
         }
-        elsif (defined $set and s/\AESEARCH \(TAG \Q$set\E\)( UID)?//) {
-            my $uid = $1;
-            my %ret; # RFC 4731
+        elsif (s/\AESEARCH( |\z)/$1/) {
+            my $tag = $1 if s/\A \(TAG \"($RE_ASTRING_CHAR+)\"\)//;
+            my $uid = s/\A UID// ? "UID" : undef;
+            my @ret;
             while ($_ ne '') {
-                $self->fail("RFC 4731 violation in ESEARCH response")
-                    # XXX RFC 4466's tagged-ext-comp unsupported
-                    unless s/\A ($RE_ATOM_CHAR+) ([0-9,:]+)//;
-                $ret{uc $1} = $2;
+                # RFC 4466 "tagged-ext-label" is a valid RFC 3501 "atom"
+                s/\A ($RE_ATOM_CHAR+) // or $self->panic();
+                my $label = uc($1);
+                my $value;
+                if (s/\A([0-9,:]+)//) {
+                    # RFC 4466 tagged-ext-simple
+                    $value = $1;
+                } elsif (s/\A\(//) {
+                    # RFC 4466 "(" [tagged-ext-comp] ")"
+                    $value = s/\A\)// ? [] : $self->_tagged_ext_comp(\$_, []);
+                } else {
+                    $self->panic();
+                }
+                # don't use a hash since some extensions might give more
+                # than one response for a same key
+                push @ret, $label => $value;
             }
-            $callback->($uid, %ret) if defined $callback and $cmd eq 'SEARCH';
+            $callback->($uid, @ret) if defined $callback and $cmd eq 'SEARCH'
+                and defined $set and $set eq $tag;
         }
         elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) {
             my ($delim, $attrs) = ($2, $1);
@@ -2306,7 +2368,7 @@ sub _resp($$;&$$) {
             $self->panic($_) unless $_ eq '';
             $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
             undef $delim if uc $delim eq 'NIL';
-            $delim =~ s/\A"(.*)"\Z/$1/ if defined $delim;
+            $delim =~ s/\A"(.*)"\z/$1/ if defined $delim;
             $self->_update_cache_for($mailbox, DELIMITER => $delim);
             $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs);
             $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST';