diff options
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 79 |
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'; |