aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm79
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';
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-29 08:02:53 +0000