aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm327
1 files changed, 262 insertions, 65 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 97756f4..6012049 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,11 +20,13 @@ package Net::IMAP::InterIMAP v0.0.1;
use warnings;
use strict;
+use Compress::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
+use Errno 'EWOULDBLOCK';
use IO::Select ();
use List::Util 'first';
-use Socket 'SO_KEEPALIVE';
use POSIX ':signal_h';
+use Socket 'SO_KEEPALIVE';
use Exporter 'import';
BEGIN {
@@ -47,6 +49,8 @@ my %OPTIONS = (
password => qr/\A([\x01-\x7F]+)\z/,
auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\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/,
SSL_cipher_list => qr/\A(\P{Control}+)\z/,
SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
@@ -210,10 +214,6 @@ our $IMAP_text;
#
# - 'name': An optional instance name to include in log messages.
#
-# - 'extra-attrs': An attribute or list of extra attributes to FETCH
-# when getting new mails, in addition to (MODSEQ FLAGS INTERNALDATE
-# BODY.PEEK[]).
-#
# - 'logger-fd': An optional filehandle to use for debug output.
#
sub new($%) {
@@ -225,6 +225,11 @@ sub new($%) {
# (cf RFC 3501 section 3)
$self->{_STATE} = '';
+ # in/out buffer counts and output stream
+ $self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0;
+ $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
+ $self->{_OUTBUF} = '';
+
if ($self->{type} eq 'tunnel') {
my $command = $self->{command} // $self->fail("Missing tunnel command");
@@ -232,7 +237,6 @@ sub new($%) {
pipe my $rd, $self->{STDIN} or $self->panic("Can't pipe: $!");
my $pid = fork // $self->panic("Can't fork: $!");
-
unless ($pid) {
# children
foreach (\*STDIN, \*STDOUT, $self->{STDIN}, $self->{STDOUT}) {
@@ -241,12 +245,24 @@ sub new($%) {
open STDIN, '<&', $rd or $self->panic("Can't dup: $!");
open STDOUT, '>&', $wd or $self->panic("Can't dup: $!");
+ my $stderr2;
+ if (uc ($self->{'null-stderr'} // 'NO') eq 'YES') {
+ open $stderr2, '>&', *STDERR;
+ open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
+ }
+
my $sigset = POSIX::SigSet::->new(SIGINT);
my $oldsigset = POSIX::SigSet::->new();
-
sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!");
- exec $command or $self->panic("Can't exec: $!");
+ unless (exec $command) {
+ my $err = $!;
+ if (defined $stderr2) {
+ close STDERR;
+ open STDERR, '>&', $stderr2;
+ }
+ $self->panic("Can't exec: $err");
+ }
}
# parent
@@ -282,6 +298,7 @@ sub new($%) {
$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
$self->{_TAG} = 0;
@@ -391,8 +408,41 @@ sub new($%) {
$self->capabilities();
}
}
-
$self->{_STATE} = 'AUTH';
+
+ # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
+ if (uc ($self->{compress} // 'NO') eq 'YES') {
+ my @supported = qw/DEFLATE/; # supported compression algorithms
+ my @algos = grep defined, map { /^COMPRESS=(.+)/ ? uc $1 : undef } @{$self->{_CAPABILITIES}};
+ my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported;
+ if (!defined $algo) {
+ $self->warn("Couldn't find a suitable compression algorithm. Not enabling compression.");
+ }
+ else {
+ my ($d, $i);
+ my $r = $self->_send("COMPRESS $algo");
+ unless ($r eq 'NO' and $IMAP_text =~ /\ANO \[COMPRESSIONACTIVE\] /) {
+ $self->panic($IMAP_text) unless $r eq 'OK';
+
+ if ($algo eq 'DEFLATE') {
+ my ($status, $d, $i);
+ my %args = ( -WindowBits => 0 - MAX_WBITS );
+ ($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::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);
+ }
+ else {
+ $self->fail("Unsupported compression algorithm: $algo");
+ }
+ }
+ }
+ }
+
my @extensions = !defined $self->{enable} ? ()
: ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
: ($self->{enable});
@@ -411,9 +461,22 @@ sub new($%) {
# Log out when the Net::IMAP::InterIMAP object is destroyed.
sub DESTROY($) {
my $self = shift;
+ $self->{_STATE} = 'LOGOUT';
+
foreach (qw/STDIN STDOUT/) {
$self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
}
+
+ unless ($self->{quiet}) {
+ my $msg = "Connection closed";
+ $msg .= " in=$self->{_INCOUNT}";
+ $msg .= " (raw=$self->{_INRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).")"
+ if defined $self->{_INRAWCOUNT} and $self->{_INCOUNT} > 0 and $self->{_INCOUNT} != $self->{_INRAWCOUNT};
+ $msg .= ", out=$self->{_OUTCOUNT}";
+ $msg .= " (raw=$self->{_OUTRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).")"
+ if defined $self->{_OUTRAWCOUNT} and $self->{_OUTCOUNT} > 0 and $self->{_OUTCOUNT} != $self->{_OUTRAWCOUNT};
+ $self->log($msg);
+ }
}
@@ -686,7 +749,7 @@ sub remove_message($@) {
my $self = shift;
my @set = @_;
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
- if $self->incapable('UIDPLUS');
+ unless $self->_capable('UIDPLUS');
my $set = compact_set(@set);
$self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
@@ -718,15 +781,19 @@ sub remove_message($@) {
# $self->append($mailbox, $mail, [...])
# Issue an APPEND command with the given mails. Croak if the server
# did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list.
-# Providing multiple mails is only allowed for servers advertising
-# "MULTIAPPEND" (RFC 3502) in their CAPABILITY list.
+# Each $mail is a hash reference with key 'RFC822' and optionally
+# 'FLAGS' and 'INTERNALDATE'. If the server supports the "BINARY"
+# extension (RFC 3516), the key 'RFC822' can be replaced with 'BINARY'
+# to send the mail body as a binary literal.
+# Providing multiple mails is only allowed for servers supporting
+# "MULTIAPPEND" (RFC 3502).
# Return the list of UIDs allocated for the new messages.
sub append($$@) {
my $self = shift;
my $mailbox = shift;
return unless @_;
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
- if $self->incapable('UIDPLUS');
+ unless $self->_capable('UIDPLUS');
my @appends;
foreach my $mail (@_) {
@@ -734,11 +801,14 @@ sub append($$@) {
$append .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') '
if defined $mail->{FLAGS};
$append .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
- $append .= "{".length($mail->{RFC822})."}\r\n".$mail->{RFC822};
+ 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.")
- if $#appends > 0 and $self->incapable('MULTIAPPEND');
+ unless $#appends == 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);
@@ -803,7 +873,7 @@ sub fetch($$$$) {
sub notify($@) {
my $self = shift;
$self->fail("Server did not advertise NOTIFY (RFC 5465) capability.")
- if $self->incapable('NOTIFY');
+ unless $self->_capable('NOTIFY');
my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/;
# Be notified of new messages with EXISTS/RECENT responses, but
# don't receive unsolicited FETCH responses with a RFC822/BODY[].
@@ -1008,23 +1078,22 @@ sub pull_updates($;$) {
}
-# $self->pull_new_messages($callback, @ignore)
+# $self->pull_new_messages($callback, $attrs, @ignore)
# FETCH new messages since the UIDNEXT found in the persistent cache
# (or 1 in no such UIDNEXT is found), and process each response on the
# fly with the callback.
+# The list of attributes to FETCH, $attr, much contain either BODY or
+# BINARY.
# If an @ignore list is supplied, then these messages are ignored from
# the UID FETCH range.
# Finally, update the UIDNEXT from the persistent cache to the value
# found in the internal cache.
# /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ!
-sub pull_new_messages($$@) {
+sub pull_new_messages($$$@) {
my $self = shift;
+ my $attrs = shift;
my $callback = shift;
my @ignore = sort { $a <=> $b } @_;
- my @attrs = !defined $self->{'extra-attrs'} ? ()
- : ref $self->{'extra-attrs'} eq 'ARRAY' ? @{$self->{'extra-attrs'}}
- : ($self->{'extra-attrs'});
- my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]';
my $mailbox = $self->{_SELECTED} // $self->panic();
@@ -1153,21 +1222,74 @@ sub _fingerprint_match($$$) {
}
-# $self->_getline([$msg])
-# Read a line from the handle and strip the trailing CRLF.
+# $self->_getline([$length])
+# Read a line from the handle and strip the trailing CRLF, optionally
+# after reading a literal of the given $length (default: 0).
+# In list context, return a pair ($literal, $line); otherwise only
+# return the $line.
# /!\ Don't use this method with non-blocking IO!
sub _getline($;$) {
my $self = shift;
- my $msg = shift // '';
+ my $len = shift // 0;
- if ($self->{STDOUT}->opened()) {
- my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
- $x =~ s/\r\n\z// or $self->panic($x);
- $self->logger("S: $msg", $x) if $self->{debug};
- return $x;
- }
- else {
- undef $self;
+ my $stdout = $self->{STDOUT};
+ $self->fail("Lost connection") unless $stdout->opened();
+
+ my (@lit, @line);
+ while(1) {
+ if ($self->{_OUTBUF} eq '') {
+ # 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);
+ unless (defined $n) {
+ next unless $! == EWOULDBLOCK and
+ (ref $stdout ne 'IO::Socket::SSL' or
+ # sysread might fail if must finish a SSL handshake first
+ ($IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_READ() or
+ $IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_WRITE()));
+ $self->panic("Can't read: $!")
+ }
+ $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
+ $self->{_OUTRAWCOUNT} += $n;
+
+ if (defined (my $i = $self->{_Z_INFLATE})) {
+ my ($out, $status) = $i->inflate($buf);
+ $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK;
+ $buf = $out;
+ }
+ $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) {
+ # found the EOL, we're done
+ my $lit = join '', @lit;
+ my $line = join '', @line, substr($self->{_OUTBUF}, 0, $idx);
+ $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx);
+
+ $self->{_OUTCOUNT} += length($lit) + length($line);
+ $line =~ s/\r\n\z// or $self->panic($line);
+ $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug};
+
+ return (wantarray ? ($lit, $line) : $line);
+ }
+ else {
+ push @line, $self->{_OUTBUF};
+ $self->{_OUTBUF} = '';
+ }
+ }
+ elsif ($len > 0) { # $len bytes of literal bytes to read
+ 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} = '';
+ }
+ next;
+ }
}
}
@@ -1203,6 +1325,98 @@ 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 = shift;
+ foreach (@_) {
+ next if $_ eq '';
+ $self->{STDIN}->write($_) // $self->panic("Can't write: $!");
+ $self->{_INRAWCOUNT} += length($_);
+ }
+}
+
+
+# $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;
+ my ($out, $status) = $d->flush($t);
+ $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+ $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;
+ }
+}
+
+
# $self->_send($command, [$callback])
# Send the given $command to the server, then wait for the response.
# (The status condition and response text are respectively placed in
@@ -1221,32 +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 = ("$tag ");
- my $dbg_cmd = "C: $command[0]";
- while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
- my ($str, $len) = ($1, $2);
- my $lit = substr $command, 0, $len, ''; # consume the literal
-
- $litplus //= $self->_capable('LITERAL+') ? '+' : '';
- push @command, $str, "{$len$litplus}", "\r\n";
- $self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
- $dbg_cmd = 'C: [...]';
-
- unless ($litplus) {
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
- my $x = $self->_getline();
- $x =~ /\A\+ / or $self->panic($x);
- @command = ();
- }
- push @command, $lit;
- }
- push @command, $command, "\r\n";
- $self->logger($dbg_cmd, $command) if $self->{debug};
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
-
+ $self->_send_cmd($tag, $command);
my $r;
# wait for the answer
@@ -1443,9 +1632,7 @@ sub _string($$) {
}
elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
# literal
- $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
- # read a the rest of the response
- $$stream = $self->_getline('[...]');
+ (my $lit, $$stream) = $self->_getline($1);
return $lit;
}
else {
@@ -1602,6 +1789,14 @@ sub _resp($$;$$$) {
elsif (s/\A(?:RFC822|BODY\[\]) //) {
$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(\$_);
+ }
+ }
elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
$mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
}
@@ -1611,7 +1806,7 @@ sub _resp($$;$$$) {
my $uid = $mail{UID} // $self->panic(); # sanity check
$self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
- if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
+ if (!exists $mail{RFC822} and !exists $mail{BINARY} and !exists $mail{ENVELOPE} and # ignore new mails
(!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or
($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) {
my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS};
@@ -1647,8 +1842,10 @@ sub _resp($$;$$$) {
if (defined $callback and $cmd eq 'AUTHENTICATE') {
my $x = $callback->($_);
$self->logger("C: ", $x) if $self->{debug};
- $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
+ $x .= "\r\n";
+ $self->{_INCOUNT} += length($x);
+ $self->_write($x);
+ $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
}
}
else {