diff options
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r-- | lib/Net/IMAP/Sync.pm | 245 |
1 files changed, 124 insertions, 121 deletions
diff --git a/lib/Net/IMAP/Sync.pm b/lib/Net/IMAP/Sync.pm index bb99dcb..9db339b 100644 --- a/lib/Net/IMAP/Sync.pm +++ b/lib/Net/IMAP/Sync.pm @@ -39,17 +39,17 @@ my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; my %OPTIONS = ( host => qr/\A([0-9a-zA-Z:.-]+)\z/, port => qr/\A([0-9]+)\z/, - type => qr/\A(imaps?|preauth)\z/, - STARTTLS => qr/\A(true|false)\z/i, + type => qr/\A(imaps?|tunnel)\z/, + STARTTLS => qr/\A(YES|NO)\z/i, username => qr/\A([\x01-\x7F]+)\z/, password => qr/\A([\x01-\x7F]+)\z/, auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, - command => qr/\A(\P{Control}+)\z/, - 'read-only' => qr/\A(TRUE|FALSE)\z/i, - SSL_ca_path => qr/\A(\P{Control}+)\z/, - SSL_cipher_list => qr/\A(\P{Control}+)\z/, + command => qr/\A(\/\P{Control}+)\z/, + 'read-only' => qr/\A(YES|NO)\z/i, SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/, - SSL_verify_peer => qr/\A(TRUE|FALSE)\z/i, + SSL_cipher_list => qr/\A(\P{Control}+)\z/, + SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i, + SSL_ca_path => qr/\A(\P{Control}+)\z/, ); @@ -75,7 +75,7 @@ sub read_config($$%) { my %configs; foreach my $section (@$sections) { - my $conf = { %{$h->{_}} }; # default section + my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section $configs{$section} = $conf; next unless defined $section and $section ne '_'; @@ -87,7 +87,7 @@ sub read_config($$%) { $conf->{host} //= 'localhost'; $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; $conf->{auth} //= 'PLAIN LOGIN'; - $conf->{STARTTLS} //= 'TRUE'; + $conf->{STARTTLS} //= 'YES'; # untaint and validate the config foreach my $k (keys %$conf) { @@ -203,7 +203,7 @@ our $IMAP_text; # # - 'enable': An extension or array reference of extensions to ENABLE # (RFC 5161) after entering AUTH state. Croak if the server did not -# advertize "ENABLE" in its CAPABILITY list or does not reply with +# advertise "ENABLE" in its CAPABILITY list or does not reply with # an untagged ENABLED response with all the given extensions. # # - 'STDERR': Where to log debug and informational messages (default: @@ -225,7 +225,7 @@ sub new($%) { bless $self, $class; # whether we're allowed to to use read-write command - $self->{'read-only'} = uc ($self->{'read-only'} // 'FALSE') ne 'TRUE' ? 0 : 1; + $self->{'read-only'} = uc ($self->{'read-only'} // 'NO') ne 'YES' ? 0 : 1; # where to log $self->{STDERR} //= \*STDERR; @@ -234,10 +234,10 @@ sub new($%) { # (cf RFC 3501 section 3) $self->{_STATE} = ''; - if ($self->{type} eq 'preauth') { + if ($self->{type} eq 'tunnel') { require 'IPC/Open2.pm'; - my $command = $self->{command} // $self->fail("Missing preauth command"); - my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, split(/ /, $command)) + my $command = $self->{command} // $self->fail("Missing tunnel command"); + my $pid = IPC::Open2::open2(@$self{qw/STDOUT STDIN/}, $command) or $self->panic("Can't fork: $!"); } else { @@ -252,8 +252,8 @@ sub new($%) { } else { require 'IO/Socket/SSL.pm'; - if (defined (my $vrfy = delete $self->{SSL_verify_peer})) { - $args{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE'; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; } my $fpr = delete $self->{SSL_fingerprint}; $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; @@ -311,16 +311,16 @@ sub new($%) { $self->{_STATE} = 'UNAUTH'; my @caps = $self->capabilities(); - if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'FALSE') { # RFC 2595 section 5.1 - $self->fail("Server did not advertize STARTTLS capability.") + if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1 + $self->fail("Server did not advertise STARTTLS capability.") unless grep {$_ eq 'STARTTLS'} @caps; require 'IO/Socket/SSL.pm'; $self->_send('STARTTLS'); my %sslargs; - if (defined (my $vrfy = delete $self->{SSL_verify_peer})) { - $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'FALSE'; + if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { + $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; } my $fpr = delete $self->{SSL_fingerprint}; $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; @@ -373,10 +373,10 @@ sub new($%) { : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} : ($self->{enable}); if (@extensions) { - $self->fail("Server did not advertize ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); + $self->fail("Server did not advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); $self->_send('ENABLE '.join(' ',@extensions)); my @enabled = @{$self->{_ENABLED} // []}; - $self->fail("Could not ENABLE $_") foreach + $self->fail("Couldn't ENABLE $_") foreach grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; } @@ -387,8 +387,9 @@ sub new($%) { # Close handles when the Net::IMAP::Sync object is destroyed. sub DESTROY($) { my $self = shift; - foreach (qw/STDIN STDOUT/) { - $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + if (defined $self->{STDIN} and $self->{STDIN}->opened() and + defined $self->{STDOUT} and $self->{STDOUT}->opened()) { + $self->logout(); } $self->{STDERR}->close() if defined $self->{STDERR} and $self->{STDERR}->opened() and $self->{STDERR} ne \*STDERR; @@ -450,7 +451,7 @@ sub capabilities($) { # $self->incapable(@capabilities) # In list context, return the list capabilties from @capabilities -# which were NOT advertized by the server. In scalar context, return +# which were NOT advertised by the server. In scalar context, return # the length of said list. sub incapable($@) { my ($self, @caps) = @_; @@ -567,16 +568,16 @@ sub list($$@) { } -# $self->remove($uid, [...]) -# Remove the given $uid list. Croak if the server did not advertize +# $self->remove_message($uid, [...]) +# Remove the given $uid list. Croak if the server did not advertise # "UIDPLUS" (RFC 4315) in its CAPABILITY list. # Successfully EXPUNGEd UIDs are removed from the pending VANISHED and # MODIFIED lists. -# Return the list of UIDs that could not be EXPUNGEd. -sub remove($@) { +# Return the list of UIDs that couldn't be EXPUNGEd. +sub remove_message($@) { my $self = shift; my @set = @_; - $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") if $self->incapable('UIDPLUS'); my $set = compact_set(@set); @@ -599,37 +600,37 @@ sub remove($@) { delete @{$self->{_MODIFIED}}{@expunged}; $self->{_VANISHED} = [ keys %vanished ]; - $self->log("Removed UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; - $self->warn("Could not UID EXPUNGE ".compact_set(@failed)) if @failed; + $self->log("Removed ".($#expunged+1)." message(s), ". + "UID ".compact_set(@expunged)) if @expunged and !$self->{quiet}; + $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed; return @failed; } -# $self->append($mailbox, RFC822, [FLAGS, [INTERNALDATE, ...]]) +# $self->append($mailbox, $mail, [...]) # Issue an APPEND command with the given mails. Croak if the server -# did not advertize "UIDPLUS" (RFC 4315) in its CAPABILITY list. -# Providing multiple mails is only allowed for servers advertizing +# 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. # Return the list of UIDs allocated for the new messages. -sub append($$$@) { +sub append($$@) { my $self = shift; my $mailbox = shift; + return unless @_; $self->fail("Server is read-only.") if $self->{'read-only'}; - $self->fail("Server did not advertize UIDPLUS (RFC 4315) capability.") + $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") if $self->incapable('UIDPLUS'); my @appends; - while (@_) { - my $rfc822 = shift; - my $flags = shift; - my $internaldate = shift; + foreach my $mail (@_) { my $append = ''; - $append .= '('.join(' ',@$flags).') ' if defined $flags; - $append .= '"'.$internaldate.'" ' if defined $internaldate; - $append .= "{".length($rfc822)."}\r\n".$rfc822; + $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}; push @appends, $append; } - $self->fail("Server did not advertize MULTIAPPEND (RFC 3502) capability.") + $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.") if $#appends > 0 and $self->incapable('MULTIAPPEND'); # dump the cache before issuing the command if we're appending to the current mailbox @@ -649,12 +650,12 @@ sub append($$$@) { my @uids; foreach (split /,/, $uidset) { if (/\A([0-9]+)\z/) { - $UIDNEXT = $1 + 1 if $UIDNEXT < $1; + $UIDNEXT = $1 + 1 if $UIDNEXT <= $1; push @uids, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1); push @uids, ($min .. $max); - $UIDNEXT = $max + 1 if $UIDNEXT < $max; + $UIDNEXT = $max + 1 if $UIDNEXT <= $max; } else { $self->panic($_); } @@ -670,7 +671,7 @@ sub append($$$@) { delete $vanished2{$_} foreach keys %vanished; my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile $cache->{EXISTS} += $#appends+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; - $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 0) < $UIDNEXT; + $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT; } $self->log("Added ".($#appends+1)." message(s) to $mailbox, got new UID ".compact_set(@uids)) @@ -691,10 +692,10 @@ sub fetch($$$$) { # $self->notify(@specifications) # Issue a NOTIFY command with the given mailbox @specifications (cf RFC # 5465 section 6) to be monitored. Croak if the server did not -# advertize "NOTIFY" (RFC 5465) in its CAPABILITY list. +# advertise "NOTIFY" (RFC 5465) in its CAPABILITY list. sub notify($@) { my $self = shift; - $self->fail("Server did not advertize NOTIFY (RFC 5465) capability.") + $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.") if $self->incapable('NOTIFY'); my $events = join ' ', qw/MessageNew MessageExpunge FlagChange MailboxName SubscriptionChange/; # Be notified of new messages with EXISTS/RECENT responses, but @@ -794,8 +795,8 @@ sub get_cache($@) { unless $self->{_STATE} eq 'SELECTED'; my $mailbox = $self->{_SELECTED} // $self->panic(); - $self->fail("Pending VANISHED responses!") if @{$self->{_VANISHED}}; - $self->fail("Pending FLAG updates!") if %{$self->{_MODIFIED}}; + $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; + $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}}; my $cache = $self->{_PCACHE}->{$mailbox}; return @_ ? @$cache{@_} : %$cache; @@ -851,42 +852,36 @@ sub pull_updates($;$) { my $mailbox = $self->{_SELECTED} // $self->panic(); my $pcache = $self->{_PCACHE}->{$mailbox}; - my (@vanished, %modified); - unless (defined $pcache->{UIDNEXT} and defined $pcache->{HIGHESTMODSEQ}) { - $self->{_MODIFIED} = {}; - $self->{_VANISHED} = []; - } - else { - $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") - if $full and $pcache->{UIDNEXT} > 1; - - my @missing; - while (%{$self->{_MODIFIED}}) { - 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 - if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH - next unless $uid < $pcache->{UIDNEXT} # out of bounds - and ($full or $v->[0] > $pcache->{HIGHESTMODSEQ}); # already seen - $modified{$uid} = $full ? $v : $v->[1]; - } else { - push @missing, $uid; - } + my %modified; + $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") + if $full and ($pcache->{UIDNEXT} // 1) > 1; + + my @missing; + while (%{$self->{_MODIFIED}}) { + 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 + 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 + $modified{$uid} = $full ? $v : $v->[1]; + } else { + push @missing, $uid; } - $self->{_MODIFIED} = {}; - $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; - @missing = (); } + $self->{_MODIFIED} = {}; + $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; + @missing = (); + } - # do that afterwards since the UID FETCH command above can produce VANISHED responses - my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; - @vanished = keys %vanished; - $self->{_VANISHED} = []; + # do that afterwards since the UID FETCH command above can produce VANISHED responses + my %vanished = map {$_ => 1} grep { $_ < ($pcache->{UIDNEXT} // 1) } @{$self->{_VANISHED}}; + my @vanished = keys %vanished; + $self->{_VANISHED} = []; - # ignore FLAG updates on VANISHED messages - delete @modified{@vanished}; - } + # ignore FLAG updates on VANISHED messages + delete @modified{@vanished}; # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT # since there might be new messages) @@ -915,36 +910,43 @@ sub pull_new_messages($$@) { my $attrs = join ' ', qw/MODSEQ FLAGS INTERNALDATE/, @attrs, 'BODY.PEEK[]'; my $mailbox = $self->{_SELECTED} // $self->panic(); - my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; - - my $range = ''; - my $first; - foreach my $uid (@ignore) { - if ($since < $uid) { - $first //= $since; - $range .= ',' if $range ne ''; - $range .= $since; - $range .= ':'.($uid-1) if $since < $uid-1; - $since = $uid+1; - } - elsif ($since == $uid) { - $since++; - } - } - - $first //= $since; - $range .= ',' if $range ne ''; - # 2^32-1: don't use '*' since the highest UID can be known already - $range .= "$since:4294967295"; - - my $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT}; - $self->panic() unless defined $UIDNEXT and $UIDNEXT > 0; # sanity check - $self->_send("UID FETCH $range ($attrs)", $callback) if $first < $UIDNEXT;; + my $UIDNEXT; + do { + my $range = ''; + my $first; + my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} // 1; + foreach my $uid (@ignore) { + if ($since < $uid) { + $first //= $since; + $range .= ',' if $range ne ''; + $range .= $since; + $range .= ':'.($uid-1) if $since < $uid-1; + $since = $uid+1; + } + elsif ($since == $uid) { + $since++; + } + } - # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ - # since there might be pending updates) - $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{UIDNEXT}); + $first //= $since; + $range .= ',' if $range ne ''; + # 2^32-1: don't use '*' since the highest UID can be known already + $range .= "$since:4294967295"; + + $UIDNEXT = $self->{_CACHE}->{$mailbox}->{UIDNEXT} // $self->panic(); # sanity check + $self->_send("UID FETCH $range ($attrs)", sub($) { + my $mail = shift; + $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID}; + $callback->($mail) if defined $callback; + }) if $first < $UIDNEXT; + + # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ + # since there might be pending updates) + $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); + } + # loop if new messages were received in the meantime + while ($UIDNEXT < $self->{_CACHE}->{$mailbox}->{UIDNEXT}); } @@ -963,7 +965,7 @@ sub push_flag_updates($$@) { my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; my %listed; - $self->_send($command, sub(%) { my %mail = @_; $listed{$mail{UID}}++; }); + $self->_send($command, sub($){ $listed{shift->{UID}}++; }); my %failed; if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { @@ -1211,10 +1213,10 @@ sub _select_or_examine($$$) { $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " ."1:".($pcache->{UIDNEXT}-1)."))" if $self->_enabled('QRESYNC') and - ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 0) > 1; + ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1; if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { - # A mailbox is currently selected and the server advertizes + # A mailbox is currently selected and the server advertises # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox # selection until the [CLOSED] response code has been received: # all responses before the [CLOSED] response code refer to the @@ -1394,6 +1396,9 @@ sub _resp($$;$$$) { if (s/\A\* //) { if (s/\ABYE //) { + foreach (qw/STDIN STDOUT/) { + $self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened(); + } exit 0; } elsif (s/\A(?:OK|NO|BAD) //) { @@ -1456,7 +1461,7 @@ sub _resp($$;$$$) { # always present, cf RFC 3501 section 6.4.8 $mail{UID} = $1; # the actual UIDNEXT is *at least* that - $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} < $1; + $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} <= $1; } if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC # always present in unsolicited FETCH responses if QRESYNC has been enabled @@ -1487,7 +1492,7 @@ sub _resp($$;$$$) { 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 in_set($uid, $set); } elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE $self->{_ENABLED} //= []; @@ -1502,15 +1507,13 @@ sub _resp($$;$$$) { if (/\A([0-9]+)\z/) { $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that - push @{$self->{_VANISHED}}, $1 - if defined $pcache->{UIDNEXT} and $1 < $pcache->{UIDNEXT}; + push @{$self->{_VANISHED}}, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that - push @{$self->{_VANISHED}}, grep {$_ < $pcache->{UIDNEXT}} ($min .. $max) - if defined $pcache->{UIDNEXT}; + push @{$self->{_VANISHED}}, ($min .. $max); } } } |