From a021e204e0844d81766ad13db229839436357c0e Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 28 Sep 2015 01:17:42 +0200 Subject: Bump version number. --- 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 3a6481e..721597d 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -16,7 +16,7 @@ # along with this program. If not, see . #---------------------------------------------------------------------- -package Net::IMAP::InterIMAP v0.0.2; +package Net::IMAP::InterIMAP v0.0.3; use warnings; use strict; -- cgit v1.2.3 From eb6b971fbd5ef3f9bd76770262da5808cf8c506a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 6 Oct 2015 02:25:56 +0200 Subject: Fix byte count for compression streams. --- lib/Net/IMAP/InterIMAP.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 721597d..8b1f451 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -485,11 +485,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); } -- cgit v1.2.3 From 1aeca5f89e768df83d3f6f86e0d782e5a20fc1f6 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 19 Oct 2015 17:14:43 +0200 Subject: Add an option 'SSL_protocols'. --- lib/Net/IMAP/InterIMAP.pm | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 8b1f451..95bdfa8 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -43,6 +43,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 +58,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, @@ -1460,20 +1463,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, -- cgit v1.2.3 From 29c40a4e26775e072c2ebcd57dcddbe66725cdbd Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 3 Mar 2016 19:05:40 +0100 Subject: Ensure the inbox is always used in upper-case internally. RFC 3501: INBOX is case-insensitive. All case variants of INBOX (e.g., "iNbOx") MUST be interpreted as INBOX not as an astring. An astring which consists of the case-insensitive sequence "I" "N" "B" "O" "X" is considered to be INBOX and not an astring. --- lib/Net/IMAP/InterIMAP.pm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 95bdfa8..c5b45aa 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -734,6 +734,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}; @@ -746,6 +747,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}; @@ -834,6 +836,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(); @@ -973,6 +976,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 = @_; @@ -999,6 +1003,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}; } @@ -1037,6 +1042,7 @@ sub get_cache($@) { # internal cache is newer than its persistent cache. sub is_dirty($$) { my ($self, $mailbox) = @_; + $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; @@ -1917,11 +1923,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} " -- cgit v1.2.3 From 84f0560ed8fb3002581b1bf96d7ea51b3136d72f Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 3 Mar 2016 22:03:48 +0100 Subject: Log and debug messages: don't prefix with a ':' for nameless clients. --- lib/Net/IMAP/InterIMAP.pm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index c5b45aa..7af04e7 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -523,9 +523,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; @@ -536,9 +537,10 @@ sub logger($@) { my ($s, $us) = Time::HiRes::gettimeofday(); $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us "; } - $prefix .= defined "$self->{name}" ? $self->{name} : ''; + $prefix .= $self->{name} // ''; $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $self->{'logger-fd'}->say($prefix, ': ', @_); + $prefix .= ': ' unless $prefix eq ''; + $self->{'logger-fd'}->say($prefix, @_); } -- cgit v1.2.3 From 1956ce125552752f61bbe8b578f00bd049b62512 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 3 Mar 2016 22:25:29 +0100 Subject: fix slurp(), useful for IDLE and NOTIFY. --- lib/Net/IMAP/InterIMAP.pm | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 7af04e7..e3285de 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -22,7 +22,6 @@ use strict; use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); -use IO::Select (); use Net::SSLeay (); use List::Util qw/all first/; use POSIX ':signal_h'; @@ -933,31 +932,31 @@ 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() ); + return $read 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) or + select($rin, undef, undef, 0) > 0; + my $x = $self->_getline(); + $self->_resp($x, $cmd, undef, $callback); $read++; } } @@ -2111,7 +2110,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. -- cgit v1.2.3 From 91eb4650581ac424cc7153ed6dc47be6563182f4 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 3 Mar 2016 22:26:33 +0100 Subject: Don't modify the state when receiving an unsolicited FETCH response without UID We require QRESYNC support (RFC 7162) for syncing, which requires UID (MODSEQ) in unsolicited FETCH responses, cf RFC 7162 section 3.2.4. --- lib/Net/IMAP/InterIMAP.pm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index e3285de..0405794 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -2212,16 +2212,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} //= []; -- cgit v1.2.3 From 48ddc7416f1934b6569ada559c3473de6cf6e4b8 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 3 Mar 2016 22:28:46 +0100 Subject: Relax parsing of continuation requests for for empty resp-text. microsoft's IMAP server violates RFC 3501 by skipping the trailing space for empty resp-text. --- lib/Net/IMAP/InterIMAP.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 0405794..745e64f 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -2249,7 +2249,8 @@ sub _resp($$;$$$) { } } } - elsif (s/\A\+ //) { + elsif (s/\A\+// and ($_ eq '' or s/\A //)) { + # microsoft's IMAP server 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); -- cgit v1.2.3 From 7e4d373d1fd60eeddf641458cc4bec115d3b5ecf Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 4 Mar 2016 11:50:00 +0100 Subject: Inspect the select(2) syscall's return value. --- lib/Net/IMAP/InterIMAP.pm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 745e64f..3957020 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -22,6 +22,7 @@ use strict; use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); +use Errno 'EINTR'; use Net::SSLeay (); use List::Util qw/all first/; use POSIX ':signal_h'; @@ -948,13 +949,16 @@ sub slurp($;$$) { vec(my $rin, fileno($self->{STDOUT}), 1) = 1; while (1) { - return $read 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) or - select($rin, undef, undef, 0) > 0; + 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++; -- cgit v1.2.3 From e9e360cbe894b5674a3ffe433e5d727cf8368715 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 5 Mar 2016 15:31:36 +0100 Subject: pullimap (IMAP part only) --- lib/Net/IMAP/InterIMAP.pm | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3957020..7d6e468 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1043,22 +1043,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) = @_; - $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; + $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'); } @@ -1661,6 +1660,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 -- cgit v1.2.3 From 56e27b9e4c27fe037695515c8afa84fd8a31cf6d Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 5 Mar 2016 15:52:27 +0100 Subject: pullimap: mark downloaded messages as \Seen --- lib/Net/IMAP/InterIMAP.pm | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 7d6e468..15682b3 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -58,6 +58,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/, + logfile => qr/\A(\/\P{Control}+)\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/, @@ -535,9 +536,10 @@ 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 .= $self->{name} // ''; + $prefix .= $self->{name} if defined $self->{name}; $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; $prefix .= ': ' unless $prefix eq ''; $self->{'logger-fd'}->say($prefix, @_); @@ -1255,6 +1257,17 @@ sub push_flag_updates($$@) { } +# $self->silent_store($set, $mod, @flags) +# Set / Add / Update the flags list on the UID $set. +# /!\ there is no check that messages flags been set! +sub silent_store($$$@) { + my $self = shift; + my $set = shift; + my $mod = shift; + $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")"); +} + + ############################################################################# # Private methods -- cgit v1.2.3 From e51c8899d67e5d86a868e1adced55a6c72113daa Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 5 Mar 2016 18:36:07 +0100 Subject: pullimap: add support for IMAP IDLE (RFC 2177). --- lib/Net/IMAP/InterIMAP.pm | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 15682b3..2898905 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -968,6 +968,35 @@ sub slurp($;$$) { } +# $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: @@ -2294,6 +2323,7 @@ sub _resp($$;$$$) { else { $self->panic("Unexpected response: ", $_); } + $callback->() if defined $callback and $cmd eq 'IDLE'; } -- cgit v1.2.3 From 76be3c7c47ace843ab3ebd216252c63411a1222e Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Sat, 5 Mar 2016 19:49:08 +0100 Subject: Ensure the FD_CLOEXEC bit is 1 on sockets, logger and state files. --- lib/Net/IMAP/InterIMAP.pm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 2898905..40f4193 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -23,6 +23,7 @@ use strict; use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); 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'; @@ -1354,7 +1355,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"); } -- cgit v1.2.3 From a3e21af7367cdd09e5260bcda90e79ae0ff00317 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Mar 2016 11:40:38 +0100 Subject: typo --- 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 40f4193..0f674ac 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1289,7 +1289,7 @@ sub push_flag_updates($$@) { # $self->silent_store($set, $mod, @flags) # Set / Add / Update the flags list on the UID $set. -# /!\ there is no check that messages flags been set! +# /!\ There is no guaranty that message flags have been set! sub silent_store($$$@) { my $self = shift; my $set = shift; -- cgit v1.2.3 From 5d8b7a1bef1c1bb1a4efaeff9398f0ed81cb59b1 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Mar 2016 13:32:13 +0100 Subject: pullimap: Remove "logfile" config option. --- lib/Net/IMAP/InterIMAP.pm | 1 - 1 file changed, 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 0f674ac..efa6b92 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -59,7 +59,6 @@ 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/, - logfile => qr/\A(\/\P{Control}+)\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/, -- cgit v1.2.3 From 247cc63d7710e1907b114a75125c27de946415aa Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Mar 2016 16:01:51 +0100 Subject: Add an option "purge-after" to remove old messages. --- lib/Net/IMAP/InterIMAP.pm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index efa6b92..01fb6a9 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1287,8 +1287,9 @@ sub push_flag_updates($$@) { # $self->silent_store($set, $mod, @flags) -# Set / Add / Update the flags list on the UID $set. -# /!\ There is no guaranty that message flags have been set! +# 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; @@ -1297,6 +1298,19 @@ sub silent_store($$$@) { } +# $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 @@ -2220,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/) { -- cgit v1.2.3 From 67f7ae7c82263dc3acad7f6b4df586f94f3b5e15 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 7 Mar 2016 17:32:29 +0100 Subject: wibble --- 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 01fb6a9..be62a9d 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -2335,7 +2335,7 @@ sub _resp($$;$$$) { } } elsif (s/\A\+// and ($_ eq '' or s/\A //)) { - # microsoft's IMAP server violates RFC 3501 by skipping the trailing ' ' for empty resp-text + # 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); -- cgit v1.2.3