aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/InterIMAP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm219
1 files changed, 170 insertions, 49 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 3a6481e..be62a9d 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -16,13 +16,14 @@
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#----------------------------------------------------------------------
-package Net::IMAP::InterIMAP v0.0.2;
+package Net::IMAP::InterIMAP v0.0.3;
use warnings;
use strict;
use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
-use IO::Select ();
+use Errno 'EINTR';
+use Fcntl qw/F_GETFL F_SETFL FD_CLOEXEC/;
use Net::SSLeay ();
use List::Util qw/all first/;
use POSIX ':signal_h';
@@ -43,6 +44,8 @@ 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_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/;
+my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-2])/;
+
# Map each option to a regexp validating its values.
my %OPTIONS = (
host => qr/\A(\P{Control}+)\z/,
@@ -56,6 +59,7 @@ 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_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\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,
@@ -485,11 +489,11 @@ sub stats($) {
$msg .= ' recv '._kibi($self->{_OUTCOUNT});
$msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}).
', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')'
- if defined $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0;
+ if exists $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0;
$msg .= ' sent '._kibi($self->{_INCOUNT});
$msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}).
', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')'
- if defined $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0;
+ if exists $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0;
$self->log($msg);
}
@@ -520,9 +524,10 @@ sub log($@) {
return unless @_;
$self->logger(@_) if defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno
and $self->{'logger-fd'}->fileno != fileno STDERR;
- my $prefix = defined $self->{name} ? $self->{name} : '';
+ my $prefix = $self->{name} // '';
$prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
- print STDERR $prefix, ': ', @_, "\n";
+ $prefix .= ': ' unless $prefix eq '';
+ print STDERR $prefix, @_, "\n";
}
sub logger($@) {
my $self = shift;
@@ -531,11 +536,13 @@ sub logger($@) {
if (defined $self->{'logger-fd'}->fileno and defined $self->{'logger-fd'}->fileno
and $self->{'logger-fd'}->fileno != fileno STDERR) {
my ($s, $us) = Time::HiRes::gettimeofday();
- $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us ";
+ $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us";
+ $prefix .= ' ' if defined $self->{name} or $self->{_STATE} eq 'SELECTED';
}
- $prefix .= defined "$self->{name}" ? $self->{name} : '';
+ $prefix .= $self->{name} if defined $self->{name};
$prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED';
- $self->{'logger-fd'}->say($prefix, ': ', @_);
+ $prefix .= ': ' unless $prefix eq '';
+ $self->{'logger-fd'}->say($prefix, @_);
}
@@ -731,6 +738,7 @@ sub rename($$$;$) {
# If $try is set, print a warning but don't crash if the command fails.
sub subscribe($$;$) {
my ($self, $mailbox, $try) = @_;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
my $r = $self->_send("SUBSCRIBE ".quote($mailbox));
if ($IMAP_cond eq 'OK') {
$self->log("Subscribe to ".$mailbox) unless $self->{quiet};
@@ -743,6 +751,7 @@ sub subscribe($$;$) {
}
sub unsubscribe($$;$) {
my ($self, $mailbox, $try) = @_;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox));
if ($IMAP_cond eq 'OK') {
$self->log("Unsubscribe to ".$mailbox) unless $self->{quiet};
@@ -831,6 +840,7 @@ sub append($$@) {
# dump the cache before issuing the command if we're appending to the current mailbox
my ($UIDNEXT, $EXISTS, $cache, %vanished);
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) {
$cache = $self->{_CACHE}->{$mailbox};
$UIDNEXT = $cache->{UIDNEXT} // $self->panic();
@@ -925,36 +935,68 @@ sub notify($@) {
my $command = 'NOTIFY ';
$command .= @_ ? ('SET '. join(' ', map {"($_ ($events))"} @_)) : 'NONE';
$self->_send($command);
- $self->{_SEL_OUT} = IO::Select::->new($self->{STDOUT});
}
-# $self->slurp()
+# $self->slurp([$cmd, $callback])
# See if the server has sent some unprocessed data; try to as many
# lines as possible, process them, and return the number of lines
# read.
# This is mostly useful when waiting for notifications while no
-# command is progress, cf. RFC 5465 (NOTIFY).
-sub slurp($) {
- my $self = shift;
-
+# command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY).
+sub slurp($;$$) {
+ my ($self, $cmd, $callback) = @_;
my $ssl = $self->{_SSL};
my $read = 0;
+ vec(my $rin, fileno($self->{STDOUT}), 1) = 1;
while (1) {
- # Unprocessed data within the current TLS record would cause
- # select(2) to block/timeout due to the raw socket not being
- # ready.
- 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() );
+ unless ((defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') or
+ # Unprocessed data within the current TLS record would
+ # cause select(2) to block/timeout due to the raw socket
+ # not being ready.
+ (defined $ssl and Net::SSLeay::pending($ssl) > 0)) {
+ my $r = CORE::select($rin, undef, undef, 0);
+ next if $r == -1 and $! == EINTR; # select(2) was interrupted
+ $self->panic("Can't select: $!") if $r == -1;
+ return $read if $r == 0; # nothing more to read
+ }
+ my $x = $self->_getline();
+ $self->_resp($x, $cmd, undef, $callback);
$read++;
}
}
+# $self->idle([$timeout, $stopwhen])
+# Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or
+# when the callback $stopwhen returns true.
+# Return false if the timeout was reached, and true if IDLE was
+# stopped due the callback.
+sub idle($$$) {
+ my ($self, $timeout, $stopwhen) = @_;
+ $timeout //= 1740; # 29 mins
+
+ $self->fail("Server did not advertise IDLE (RFC 2177) capability.")
+ unless $self->_capable('IDLE');
+
+ my $tag = $self->_cmd_init('IDLE');
+ $self->_cmd_flush();
+
+ for (; $timeout > 0; $timeout--) {
+ $self->slurp('IDLE', sub() {$timeout = -1 if $stopwhen->()});
+ sleep 1 if $timeout > 0;
+ }
+
+ # done idling
+ $self->_cmd_extend('DONE');
+ $self->_cmd_flush();
+ $self->_recv($tag);
+
+ return $timeout < 0 ? 1 : 0;
+}
+
+
# $self->set_cache( $mailbox, STATE )
# Initialize or update the persistent cache, that is, associate a
# known $mailbox with the last known (synced) state:
@@ -970,6 +1012,7 @@ sub slurp($) {
sub set_cache($$%) {
my $self = shift;
my $mailbox = shift // $self->panic();
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
my $cache = $self->{_PCACHE}->{$mailbox} //= {};
my %status = @_;
@@ -996,6 +1039,7 @@ sub uidvalidity($;$) {
my $self = shift;
my $mailbox = shift;
if (defined $mailbox) {
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
my $cache = $self->{_CACHE}->{$mailbox} // return;
return $cache->{UIDVALIDITY};
}
@@ -1030,21 +1074,21 @@ sub get_cache($@) {
# $self->is_dirty($mailbox)
-# Return true if there are pending updates for $mailbox, i.e., its
-# internal cache is newer than its persistent cache.
+# Return true if there are pending updates for $mailbox, i.e., if its
+# internal cache's HIGHESTMODSEQ or UIDNEXT values differ from its
+# persistent cache's values.
sub is_dirty($$) {
my ($self, $mailbox) = @_;
- my $cache = $self->{_CACHE}->{$mailbox} // return 1;
- my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;
+ $self->_updated_cache($mailbox, qw/HIGHESTMODSEQ UIDNEXT/);
+}
- if (defined $pcache->{HIGHESTMODSEQ} and defined $cache->{HIGHESTMODSEQ}
- and $pcache->{HIGHESTMODSEQ} == $cache->{HIGHESTMODSEQ} and
- defined $pcache->{UIDNEXT} and defined $cache->{UIDNEXT}
- and $pcache->{UIDNEXT} == $cache->{UIDNEXT}) {
- return 0
- } else {
- return 1
- }
+
+# $self->has_new_mails($mailbox)
+# Return true if there are new messages in $mailbox, i.e., if its
+# internal cache's UIDNEXT value differs from its persistent cache's.
+sub has_new_mails($$) {
+ my ($self, $mailbox) = @_;
+ $self->_updated_cache($mailbox, 'UIDNEXT');
}
@@ -1242,6 +1286,31 @@ sub push_flag_updates($$@) {
}
+# $self->silent_store($set, $mod, @flags)
+# Set / Add / Remove the flags list on the UID $set, depending on the
+# value of $mod ('' / '+' / '-').
+# /!\ There is no guaranty that message flags are successfully updated!
+sub silent_store($$$@) {
+ my $self = shift;
+ my $set = shift;
+ my $mod = shift;
+ $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")");
+}
+
+
+# $self->expunge($set)
+# Exunge the given UID $set.
+# /!\ There is no guaranty that messages are successfully expunged!
+sub expunge($$) {
+ my $self = shift;
+ my $set = shift;
+
+ $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
+ unless $self->_capable('UIDPLUS');
+ $self->_send("UID EXPUNGE $set");
+}
+
+
#############################################################################
# Private methods
@@ -1299,7 +1368,13 @@ sub _tcp_connect($$$) {
foreach my $ai (@res) {
socket my $s, $ai->{family}, $ai->{socktype}, $ai->{protocol};
- return $s if defined $s and connect($s, $ai->{addr});
+ # TODO: add a connection timeout
+ # http://devpit.org/wiki/Connect%28%29_with_timeout_%28in_Perl%29
+ if (defined $s and connect($s, $ai->{addr})) {
+ my $flags = fcntl($s, F_GETFL, 0) or $self->panic("fcntl F_GETFL: $!");
+ fcntl($s, F_SETFL, $flags | FD_CLOEXEC) or $self->panic("fcntl F_SETFL: $!");
+ return $s;
+ }
}
$self->fail("Can't connect to $host:$port");
}
@@ -1460,20 +1535,42 @@ sub _ssl_verify($$$) {
return $ok; # 1=accept cert, 0=reject
}
+my %SSL_proto = (
+ 'SSLv2' => Net::SSLeay::OP_NO_SSLv2(),
+ 'SSLv3' => Net::SSLeay::OP_NO_SSLv3(),
+ 'TLSv1' => Net::SSLeay::OP_NO_TLSv1(),
+ 'TLSv1.1' => Net::SSLeay::OP_NO_TLSv1_1(),
+ 'TLSv1.2' => Net::SSLeay::OP_NO_TLSv1_2()
+);
# $self->_start_ssl($socket)
# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
my ($self, $socket) = @_;
my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!");
+ my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE();
+
+ $self->{SSL_protocols} //= q{!SSLv2 !SSLv3};
+ my ($proto_include, $proto_exclude) = (0, 0);
+ foreach (split /\s+/, $self->{SSL_protocols}) {
+ my $neg = s/^!// ? 1 : 0;
+ s/\.0$//;
+ ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_");
+ }
+ if ($proto_include != 0) {
+ # exclude all protocols except those explictly included
+ my $x = 0;
+ $x |= $_ foreach values %SSL_proto;
+ $x &= ~ $proto_include;
+ $proto_exclude |= $x;
+ }
+ my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto;
+ $self->log("Disabling SSL protocol: ".join(', ', sort @proto_exclude)) if $self->{debug};
+ $ssl_options |= $SSL_proto{$_} foreach @proto_exclude;
+ $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION();
# 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() );
+ Net::SSLeay::CTX_set_options($ctx, $ssl_options);
# https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html
Net::SSLeay::CTX_set_mode($ctx,
@@ -1625,6 +1722,24 @@ sub _update_cache_for($$%) {
}
+# $self->_updated_cache($mailbox)
+# Return true if there are pending updates for $mailbox, i.e., if one
+# of its internal cache's @attrs value differs from the persistent
+# cache's value.
+sub _updated_cache($$@) {
+ my ($self, $mailbox, @attrs) = @_;
+ $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
+ my $cache = $self->{_CACHE}->{$mailbox} // return 1;
+ my $pcache = $self->{_PCACHE}->{$mailbox} // return 1;
+
+ foreach (@attrs) {
+ return 1 unless $pcache->{$_} and defined $cache->{$_} and
+ $pcache->{$_} == $cache->{$_};
+ }
+ return 0;
+}
+
+
# $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
@@ -1892,11 +2007,11 @@ sub _select_or_examine($$$;$$) {
my $mailbox = shift;
my ($seqs, $uids) = @_;
+ $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
my $pcache = $self->{_PCACHE}->{$mailbox} //= {};
my $cache = $self->{_CACHE}->{$mailbox} //= {};
$cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY};
- $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive
$command .= ' '.quote($mailbox);
if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) {
$command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} "
@@ -2078,7 +2193,7 @@ sub _envelope($$) {
return \@envelope;
}
-# $self->_resp($buf, [$cmd, $callback] )
+# $self->_resp($buf, [$cmd, $set, $callback] )
# Parse an untagged response line or a continuation request line.
# (The trailing CRLF must be removed.) The internal cache is
# automatically updated when needed.
@@ -2119,8 +2234,10 @@ sub _resp($$;$$$) {
}
elsif (/\A([0-9]+) EXPUNGE\z/) {
# /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
- $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
- $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.") if $self->_enabled('QRESYNC');
+ if ($self->_enabled('QRESYNC')) {
+ $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check
+ $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.");
+ }
$cache->{EXISTS}--; # explicit EXISTS responses are optional
}
elsif (/\ASEARCH((?: [0-9]+)*)\z/) {
@@ -2180,16 +2297,18 @@ sub _resp($$;$$$) {
undef $first;
}
- my $uid = $mail{UID} // $self->panic(); # sanity check
$self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
+ my $uid = $mail{UID};
if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
+ defined $uid and # /!\ ignore unsolicited FETCH responses without UID, cf RFC 7162 section 3.2.4
(!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};
$self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ];
}
- $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and in_set($uid, $set);
+ $callback->(\%mail) if defined $callback and ($cmd eq 'FETCH' or $cmd eq 'STORE') and
+ defined $uid and in_set($uid, $set);
}
elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE
$self->{_ENABLED} //= [];
@@ -2215,7 +2334,8 @@ sub _resp($$;$$$) {
}
}
}
- elsif (s/\A\+ //) {
+ elsif (s/\A\+// and ($_ eq '' or s/\A //)) {
+ # Microsoft Exchange Server 2010 violates RFC 3501 by skipping the trailing ' ' for empty resp-text
if (defined $callback and $cmd eq 'AUTHENTICATE') {
my $x = $callback->($_);
$self->_cmd_extend(\$x);
@@ -2225,6 +2345,7 @@ sub _resp($$;$$$) {
else {
$self->panic("Unexpected response: ", $_);
}
+ $callback->() if defined $callback and $cmd eq 'IDLE';
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-03 02:26:24 +0000