aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/InterIMAP.pm
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-09-14 21:11:56 +0200
committerGuilhem Moulin <guilhem@fripost.org>2015-09-15 01:35:12 +0200
commitcc842e127d380255524ee8ccf465d63596b2a870 (patch)
tree14d0ef044e2f8a25d2fb495151c6038b11caefef /lib/Net/IMAP/InterIMAP.pm
parent52121383f898700c9dbfccc6121d40185e207330 (diff)
Replace IO::Socket::INET dependency by the lower lever Socket to enable IPv6.
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm70
1 files changed, 57 insertions, 13 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 57f002e..0762b3b 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -26,7 +26,7 @@ use IO::Select ();
use Net::SSLeay ();
use List::Util 'first';
use POSIX ':signal_h';
-use Socket qw/SO_KEEPALIVE SOL_SOCKET/;
+use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP/;
use Exporter 'import';
BEGIN {
@@ -45,8 +45,8 @@ my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
# Map each option to a regexp validating its values.
my %OPTIONS = (
- host => qr/\A([0-9a-zA-Z:.-]+)\z/,
- port => qr/\A([0-9]+)\z/,
+ host => qr/\A(\P{Control}+)\z/,
+ port => qr/\A(\P{Control}+)\z/,
type => qr/\A(imaps?|tunnel)\z/,
STARTTLS => qr/\A(YES|NO)\z/i,
username => qr/\A([\x01-\x7F]+)\z/,
@@ -283,13 +283,11 @@ 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 = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@");
- $socket->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
+ foreach (qw/host port/) {
+ $self->fail("Missing option $_") unless defined $self->{$_};
+ }
+ my $socket = $self->_tcp_connect(@$self{qw/host port/});
+ setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
$self->_start_ssl($socket) if $self->{type} eq 'imaps';
$self->{$_} = $socket for qw/STDOUT STDIN/;
@@ -459,6 +457,7 @@ 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();
}
@@ -1212,6 +1211,51 @@ sub _ssl_error($$@) {
}
+# RFC 3986 appendix A
+my $RE_IPv4 = do {
+ my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/;
+ qr/$dec(?:\.$dec){3}/o };
+my $RE_IPv6 = do {
+ my $h16 = qr/[0-9A-Fa-f]{1,4}/;
+ my $ls32 = qr/$h16:$h16|$RE_IPv4/o;
+ qr/ (?: $h16 : ){6} $ls32
+ | :: (?: $h16 : ){5} $ls32
+ | (?: $h16 )? :: (?: $h16 : ){4} $ls32
+ | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
+ | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
+ | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
+ | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
+ | (?: (?: $h16 : ){0,5} $h16 )? :: $h16
+ | (?: (?: $h16 : ){0,6} $h16 )? ::
+ /xo };
+
+
+# Opens a TCP socket to the given $host and $port.
+sub _tcp_connect($$$) {
+ my ($self, $host, $port) = @_;
+
+ my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP);
+ if ($host =~ qr/\A$RE_IPv4\z/o) {
+ $hints{family} = AF_INET;
+ $hints{flags} |= AI_NUMERICHOST;
+ }
+ elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) {
+ $host = $1;
+ $hints{family} = AF_INET6;
+ $hints{flags} |= AI_NUMERICHOST;
+ }
+
+ my ($err, @res) = Socket::getaddrinfo($host, $port, \%hints);
+ $self->fail("Can't getaddrinfo: $err") if $err ne '';
+
+ foreach my $ai (@res) {
+ socket my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol};
+ return $s if defined $s and connect($s, $ai->{addr});
+ }
+ $self->fail("Can't connect to $host:$port");
+}
+
+
# $self->_start_ssl($socket)
# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
@@ -1252,7 +1296,7 @@ sub _start_ssl($$) {
}
my $ssl = Net::SSLeay::new($ctx) or $self->fail("Can't create new SSL structure");
- Net::SSLeay::set_fd($ssl, $socket->fileno()) or $self->fail("SSL filehandle association failed");
+ Net::SSLeay::set_fd($ssl, fileno $socket) or $self->fail("SSL filehandle association failed");
$self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
if (defined (my $fpr = $self->{SSL_fingerprint})) {
@@ -1296,7 +1340,7 @@ sub _getline($;$) {
if (defined $ssl) {
($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE);
} else {
- $n = $stdout->sysread($buf, $BUFSIZE, 0);
+ $n = sysread($stdout, $buf, $BUFSIZE, 0);
}
$self->_ssl_error("Can't read: $!") unless defined $n;
@@ -1495,7 +1539,7 @@ sub _cmd_flush($;$$) {
while ($length > 0) {
my $written = defined $ssl ?
Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) :
- $stdin->syswrite($self->{_INBUF}, $length, $offset);
+ syswrite($stdin, $self->{_INBUF}, $length, $offset);
$self->_ssl_error("Can't write: $!") unless defined $written and $written > 0;
$offset += $written;