From ae69332edcf916e0e2af806e4969ef6402040816 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 9 Sep 2015 21:37:35 +0200 Subject: Refactoring. --- INSTALL | 2 +- lib/Net/IMAP/InterIMAP.pm | 169 +++++++++++++++++++++++----------------------- 2 files changed, 84 insertions(+), 87 deletions(-) diff --git a/INSTALL b/INSTALL index b3f9ebc..f27952b 100644 --- a/INSTALL +++ b/INSTALL @@ -1,6 +1,6 @@ InterIMAP depends on the following Perl modules: - - Compress::Raw::Zlib (core module) + - Compress::Zlib (core module) - Config::Tiny - DBI - DBD::SQLite diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 2821f98..6012049 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -20,7 +20,7 @@ package Net::IMAP::InterIMAP v0.0.1; use warnings; use strict; -use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; +use Compress::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); use Errno 'EWOULDBLOCK'; use IO::Select (); @@ -427,11 +427,11 @@ sub new($%) { if ($algo eq 'DEFLATE') { my ($status, $d, $i); my %args = ( -WindowBits => 0 - MAX_WBITS ); - ($d, $status) = Compress::Raw::Zlib::Deflate::->new(%args); + ($d, $status) = Compress::Zlib::deflateInit(%args); $self->panic("Can't create deflation stream: ", $d->msg()) unless defined $d and $status == Z_OK; - ($i, $status) = Compress::Raw::Zlib::Inflate::->new(%args); + ($i, $status) = Compress::Zlib::inflateInit(%args); $self->panic("Can't create inflation stream: ", $i->msg()) unless defined $i and $status == Z_OK; @$self{qw/_Z_DEFLATE _Z_INFLATE/} = ($d, $i); @@ -1254,9 +1254,9 @@ sub _getline($;$) { $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { - my $status = $i->inflate($buf, my $data); + my ($out, $status) = $i->inflate($buf); $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK; - $buf = $data; + $buf = $out; } $self->{_OUTBUF} = $buf; } @@ -1326,52 +1326,94 @@ sub _update_cache_for($$%) { # $self->_write(@data) -# Send the given @data to the IMAP server and flush the buffer. If a -# compression layer is active, flush the deflation stream first. +# Send the given @data to the IMAP server. # Update the interal raw byte count, but the regular byte count must -# have been updated earlier. +# have been updated earlier (eg, by _send_cmd). sub _write($@) { my $self = shift; - my @data = @_; - - if (defined (my $d = $self->{_Z_DEFLATE})) { - my $status = $d->flush(my $buf, Z_SYNC_FLUSH); - $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK; - push @data, $buf if $buf ne ''; + foreach (@_) { + next if $_ eq ''; + $self->{STDIN}->write($_) // $self->panic("Can't write: $!"); + $self->{_INRAWCOUNT} += length($_); } - - my $data = join '', @data; - $self->{STDIN}->write($data) // $self->panic("Can't write: $!"); - $self->{STDIN}->flush() // $self->panic("Can't flush: $!"); - $self->{_INRAWCOUNT} += length($data); -} - - -# $self->_z_deflate(@data) -# Add the given @data to the deflation stream, and return the -# compressed data. -# This method is a noop if no compression layer is active. -sub _z_deflate($@) { - my $self = shift; - my $data = join '', @_; - $self->{_INCOUNT} += length($data); - my $d = $self->{_Z_DEFLATE} // return @_; - - my $status = $d->deflate($data, my $buf); - $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK; - return ($buf) if $buf ne ''; } # $self->_z_flush([$type]) -# Flush the deflation stream, and return the compressed data. +# 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 = shift; + my ($self,$t) = @_; my $d = $self->{_Z_DEFLATE} // return; - my $status = $d->flush(my $buf, @_); + my ($out, $status) = $d->flush($t); $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK; - return ($buf) if $buf ne ''; + $self->_write($out); +} + + +# $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; + my $d = $self->{_Z_DEFLATE}; + + my ($offset, $litlen) = (0, 0); + my $z_flush = 0; # whether to flush the dictionary after processing the next literal + + while(1) { + my $lit = substr($command, $offset, $litlen) if $litlen > 0; + $offset += $litlen; + + my ($line, $z_flush2); + my $idx = index($command, "\n", $offset); + if ($idx < 0) { + $line = substr($command, $offset); + } + 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 + (uc ($self->{'use-binary'} // 'YES') eq 'NO' + or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY + ) ? 1 : 0; + } + $self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug}; + + my @data = (($offset == 0 ? "$tag " : $lit), $line, "\r\n"); + $self->{_INCOUNT} += length($_) foreach @data; + if (!defined $d) { + $self->_write(@data); + } + else { + for (my $i = 0; $i <= $#data; $i++) { + $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush; + + my ($out, $status) = $d->deflate($data[$i]); + $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK; + $self->_write($out); + + $self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush; + } + } + + if (!$litplus or $idx < 0) { + $self->_z_flush(Z_SYNC_FLUSH) if defined $d; + + $self->{STDIN}->flush() // $self->panic("Can't flush: $!"); + last if $idx < 0; + my $x = $self->_getline(); + $x =~ /\A\+ / or $self->panic($x); + } + + $z_flush = $z_flush2; + $offset = $idx+1; + } } @@ -1393,53 +1435,7 @@ sub _send($$;&) { # 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}++; - my $litplus; - - my @command = $self->_z_deflate("$tag "); - my $dbg_cmd = "C: $tag "; - - while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) { - my ($str, $len) = ($1, $2); - my $lit = substr $command, 0, $len, ''; # consume the literal - my $bin = substr($str,-1) eq '~' ? 1 : 0; # literal8, RFC 3516 BINARY - - $litplus //= $self->_capable('LITERAL+') ? '+' : ''; - push @command, $self->_z_deflate($str, "{$len$litplus}", "\r\n"); - - $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug}; - $dbg_cmd = 'C: [...]'; - - unless ($litplus) { - $self->_write(@command); - my $x = $self->_getline(); - $x =~ /\A\+ / or $self->panic($x); - @command = (); - } - if ($len > 4096 and (!$self->{'use-binary'} or $bin) and defined (my $d = $self->{_Z_DEFLATE})) { - my ($status, $buf); - # send a Z_FULL_FLUSH at the start and end of large non-text - # literals, as hinted at in RFC 4978 section 4 - $status = $d->flush($buf, Z_FULL_FLUSH); - $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK; - push @command, $buf if $buf ne ''; - - undef $buf; - $status = $d->deflate($lit, $buf); - $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK; - push @command, $buf if $buf ne ''; - - undef $buf; - $status = $d->flush($buf, Z_FULL_FLUSH); - $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK; - push @command, $buf if $buf ne ''; - } - else { - push @command, $self->_z_deflate($lit); - } - } - push @command, $self->_z_deflate($command, "\r\n"); - $self->logger($dbg_cmd, $command) if $self->{debug}; - $self->_write(@command); + $self->_send_cmd($tag, $command); my $r; # wait for the answer @@ -1849,6 +1845,7 @@ 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