Merge branch 'master' into HEAD

1 files changed, 34 insertions, 45 deletions

diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index a773f08..1dd54b7 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -16,18 +16,17 @@
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 #----------------------------------------------------------------------
 
-package Net::IMAP::InterIMAP v0.0.4;
+package Net::IMAP::InterIMAP v0.0.5;
 use warnings;
 use strict;
 
 use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
 use Config::Tiny ();
 use Errno qw/EEXIST EINTR/;
-use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC/;
 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/;
+use Socket qw/SOCK_STREAM SOCK_RAW IPPROTO_TCP AF_UNIX AF_INET AF_INET6 PF_UNSPEC SOCK_CLOEXEC :addrinfo/;
 
 use Exporter 'import';
 BEGIN {
@@ -40,9 +39,10 @@ BEGIN {
 }
 
 
-# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR' and 'TEXT-CHAR'.
+# Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR', 'list-char' and 'TEXT-CHAR'.
 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_LIST_CHAR    = qr/[\x21\x23-\x27\x2A\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-3])/;
@@ -239,7 +239,7 @@ sub quote($) {
     if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) {
         return $str;
     }
-    elsif ($str =~ qr/\A$RE_TEXT_CHAR+\z/) {
+    elsif ($str =~ qr/\A$RE_TEXT_CHAR*\z/) {
         $str =~ s/([\x22\x5C])/\\$1/g;
         return "\"$str\"";
     }
@@ -303,18 +303,13 @@ sub new($%) {
 
     if ($self->{type} eq 'tunnel') {
         my $command = $self->{command} // $self->fail("Missing tunnel command");
-
-        pipe $self->{STDOUT}, my $wd or $self->panic("Can't pipe: $!");
-        pipe my $rd, $self->{STDIN}  or $self->panic("Can't pipe: $!");
-
-        my $pid = fork // $self->panic("Can't fork: $!");
+        socketpair($self->{S}, my $s, AF_UNIX, SOCK_STREAM|SOCK_CLOEXEC, PF_UNSPEC) or $self->panic("socketpair: $!");
+        my $pid = fork // $self->panic("fork: $!");
         unless ($pid) {
             # children
-            foreach (\*STDIN, \*STDOUT, $self->{STDIN}, $self->{STDOUT}) {
-                close $_ or $self->panic("Can't close: $!");
-            }
-            open STDIN,  '<&', $rd or $self->panic("Can't dup: $!");
-            open STDOUT, '>&', $wd or $self->panic("Can't dup: $!");
+            close($self->{S}) or $self->panic("Can't close: $!");
+            open STDIN,  '<&', $s or $self->panic("Can't dup: $!");
+            open STDOUT, '>&', $s or $self->panic("Can't dup: $!");
 
             my $stderr2;
             if ($self->{'null-stderr'} // 0) {
@@ -337,30 +332,24 @@ sub new($%) {
         }
 
         # parent
-        foreach ($rd, $wd) {
-            close $_ or $self->panic("Can't close: $!");
-        }
-        foreach (qw/STDIN STDOUT/) {
-            binmode($self->{$_}) // $self->panic("binmode: $!")
-        }
+        close($s) or $self->panic("Can't close: $!");
     }
     else {
         foreach (qw/host port/) {
             $self->fail("Missing option $_") unless defined $self->{$_};
         }
-        my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
+        $self->{S} = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
                                             : $self->_tcp_connect(@$self{qw/host port/});
         if (defined $self->{keepalive}) {
-            setsockopt($socket, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
+            setsockopt($self->{S}, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
                 or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
-            setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
+            setsockopt($self->{S}, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
                 or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!");
         }
 
-        binmode($socket) // $self->panic("binmode: $!");
-        $self->_start_ssl($socket) if $self->{type} eq 'imaps';
-        $self->{$_} = $socket for qw/STDOUT STDIN/;
     }
+    binmode($self->{S}) // $self->panic("binmode: $!");
+    $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps';
 
     # command counter
     $self->{_TAG} = 0;
@@ -412,7 +401,7 @@ sub new($%) {
         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;
-            $self->_start_ssl($self->{STDIN}) if $self->{type} eq 'imaps';
+            $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps';
 
             # refresh the previous CAPABILITY list since the previous one could have been spoofed
             delete $self->{_CAPABILITIES};
@@ -525,11 +514,8 @@ sub DESTROY($) {
     Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL};
     Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX};
 
-    shutdown($self->{STDIN}, 2) if $self->{type} ne 'tunnel' and defined $self->{STDIN};
-    foreach (qw/STDIN STDOUT/) {
-        $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
-    }
-
+    shutdown($self->{S}, 2) if $self->{type} ne 'tunnel' and defined $self->{S};
+    $self->{S}->close() if defined $self->{S} and $self->{S}->opened();
     $self->stats() unless $self->{quiet};
 }
 
@@ -676,7 +662,7 @@ sub unselect($) {
 sub logout($) {
     my $self = shift;
     # don't bother if the connection is already closed
-    $self->_send('LOGOUT') if $self->{STDIN}->opened();
+    $self->_send('LOGOUT') if $self->{S}->opened();
     $self->{_STATE} = 'LOGOUT';
     undef $self;
 }
@@ -967,7 +953,7 @@ sub slurp($$$) {
     my $aborted = 0;
 
     my $rin = '';
-    vec($rin, fileno($_->{STDOUT}), 1) = 1 foreach @$selfs;
+    vec($rin, fileno($_->{S}), 1) = 1 foreach @$selfs;
 
     while (1) {
         # first, consider only unprocessed data without our own output
@@ -982,7 +968,7 @@ sub slurp($$$) {
             next if $r == -1 and $! == EINTR; # select(2) was interrupted
             die "select: $!" if $r == -1;
             return $aborted if $r == 0; # nothing more to read (timeout reached)
-            @ready = grep {vec($rout, fileno($_->{STDOUT}), 1)} @$selfs;
+            @ready = grep {vec($rout, fileno($_->{S}), 1)} @$selfs;
             $timeout = $timeleft if $timeout > 0;
         }
 
@@ -1420,7 +1406,7 @@ sub _tcp_connect($$$) {
 
     SOCKETS:
     foreach my $ai (@res) {
-        socket (my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol}) or $self->panic("connect: $!");
+        socket (my $s, $ai->{family}, $ai->{socktype}|SOCK_CLOEXEC, $ai->{protocol}) or $self->panic("socket: $!");
 
         # timeout connect/read/write/... after 30s
         # XXX we need to pack the struct timeval manually: not portable!
@@ -1435,9 +1421,6 @@ sub _tcp_connect($$$) {
             next if $! == EINTR; # try again if connect(2) was interrupted by a signal
             next SOCKETS;
         }
-
-        my $flags = fcntl($s, F_GETFD, 0)       or $self->panic("fcntl F_GETFD: $!");
-        fcntl($s, F_SETFD, $flags | FD_CLOEXEC) or $self->panic("fcntl F_SETFD: $!");
         return $s;
     }
     $self->fail("Can't connect to $host:$port");
@@ -1703,7 +1686,7 @@ sub _getline($;$) {
     my $self = shift;
     my $len = shift // 0;
 
-    my ($stdout, $ssl) = @$self{qw/STDOUT _SSL/};
+    my ($stdout, $ssl) = @$self{qw/S _SSL/};
     $self->fail("Lost connection") unless $stdout->opened();
 
     my (@lit, @line);
@@ -1902,7 +1885,7 @@ sub _cmd_flush($;$$) {
     my $self = shift;
     $self->_cmd_extend_( $_[0] // \$CRLF );
     my $z_flush = $_[1] // Z_SYNC_FLUSH; # the flush point type to use
-    my ($stdin, $ssl) = @$self{qw/STDIN _SSL/};
+    my ($stdin, $ssl) = @$self{qw/S _SSL/};
 
     if ($self->{debug}) {
         # remove $CRLF and literals
@@ -2192,7 +2175,13 @@ sub _nstring($$) {
 # Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string).
 sub _astring($$) {
     my ($self, $stream) = @_;
-    return $$stream =~ s/\A($RE_ATOM_CHAR+)// ? $1 : $self->_string($stream);
+    return $$stream =~ s/\A$RE_ASTRING_CHAR+//p ? ${^MATCH} : $self->_string($stream);
+}
+
+# Parse and consume an RFC 3501 list-mailbox (1*list-char / string).
+sub _list_mailbox($$) {
+    my ($self, $stream) = @_;
+    return $$stream =~ s/\A$RE_LIST_CHAR+//p ? ${^MATCH} : $self->_string($stream);
 }
 
 # Parse and consume an RFC 3501 string (quoted / literal).
@@ -2364,11 +2353,11 @@ sub _resp($$;&$$) {
         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);
             my @attrs = defined $attrs ? split(/ /, $attrs) : ();
-            my $mailbox = $self->_astring(\$_);
+            my $mailbox = $self->_list_mailbox(\$_);
             $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;
+            $self->panic($_) if defined $delim and $delim !~ s/\A"\\?(.)"\z/$1/;
             $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';