From bacb78530555f9a73d86564837a11d6e75236de5 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 25 May 2019 15:27:59 +0200 Subject: libinterimap: use socketpair(2) in tunnel mode. Rather than two pipe(2). Also, use SOCK_CLOEXEC to save a fcntl() call when setting the close-on-exec flag on the socket (even though Perl will likely call fcntl() anyway). --- lib/Net/IMAP/InterIMAP.pm | 60 +++++++++++++++++------------------------------ 1 file changed, 21 insertions(+), 39 deletions(-) (limited to 'lib/Net/IMAP') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 86f08a9..1dd54b7 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -23,11 +23,10 @@ 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 { @@ -304,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) { @@ -338,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; @@ -413,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}; @@ -526,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}; } @@ -677,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; } @@ -968,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 @@ -983,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; } @@ -1421,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! @@ -1436,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"); @@ -1704,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); @@ -1903,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 -- cgit v1.2.3