aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm142
1 files changed, 77 insertions, 65 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index bb27009..02ae65f 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -17,7 +17,7 @@
#----------------------------------------------------------------------
package Net::IMAP::InterIMAP v0.0.5;
-use v5.10.0;
+use v5.20.0;
use warnings;
use strict;
@@ -36,7 +36,7 @@ BEGIN {
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();
- our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond
+ our @EXPORT_OK = qw/xdg_basedir read_config compact_set
slurp is_dirty has_new_mails/;
}
@@ -61,7 +61,7 @@ my %OPTIONS = (
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/,
+ compress => qr/\A(YES|NO)\z/i,
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/,
@@ -203,6 +203,21 @@ sub compact_list(@) {
return $set;
}
+# with_set($set, $cmd)
+# Split long commands over multiple subsets to avoid exceeding the server limit
+sub with_set($&) {
+ my ($set, $cmd) = @_;
+ my $max_length = 4096;
+ for (my $length = length($set); $length > $max_length;) {
+ my $l = rindex($set, ',', $max_length);
+ die unless $l > 0; # sanity check
+ $cmd->(substr($set, 0, $l));
+ $set = substr($set, ++$l);
+ $length -= $l;
+ }
+ return $cmd->($set);
+}
+
# in_set($x, $set)
# Return true if the UID or sequence number $x belongs to the set $set.
@@ -215,7 +230,7 @@ sub in_set($$) {
return 1 if $x == $1;
}
elsif ($r eq '*' or $r eq '*:*') {
- warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
+ warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)";
return 1;
}
elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) {
@@ -398,7 +413,8 @@ 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->{S}) if $self->{type} eq 'imaps';
+ $self->_send('STARTTLS');
+ $self->_start_ssl($self->{S});
# refresh the previous CAPABILITY list since the previous one could have been spoofed
delete $self->{_CAPABILITIES};
@@ -840,9 +856,10 @@ sub remove_message($@) {
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
unless $self->_capable('UIDPLUS');
- my $set = compact_set(@set);
- $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)");
- $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS
+ with_set(compact_set(@set), sub($) {
+ $self->_send("UID STORE $_[0] +FLAGS.SILENT (\\Deleted)");
+ $self->_send("UID EXPUNGE $_[0]"); # RFC 4315 UIDPLUS
+ });
my %vanished = map {$_ => 1} @{$self->{_VANISHED}};
@@ -959,7 +976,9 @@ sub append($$@) {
# optional $callback.
sub fetch($$$;&) {
my ($self, $set, $flags, $callback) = @_;
- $self->_send("UID FETCH $set $flags", $callback);
+ return with_set($set, sub($) {
+ $self->_send("UID FETCH $_[0] $flags", $callback);
+ });
}
@@ -1196,16 +1215,15 @@ sub pull_updates($;$) {
my $mailbox = $self->{_SELECTED} // $self->panic();
my $pcache = $self->{_PCACHE}->{$mailbox};
- my %modified;
$self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)")
if $full and ($pcache->{UIDNEXT} // 1) > 1;
- my @missing;
+ my %modified;
while (%{$self->{_MODIFIED}}) {
+ my @missing;
while (my ($uid,$v) = each %{$self->{_MODIFIED}}) {
- # don't filter on the fly (during FETCH responses) because
- # FLAG updates can arrive while processing pull_new_messages
- # for instance
+ # don't filter on the fly (during FETCH responses) because FLAG updates
+ # can arrive while processing pull_new_messages() for instance
if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH
next unless $uid < ($pcache->{UIDNEXT} // 1) # out of bounds
and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen
@@ -1215,8 +1233,11 @@ sub pull_updates($;$) {
}
}
$self->{_MODIFIED} = {};
- $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing;
- @missing = ();
+ # non-empty @missing indicates a discouraged (but allowed) CONDSTORE server behavior,
+ # cf. RFC 7162 sec. 3.1.3 ex. 8 and the comment in push_flag_updates() below
+ with_set(compact_set(@missing), sub($) {
+ $self->_send("UID FETCH $_[0] (MODSEQ FLAGS)")
+ }) if @missing;
}
# do that afterwards since the UID FETCH command above can produce VANISHED responses
@@ -1278,7 +1299,7 @@ sub pull_new_messages($$&@) {
$range .= "$since:4294967295";
$UIDNEXT = $cache->{UIDNEXT} // $self->panic(); # sanity check
- $self->_send("UID FETCH $range ($attrs)", sub($) {
+ $self->fetch($range, "($attrs)", sub($) {
my $mail = shift;
$UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID};
$callback->($mail) if defined $callback;
@@ -1306,57 +1327,48 @@ sub push_flag_updates($$@) {
my $mailbox = $self->{_SELECTED} // $self->panic();
my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic();
- my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)";
-
- my %listed;
- $self->_send($command, sub($){ $listed{shift->{UID}}++; });
my %failed;
- if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) {
- foreach (split /,/, $1) {
- if (/\A([0-9]+)\z/) {
- $failed{$1} = 1;
- }
- elsif (/\A([0-9]+):([0-9]+)\z/) {
- my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
- $failed{$_} = 1 foreach ($min .. $max);
- }
- else {
- $self->panic($_);
+ with_set(compact_set(@set), sub($) {
+ $self->_send("UID STORE $_[0] (UNCHANGEDSINCE $modseq) FLAGS.SILENT ($flags)");
+ if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) {
+ foreach (split /,/, $1) {
+ if (/\A([0-9]+)\z/) {
+ $failed{$1} = 1;
+ } elsif (/\A([0-9]+):([0-9]+)\z/) {
+ my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1);
+ $failed{$_} = 1 foreach ($min .. $max);
+ } else {
+ $self->panic($_);
+ }
}
}
- }
+ });
my @ok;
foreach my $uid (@set) {
+ my $modified = $self->{_MODIFIED};
if ($failed{$uid}) {
- # $uid was listed in the MODIFIED response code
- $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates
- delete $self->{_MODIFIED}->{$uid} if
- # got a FLAG update for $uid; ignore it if it's $flags
- defined $self->{_MODIFIED}->{$uid}->[1] and
- $self->{_MODIFIED}->{$uid}->[1] eq $flags;
- }
- else {
- # $uid wasn't listed in the MODIFIED response code
- next unless defined $self->{_MODIFIED}->{$uid}; # already stored
- $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check
- if ($listed{$uid} == 1) {
- # ignore succesful update
- delete $self->{_MODIFIED}->{$uid};
+ # $uid was listed in the MODIFIED response code from RFC 7162; will FETCH
+ # again in pull_updates(); per RFC 7162 sec. 3.1.3 $modified->{$uid} might not
+ # be defined ("nice" servers send an untagged FETCH response, cf. example 10,
+ # but they might omit it - allowed but discouraged CONDSTORE server behavior -
+ # cf. example 8)
+ $modified->{$uid} //= [ 0, undef ];
+ } elsif (defined (my $m = $modified->{$uid})) {
+ # received an untagged FETCH response, remove from the list of pending changes
+ # if the flag list was up to date (either implicitely or explicitely)
+ if (!defined $m->[1] or $m->[1] eq $flags) {
+ delete $modified->{$uid};
+ push @ok, $uid;
}
- elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) {
- # got multiple FETCH responses for $uid, the last one with $flags
- delete $self->{_MODIFIED}->{$uid};
- }
- push @ok, $uid;
}
}
unless ($self->{quiet}) {
$self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok;
$self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '.
- "trying again later") if %failed;
+ "will try again later") if %failed;
}
return keys %failed;
}
@@ -1369,8 +1381,9 @@ sub push_flag_updates($$@) {
sub silent_store($$$@) {
my $self = shift;
my $set = shift;
- my $mod = shift;
- $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")");
+ my $subcmd = shift . "FLAGS.SILENT";
+ my $flags = join(' ', @_);
+ with_set($set, sub($) { $self->_send("UID STORE $_[0] $subcmd ($flags)") });
}
@@ -1383,7 +1396,7 @@ sub expunge($$) {
$self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.")
unless $self->_capable('UIDPLUS');
- $self->_send("UID EXPUNGE $set");
+ with_set($set, sub($) { $self->_send("UID EXPUNGE $_[0]") });
}
@@ -1408,10 +1421,10 @@ sub _ssl_error($$@) {
# RFC 3986 appendix A
my $RE_IPv4 = do {
my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/;
- qr/$dec(?:\.$dec){3}/o };
+ qr/$dec(?:\.$dec){3}/ };
my $RE_IPv6 = do {
my $h16 = qr/[0-9A-Fa-f]{1,4}/;
- my $ls32 = qr/$h16:$h16|$RE_IPv4/o;
+ my $ls32 = qr/$h16:$h16|$RE_IPv4/;
qr/ (?: $h16 : ){6} $ls32
| :: (?: $h16 : ){5} $ls32
| (?: $h16 )? :: (?: $h16 : ){4} $ls32
@@ -1421,7 +1434,7 @@ my $RE_IPv6 = do {
| (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
| (?: (?: $h16 : ){0,5} $h16 )? :: $h16
| (?: (?: $h16 : ){0,6} $h16 )? ::
- /xo };
+ /x };
# Opens a TCP socket to the given $host and $port.
@@ -1429,11 +1442,10 @@ sub _tcp_connect($$$) {
my ($self, $host, $port) = @_;
my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP);
- if ($host =~ qr/\A$RE_IPv4\z/o) {
+ if ($host =~ qr/\A$RE_IPv4\z/) {
$hints{family} = AF_INET;
$hints{flags} |= AI_NUMERICHOST;
- }
- elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) {
+ } elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/) {
$host = $1;
$hints{family} = AF_INET6;
$hints{flags} |= AI_NUMERICHOST;
@@ -1611,7 +1623,7 @@ sub _ssl_verify($$$) {
my $pkey = Net::SSLeay::X509_get_X509_PUBKEY($cert);
unless (defined $pkey and Net::SSLeay::EVP_Digest($pkey, $type) eq $digest) {
- $self->warn("Fingerprint doesn't match! MiTM in action?");
+ $self->warn("Fingerprint doesn't match! MiTM in action?");
$ok = 0;
}
}
@@ -2356,7 +2368,7 @@ sub _resp($$;&$$) {
# /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs
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.");
+ $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled.");
}
# the new message was expunged before it was synced
$self->{_NEW} = 0 if $self->{_NEW} == 1 and $cache->{EXISTS} == $1;
@@ -2407,7 +2419,7 @@ sub _resp($$;&$$) {
/\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_);
my %status = split / /, $1;
$mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive
- $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response")
+ $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response")
if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and
($cmd eq 'NOTIFY' or $cmd eq 'slurp');
$self->_update_cache_for($mailbox, %status);
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 03:54:16 +0000