From a4729170cffc902319b08bae86e1ab6e20a7939d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 13 Sep 2015 13:37:50 +0200 Subject: Fix detection of boolean options. --- lib/Net/IMAP/InterIMAP.pm | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 65a0c10..678e09d 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -100,7 +100,7 @@ sub read_config($$%) { die "Invalid option $k\n" unless defined $opts{$k}; next unless defined $conf->{$k}; die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k}; - $conf->{$k} = $1; + $conf->{$k} = $opts{$k} ne qr/\A(YES|NO)\z/i ? $1 : uc $1 eq 'YES' ? 1 : 0; } } return \%configs; @@ -221,15 +221,6 @@ sub new($%) { my $self = { @_ }; bless $self, $class; - foreach (keys %$self) { - next unless defined $self->{$_}; - if (uc $self->{$_} eq 'YES') { - $self->{$_} = 1; - } elsif (uc $self->{$_} eq 'NO') { - $self->{$_} = 0; - } - } - # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' # (cf RFC 3501 section 3) $self->{_STATE} = ''; -- cgit v1.2.3 From 35ab0d8661b6808a9132bde20eefcf07f1486093 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sun, 13 Sep 2015 14:04:03 +0200 Subject: Replace IO::Socket::SSL dependency by the lower level Net::SSLeay. Also, * Rename the 'SSL_verify_trusted_peer', 'SSL_ca_path', and 'SSL_cipher_list' options to 'SSL_CApath', 'SSL_verify' and 'SSL_cipherlist', respectively. * Add an option 'SSL_CAfile' to specify a file containing trusted certificates to use during server certificate authentication. * Replace Compress::Zlib dependency by the lower level Compress::Raw::Zlib. --- lib/Net/IMAP/InterIMAP.pm | 224 ++++++++++++++++++++++++++++------------------ 1 file changed, 137 insertions(+), 87 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 678e09d..c26d102 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -20,16 +20,20 @@ package Net::IMAP::InterIMAP v0.0.2; use warnings; use strict; -use Compress::Zlib qw/Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; +use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); -use Errno 'EWOULDBLOCK'; use IO::Select (); +use Net::SSLeay (); use List::Util 'first'; use POSIX ':signal_h'; -use Socket 'SO_KEEPALIVE'; +use Socket qw/SO_KEEPALIVE SOL_SOCKET/; use Exporter 'import'; BEGIN { + Net::SSLeay::load_error_strings(); + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::randomize(); + our @EXPORT_OK = qw/read_config compact_set $IMAP_text $IMAP_cond/; } @@ -51,12 +55,16 @@ my %OPTIONS = ( command => qr/\A(\/\P{Control}+)\z/, 'null-stderr' => qr/\A(YES|NO)\z/i, compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, - SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, - SSL_cipher_list => qr/\A(\P{Control}+)\z/, - SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, - SSL_ca_path => qr/\A(\P{Control}+)\z/, + SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/, + SSL_cipherlist => qr/\A(\P{Control}+)\z/, + SSL_verify => qr/\A(YES|NO)\z/i, + SSL_CApath => qr/\A(\P{Control}+)\z/, + SSL_CAfile => qr/\A(\P{Control}+)\z/, ); +# Use the same buffer size as Net::SSLeay::read(), to ensure there is +# never any pending data left in the current TLS record +my $BUFSIZE = 32768; ############################################################################# # Utilities @@ -228,7 +236,7 @@ sub new($%) { # in/out buffer counts and output stream $self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0; $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0; - $self->{_OUTBUF} = ''; + $self->{_OUTBUF} = undef; if ($self->{type} eq 'tunnel') { my $command = $self->{command} // $self->fail("Missing tunnel command"); @@ -277,12 +285,10 @@ sub new($%) { $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: $!"); $self->_start_ssl($socket) if $self->{type} eq 'imaps'; - - $socket->sockopt(SO_KEEPALIVE, 1); $self->{$_} = $socket for qw/STDOUT STDIN/; } - $self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!"); binmode $self->{$_} foreach qw/STDIN STDOUT/; # command counter @@ -396,10 +402,10 @@ sub new($%) { $self->panic($IMAP_text) unless $r eq 'OK'; if ($algo eq 'DEFLATE') { - my %args = ( -WindowBits => 0 - MAX_WBITS ); - $self->{_Z_DEFLATE} = Compress::Zlib::deflateInit(%args) // + my %args = ( -WindowBits => 0 - MAX_WBITS, -Bufsize => $BUFSIZE ); + $self->{_Z_DEFLATE} = Compress::Raw::Zlib::Deflate::->new(%args, -AppendOutput => 1) // $self->panic("Can't create deflation stream"); - $self->{_Z_INFLATE} = Compress::Zlib::inflateInit(%args) // + $self->{_Z_INFLATE} = Compress::Raw::Zlib::Inflate::->new(%args) // $self->panic("Can't create inflation stream"); } else { @@ -445,6 +451,9 @@ sub DESTROY($) { my $self = shift; $self->{_STATE} = 'LOGOUT'; + Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL}; + Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX}; + foreach (qw/STDIN STDOUT/) { $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); } @@ -871,18 +880,17 @@ sub notify($@) { sub slurp($) { my $self = shift; - my $stdout = $self->{STDOUT}; + my $ssl = $self->{_SSL}; my $read = 0; while (1) { - # Unprocessed data within the current SSL frame would cause + # Unprocessed data within the current TLS record would cause # select(2) to block/timeout due to the raw socket not being # ready. - unless (ref $stdout eq 'IO::Socket::SSL' and $stdout->pending() > 0) { + unless (defined $ssl and Net::SSLeay::pending($ssl) > 0) { my ($ok) = $self->{_SEL_OUT}->can_read(0); return $read unless defined $ok; } - $self->_resp( $self->_getline() ); $read++; } @@ -1180,52 +1188,80 @@ sub push_flag_updates($$@) { ############################################################################# # Private methods +# $self->_ssl_error($error, [...]) +# Log an SSL $error and exit with return value 1. +sub _ssl_error($$) { + my $self = shift; + $self->log('SSL ERROR: ', @_); + if ($self->{debug}) { + while (my $err = Net::SSLeay::ERR_get_error()) { + $self->log(Net::SSLeay::ERR_error_string($err)); + } + } + exit 1; +} + # $self->_start_ssl($socket) -# Upgrade the $socket to IO::Socket::SSL. +# Upgrade the $socket to SSL/TLS. sub _start_ssl($$) { my ($self, $socket) = @_; - require 'IO/Socket/SSL.pm'; - require 'Net/SSLeay.pm'; - - my %sslargs = (SSL_create_ctx_callback => sub($) { - my $ctx = shift; - my $rv; - - # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html - $rv = Net::SSLeay::CTX_get_options($ctx) - | Net::SSLeay::OP_SINGLE_ECDH_USE() - | Net::SSLeay::OP_SINGLE_DH_USE() - | Net::SSLeay::OP_NO_SSLv2() - | Net::SSLeay::OP_NO_SSLv3() - | Net::SSLeay::OP_NO_COMPRESSION(); - Net::SSLeay::CTX_set_options($ctx, $rv); - - # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html - $rv = Net::SSLeay::CTX_get_mode($ctx) - | Net::SSLeay::MODE_AUTO_RETRY() # don't fail SSL_read on renegociation - | Net::SSLeay::MODE_RELEASE_BUFFERS(); - Net::SSLeay::CTX_set_mode($ctx, $rv); - }); - - my $fpr = delete $self->{SSL_fingerprint}; - my $vrfy = delete $self->{SSL_verify_trusted_peer}; - $sslargs{SSL_verify_mode} = ($vrfy // 1) ? Net::SSLeay::VERIFY_PEER() : Net::SSLeay::VERIFY_NONE(); - $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; - - IO::Socket::SSL->start_SSL($socket, %sslargs) - or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); - - # ensure we're talking to the right server - if (defined $fpr) { - my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; - my $fpr2 = $socket->get_fingerprint($algo); - $fpr =~ s/.*\$//; - $fpr2 =~ s/.*\$//; - $self->fail("Fingerprint don't match! MiTM in action?") - unless uc $fpr eq uc $fpr2; + my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!"); + + # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html + Net::SSLeay::CTX_set_options($ctx, + Net::SSLeay::OP_SINGLE_ECDH_USE() | + Net::SSLeay::OP_SINGLE_DH_USE() | + Net::SSLeay::OP_NO_SSLv2() | + Net::SSLeay::OP_NO_SSLv3() | + Net::SSLeay::OP_NO_COMPRESSION() ); + + # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html + Net::SSLeay::CTX_set_mode($ctx, + Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() | + Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() | + Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegociation + Net::SSLeay::MODE_RELEASE_BUFFERS() ); + + if (defined (my $ciphers = $self->{SSL_cipherlist})) { + Net::SSLeay::CTX_set_cipher_list($ctx, $ciphers) + or $self->_ssl_error("Can't set cipher list"); + } + + if ($self->{SSL_verify} // 1) { + # verify the certificate chain + my ($file, $path) = ($self->{SSL_CAfile} // '', $self->{SSL_CApath} // ''); + if ($file ne '' or $path ne '') { + Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path) + or $self->_ssl_error("Can't load verify locations"); + } + Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER()); + } + else { + Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_NONE()); } + 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"); + $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1; + + if (defined (my $fpr = $self->{SSL_fingerprint})) { + # ensure we're talking to the right server + (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr); + my $digest = pack 'H*', ($fpr =~ tr/://rd); + + my $type = Net::SSLeay::EVP_get_digestbyname($algo) + or $self->_ssl_error("Can't find MD value for name '$algo'"); + + my $cert = Net::SSLeay::get_peer_certificate($ssl) + or $self->_ssl_error("Can't get peer certificate"); + + $self->fail("Fingerprint doesn't match! MiTM in action?") + if Net::SSLeay::X509_digest($cert, $type) ne $digest and + Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest; + } + + @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx); } @@ -1239,24 +1275,31 @@ sub _getline($;$) { my $self = shift; my $len = shift // 0; - my $stdout = $self->{STDOUT}; + my ($stdout, $ssl) = @$self{qw/STDOUT _SSL/}; $self->fail("Lost connection") unless $stdout->opened(); my (@lit, @line); while(1) { - if ($self->{_OUTBUF} eq '') { + unless (defined $self->{_OUTBUF}) { + my ($buf, $n); # nothing cached: read some more - # (read at most 2^14 bytes, the maximum length of an SSL - # frame, to ensure to guaranty that there is no pending data) - my $n = $stdout->sysread(my $buf,16384,0); + if (defined $ssl) { + ($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE); + } else { + $n = $stdout->sysread($buf, $BUFSIZE, 0); + } + $self->panic("Can't read: $!") unless defined $n; $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { - $buf = $i->inflate($buf) // $self->panic("Inflation failed: ", $i->msg()); + $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or + $self->panic("Inflation failed: ", $i->msg()); + } + else { + $self->{_OUTBUF} = $buf; } - $self->{_OUTBUF} = $buf; } if ($len == 0) { # read a regular line: stop after the first \r\n if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) { @@ -1273,20 +1316,19 @@ sub _getline($;$) { } else { push @line, $self->{_OUTBUF}; - $self->{_OUTBUF} = ''; + undef $self->{_OUTBUF}; } } elsif ($len > 0) { # $len bytes of literal bytes to read - if ($len <= length($self->{_OUTBUF})) { + if ($len < length($self->{_OUTBUF})) { push @lit, substr($self->{_OUTBUF}, 0, $len, ''); $len = 0; } else { push @lit, $self->{_OUTBUF}; $len -= length($self->{_OUTBUF}); - $self->{_OUTBUF} = ''; + undef $self->{_OUTBUF}; } - next; } } } @@ -1314,7 +1356,7 @@ sub _update_cache_for($$%) { if ($k eq 'UIDVALIDITY') { # try to detect UIDVALIDITY changes early (before starting the sync) $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ", - "Need to invalidate the UID cache.") + "Need to invalidate the UID cache.") if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v; } @@ -1327,12 +1369,18 @@ sub _update_cache_for($$%) { # Send the given @data to the IMAP server. # Update the interal raw byte count, but the regular byte count must # have been updated earlier (eg, by _send_cmd). -sub _write($@) { - my $self = shift; - foreach (@_) { - next if $_ eq ''; - $self->{STDIN}->write($_) // $self->panic("Can't write: $!"); - $self->{_INRAWCOUNT} += length($_); +sub _write($$) { + my ($self, $data) = @_; + my ($stdin, $ssl) = @$self{qw/STDIN _SSL/}; + + my ($offset, $length) = (0, length($$data)); + while ($length > 0) { + my $written = defined $ssl ? + Net::SSLeay::write_partial($ssl, $offset, $length, $$data) : + $stdin->syswrite($$data, $length, $offset); + $offset += $written; + $length -= $written; + $self->{_INRAWCOUNT} += $written; } } @@ -1340,10 +1388,11 @@ sub _write($@) { # $self->_z_flush([$type]) # Flush the deflation stream, and write the compressed data. # This method is a noop if no compression layer is active. -sub _z_flush($;$) { - my ($self,$t) = @_; - my $d = $self->{_Z_DEFLATE} // return; - $self->_write( $d->flush($t) // $self->panic("Can't flush deflation stream: ", $d->msg()) ); +sub _z_flush($$;$) { + my ($self, $buf, $t) = @_; + my $d = $self->{_Z_DEFLATE}; + $d->flush($buf, $t) == Z_OK or + $self->panic("Can't flush deflation stream: ", $d->msg()); } @@ -1361,6 +1410,7 @@ sub _send_cmd($) { my ($offset, $litlen) = (0, 0); my $z_flush = 0; # whether to flush the dictionary after processing the next literal + my $buf; while(1) { my $lit = substr($command, $offset, $litlen) if $litlen > 0; $offset += $litlen; @@ -1383,20 +1433,21 @@ sub _send_cmd($) { my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n"); $self->{_INCOUNT} += length($_) foreach @data; if (!defined $d) { - $self->_write(@data); + $buf .= join '', @data; } else { for (my $i = 0; $i <= $#data; $i++) { - $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush; - $self->_write( $d->deflate($data[$i]) // $self->panic("Deflation failed: ", $d->msg()) ); - $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush; + $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush; + $d->deflate($data[$i], \$buf) == Z_OK or $self->panic("Deflation failed: ", $d->msg()); + $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush; } } if (!$litplus or $idx < 0) { - $self->_z_flush(Z_SYNC_FLUSH) if defined $d; + $self->_z_flush(\$buf, Z_SYNC_FLUSH) if defined $d; + $self->_write(\$buf); + undef $buf; - $self->{STDIN}->flush() // $self->panic("Can't flush: $!"); last if $idx < 0; my $x = $self->_getline(); $x =~ /\A\+ / or $self->panic($x); @@ -1851,7 +1902,6 @@ sub _resp($$;$$$) { $x .= "\r\n"; $self->{_INCOUNT} += length($x); $self->_write($x); - $self->{STDIN}->flush() // $self->panic("Can't flush: $!"); } } else { -- cgit v1.2.3 From d586881f81e74f7c22a2d11094f38634933a558a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 14 Sep 2015 01:20:53 +0200 Subject: Pass literals by reference to save memory. --- lib/Net/IMAP/InterIMAP.pm | 313 +++++++++++++++++++++++++++++----------------- 1 file changed, 196 insertions(+), 117 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index c26d102..5cd0061 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -65,6 +65,7 @@ my %OPTIONS = ( # Use the same buffer size as Net::SSLeay::read(), to ensure there is # never any pending data left in the current TLS record my $BUFSIZE = 32768; +my $CRLF = "\x0D\x0A"; ############################################################################# # Utilities @@ -187,7 +188,9 @@ sub quote($) { return "\"$str\""; } else { - return "{".length($str)."}\r\n".$str; + # we'll later replace the non-synchronizing literal with a + # synchronizing one if need be + return "{".length($str)."+}$CRLF".$str; } } @@ -236,7 +239,8 @@ sub new($%) { # in/out buffer counts and output stream $self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0; $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0; - $self->{_OUTBUF} = undef; + $self->{_OUTBUF} = $self->{_INBUF} = undef; + $self->{_LITPLUS} = ''; if ($self->{type} eq 'tunnel') { my $command = $self->{command} // $self->fail("Missing tunnel command"); @@ -286,6 +290,7 @@ sub new($%) { 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: $!"); + $self->_start_ssl($socket) if $self->{type} eq 'imaps'; $self->{$_} = $socket for qw/STDOUT STDIN/; } @@ -776,21 +781,8 @@ sub append($$@) { return unless @_; $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); - - my @appends; - foreach my $mail (@_) { - my $append = ''; - $append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' - if defined $mail->{FLAGS}; - $append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; - my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, '') - : defined $mail->{BINARY} ? ($mail->{BINARY}, '~') - : $self->panic("Missing message body in APPEND"); - $append .= "$t\{".length($body)."\}\r\n".$body; - push @appends, $append; - } $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.") - unless $#appends == 0 or $self->_capable('MULTIAPPEND'); + unless $#_ == 0 or $self->_capable('MULTIAPPEND'); # dump the cache before issuing the command if we're appending to the current mailbox my ($UIDNEXT, $EXISTS, $cache, %vanished); @@ -801,7 +793,21 @@ sub append($$@) { %vanished = map {$_ => 1} @{$self->{_VANISHED}}; } - $self->_send('APPEND '.quote($mailbox).' '.join(' ',@appends)); + my $tag = $self->_cmd_init('APPEND '.quote($mailbox)); + foreach my $mail (@_) { + my $str = ' '; + $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS}; + $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; + my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, 0) + : defined $mail->{BINARY} ? ($mail->{BINARY}, 1) + : $self->panic("Missing message body in APPEND"); + $self->_cmd_extend(\$str); + $self->_cmd_extend_lit($body, $t); + } + + $self->_cmd_flush(); + $self->_recv($tag); + $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text); my ($uidvalidity, $uidset) = ($1, $2); $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity); @@ -819,9 +825,8 @@ sub append($$@) { $self->panic($_); } } - $self->fail("$uidset contains ".scalar(@uids)." elements while " - .scalar(@appends)." messages were appended.") - unless $#uids == $#appends; + $self->fail("$uidset contains ".scalar(@uids)." elements while ".($#_+1)." messages were appended.") + unless $#uids == $#_; # if $mailbox is the current mailbox we need to update the cache if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { @@ -829,12 +834,16 @@ sub append($$@) { my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}}; delete $vanished2{$_} foreach keys %vanished; my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile - $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; + $cache->{EXISTS} += $#_+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT; } - $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) - unless $self->{quiet}; + unless ($self->{quiet}) { + my $msg = "Added ".($#_+1)." message(s)"; + $msg .= " to $mailbox" unless defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}; + $msg .= ", got new UID ".compact_set(@uids); + $self->log($msg); + } return @uids; } @@ -1190,8 +1199,9 @@ sub push_flag_updates($$@) { # $self->_ssl_error($error, [...]) # Log an SSL $error and exit with return value 1. -sub _ssl_error($$) { +sub _ssl_error($$@) { my $self = shift; + $self->fail(@_) unless defined $self->{_SSL}; $self->log('SSL ERROR: ', @_); if ($self->{debug}) { while (my $err = Net::SSLeay::ERR_get_error()) { @@ -1289,8 +1299,8 @@ sub _getline($;$) { $n = $stdout->sysread($buf, $BUFSIZE, 0); } - $self->panic("Can't read: $!") unless defined $n; - $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF + $self->_ssl_error("Can't read: $!") unless defined $n; + $self->_ssl_error("0 bytes read (got EOF)") unless $n > 0; # EOF $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { @@ -1309,10 +1319,10 @@ sub _getline($;$) { $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx); $self->{_OUTCOUNT} += length($lit) + length($line); - $line =~ s/\r\n\z// or $self->panic($line); + $line =~ s/$CRLF\z// or $self->panic($line); $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug}; - return (wantarray ? ($lit, $line) : $line); + return (wantarray ? (\$lit, $line) : $line); } else { push @line, $self->{_OUTBUF}; @@ -1365,96 +1375,150 @@ sub _update_cache_for($$%) { } -# $self->_write(@data) -# Send the given @data to the IMAP server. -# Update the interal raw byte count, but the regular byte count must -# have been updated earlier (eg, by _send_cmd). -sub _write($$) { - my ($self, $data) = @_; - my ($stdin, $ssl) = @$self{qw/STDIN _SSL/}; - - my ($offset, $length) = (0, length($$data)); - while ($length > 0) { - my $written = defined $ssl ? - Net::SSLeay::write_partial($ssl, $offset, $length, $$data) : - $stdin->syswrite($$data, $length, $offset); - $offset += $written; - $length -= $written; - $self->{_INRAWCOUNT} += $written; - } +# $self->_cmd_init($command) +# Generate a new tag for the given $command, push both the +# concatenation to the command buffer. $command can be a scalar or a +# scalar reference. +# Use the _cmd_extend and/or _cmd_extend_lit methods to extend the +# command, and _cmd_flush to send it to the server. +sub _cmd_init($$) { + my $self = shift; + my $tag = sprintf '%06d', $self->{_TAG}++; + my $command = (defined $self->{_INBUF} ? $CRLF : '').$tag.' '.(ref $_[0] ? ${$_[0]} : $_[0]); + $self->_cmd_extend(\$command); + return $tag; } -# $self->_z_flush([$type]) -# Flush the deflation stream, and write the compressed data. -# This method is a noop if no compression layer is active. -sub _z_flush($$;$) { - my ($self, $buf, $t) = @_; - my $d = $self->{_Z_DEFLATE}; - $d->flush($buf, $t) == Z_OK or - $self->panic("Can't flush deflation stream: ", $d->msg()); +# $self->_cmd_extend($args) +# Append $args to the command buffer. $args can be a scalar or a +# scalar reference. If $args contains some literal(s) and the server +# doesn't support LITERAL+, flush the command and wait for an answer +# before each literal +sub _cmd_extend($$) { + my $self = shift; + my $args = ref $_[0] ? $_[0] : \$_[0]; + + if ($self->{_LITPLUS} ne '') { + # server supports LITERAL+: use $args as is + $self->_cmd_extend_($args); + } + else { + # server supports LITERAL+: flush the command before each + # literal + my ($offset, $litlen) = (0, 0); + while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) { + my $line = substr($$args, $offset, $idx+1-$offset); + $line =~ s/\{([0-9]+)\+\}$CRLF\z/{$1}$CRLF/ or $self->panic(); + $litlen = $1; + $self->_cmd_flush(\$line); + + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + $offset = $idx+1; + } + my $line = substr($$args, $offset); + $self->_cmd_extend_(\$line); + } } -# $self->_send_cmd($tag, $command) -# Send the given $command to the IMAP server. -# If $command contains literals and the server supportes LITERAL+, -# non-synchronizing literals are sent instead. -# If a compression layer is active, $command is compressed before -# being send. -sub _send_cmd($) { - my ($self, $tag, $command) = @_; - my $litplus = $self->_capable('LITERAL+') ? 1 : 0; +# $self->_cmd_extend_lit($lit, [$lit8]) +# Append the literal $lit to the command buffer. $lit must be a +# scalar reference. If $lit8 is true, a literal8 is sent instead [RFC +# 3516]. +sub _cmd_extend_lit($$;$) { + my ($self, $lit, $lit8) = @_; + my $len = length($$lit); my $d = $self->{_Z_DEFLATE}; - my ($offset, $litlen) = (0, 0); - my $z_flush = 0; # whether to flush the dictionary after processing the next literal + # create a full flush point for long binary literals + my $z_flush = ($len > 4096 and !($self->{'use-binary'} // 1 and !$lit8)) ? 1 : 0; + $lit8 = $lit8 ? '~' : ''; # literal8, RFC 3516 BINARY - my $buf; - while(1) { - my $lit = substr($command, $offset, $litlen) if $litlen > 0; - $offset += $litlen; + my $strlen = $lit8.'{'.$len.$self->{_LITPLUS}.'}'.$CRLF; - my ($line, $z_flush2); - my $idx = index($command, "\n", $offset); - if ($idx < 0) { - $line = substr($command, $offset); + if ($self->{_LITPLUS} ne '') { + $self->_cmd_extend_(\$strlen); + if ($z_flush and defined $d) { + $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK + or $self->panic("Can't flush deflation stream: ", $d->msg()); } - else { - $line = substr($command, $offset, $idx-1-$offset); - $litlen = $litplus ? ($line =~ s/\{([0-9]+)\}\z/{$1+}/ ? $1 : $self->panic()) - : ($line =~ /\{([0-9]+)\}\z/ ? $1 : $self->panic()); - $z_flush2 = ($litlen > 4096 and # large literal - ($self->{'use-binary'} // 1 or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY - ) ? 1 : 0; - } - $self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug}; + } + else { + # server doesn't supports LITERAL+ + $self->_cmd_flush(\$strlen, ($z_flush ? Z_FULL_FLUSH : ())); + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + } - my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n"); - $self->{_INCOUNT} += length($_) foreach @data; - if (!defined $d) { - $buf .= join '', @data; - } - else { - for (my $i = 0; $i <= $#data; $i++) { - $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush; - $d->deflate($data[$i], \$buf) == Z_OK or $self->panic("Deflation failed: ", $d->msg()); - $self->_z_flush(\$buf, Z_FULL_FLUSH) if $i == 0 and $z_flush; - } - } + $self->_cmd_extend_($lit); + if ($z_flush and defined $d) { + $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK + or $self->panic("Can't flush deflation stream: ", $d->msg()); + } +} - if (!$litplus or $idx < 0) { - $self->_z_flush(\$buf, Z_SYNC_FLUSH) if defined $d; - $self->_write(\$buf); - undef $buf; - last if $idx < 0; - my $x = $self->_getline(); - $x =~ /\A\+ / or $self->panic($x); +# $self->_cmd_flush([$crlf], [$z_flush]) +# Append $crlf (default: $CRLF) to the command buffer, flush the +# deflation stream by creating a flush point of type $z_flush +# (default: Z_SYNC_FLUSH) if there is a compression layer, and finally +# send the command to the server. +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/}; + + if ($self->{debug}) { + # remove $CRLF and literals + my ($offset, $litlen) = (0, $self->{_INBUFDBGLEN} // 0); + while ( (my $idx = index($self->{_INBUFDBG}, "\n", $offset+$litlen)) >= 0) { + my $line = substr($self->{_INBUFDBG}, $offset+$litlen, $idx+1-$offset-$litlen); + $line =~ s/$CRLF\z// or $self->panic(); + $self->logger('C: ', ($litlen > 0) ? '[...]' : '', $line); + $litlen = $line =~ /\{([0-9]+)(\+)?\}\z/ ? $1 : 0; + $offset = $idx+1; } + $self->panic() if $offset+$litlen < length($self->{_INBUFDBG}); + undef $self->{_INBUFDBG}; + $self->{_INBUFDBGLEN} = $litlen; + } + + if (defined (my $d = $self->{_Z_DEFLATE})) { + $d->flush(\$self->{_INBUF}, $z_flush) == Z_OK + or $self->panic("Can't flush deflation stream: ", $d->msg()); + } + + my ($offset, $length) = (0, length($self->{_INBUF})); + while ($length > 0) { + my $written = defined $ssl ? + Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) : + $stdin->syswrite($self->{_INBUF}, $length, $offset); + $self->_ssl_error("Can't write: $!") unless defined $written and $written > 0; + + $offset += $written; + $length -= $written; + $self->{_INRAWCOUNT} += $written; + } + undef $self->{_INBUF}; +} + - $z_flush = $z_flush2; - $offset = $idx+1; +# $self->_cmd_extend_($args) +# Append the scalar reference $args to the command buffer. Usually +# one should use the higher-level method _cmd_extend as it takes care +# of literals if the server doesn't support LITERAL+. +sub _cmd_extend_($$) { + my ($self, $args) = @_; + $self->{_INCOUNT} += length($$args); # count IMAP traffic + $self->{_INBUFDBG} .= $$args if $self->{debug}; + if (defined (my $d = $self->{_Z_DEFLATE})) { + $d->deflate($args, \$self->{_INBUF}) == Z_OK or $self->panic("Deflation failed: ", $d->msg()); + } + else { + $self->{_INBUF} .= $$args; } } @@ -1469,15 +1533,31 @@ sub _send_cmd($) { # In void context, croak unless the server answers with a tagged 'OK' # response. Otherwise, return the condition status ('OK'/'NO'/'BAD'). sub _send($$;&) { - my ($self, $command, $callback) = @_; - my $cmd = $command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $command; - my $set = $command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef; + my $self = shift; + my $command = \$_[0]; + my $callback = $_[1]; - # send the command; for servers supporting non-synchronizing - # literals, mark literals as such and then the whole command in one - # go, otherwise send literals one at a time - my $tag = sprintf '%06d', $self->{_TAG}++; - $self->_send_cmd($tag, $command); + my $tag = $self->_cmd_init($command); + $self->_cmd_flush(); + + if (!defined $callback) { + $self->_recv($tag); + } + else { + my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command; + my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : undef; + $self->_recv($tag, $callback, $cmd, $set); + } +} + + +# $self->_recv($tag, [$callback, $command, $set]) +# Wait for a tagged response with the given $tag. The $callback, if +# provided, is used to process each untagged response. $command and +# $set can further limit the set of responses to apply the callback +# to. +sub _recv($$;$&$) { + my ($self, $tag, $callback, $cmd, $set) = @_; my $r; # wait for the answer @@ -1630,6 +1710,7 @@ sub _resp_text($$) { } elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) { $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; + $self->{_LITPLUS} = (grep { uc $_ eq 'LITERAL+' } @{$self->{_CAPABILITIES}}) ? '+' : ''; } elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) { $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] ); @@ -1690,7 +1771,7 @@ sub _string($$) { elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) { # literal (my $lit, $$stream) = $self->_getline($1); - return $lit; + return $$lit; } else { $self->panic($$stream); @@ -1844,14 +1925,14 @@ sub _resp($$;$$$) { $mail{INTERNALDATE} = $1; } elsif (s/\A(?:RFC822|BODY\[\]) //) { - $mail{RFC822} = $self->_nstring(\$_); + $mail{RFC822} = \$self->_nstring(\$_); } elsif (s/\ABINARY\[\] //) { if (s/\A~\{([0-9]+)\}\z//) { # literal8, RFC 3516 BINARY (my $lit, $_) = $self->_getline($1); $mail{BINARY} = $lit; } else { - $mail{RFC822} = $self->_nstring(\$_); + $mail{RFC822} = \$self->_nstring(\$_); } } elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { @@ -1898,10 +1979,8 @@ sub _resp($$;$$$) { elsif (s/\A\+ //) { if (defined $callback and $cmd eq 'AUTHENTICATE') { my $x = $callback->($_); - $self->logger("C: ", $x) if $self->{debug}; - $x .= "\r\n"; - $self->{_INCOUNT} += length($x); - $self->_write($x); + $self->_cmd_extend(\$x); + $self->_cmd_flush(); } } else { -- cgit v1.2.3 From c8fb54897f046a5a3fb4c1d45dc21fd8bcd882e3 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 14 Sep 2015 02:23:22 +0200 Subject: Accept non-fully qualified commands. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 5cd0061..57f002e 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -52,7 +52,7 @@ my %OPTIONS = ( username => qr/\A([\x01-\x7F]+)\z/, password => qr/\A([\x01-\x7F]+)\z/, auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, - command => qr/\A(\/\P{Control}+)\z/, + command => qr/\A(\P{Control}+)\z/, 'null-stderr' => qr/\A(YES|NO)\z/i, compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/, -- cgit v1.2.3