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.pm76
1 files changed, 49 insertions, 27 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index db6f484..2821f98 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -214,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($%) {
@@ -753,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)");
@@ -785,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 (@_) {
@@ -801,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);
@@ -870,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[].
@@ -1075,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();
@@ -1398,7 +1400,8 @@ sub _send($$;&) {
while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
my ($str, $len) = ($1, $2);
- my $lit = substr $command, 0, $len, ''; # consume the literal
+ my $lit = substr $command, 0, $len, ''; # consume the literal
+ my $bin = substr($str,-1) eq '~' ? 1 : 0; # literal8, RFC 3516 BINARY
$litplus //= $self->_capable('LITERAL+') ? '+' : '';
push @command, $self->_z_deflate($str, "{$len$litplus}", "\r\n");
@@ -1412,15 +1415,26 @@ sub _send($$;&) {
$x =~ /\A\+ / or $self->panic($x);
@command = ();
}
- if ($len <= 4096) {
- push @command, $self->_z_deflate($lit);
- } else {
- # send a Z_FULL_FLUSH at the start and end of large literals,
- # as hinted at in RFC 4978 section 4
- # TODO only do that for non-text literals
- push @command, $self->_z_flush(Z_FULL_FLUSH);
+ if ($len > 4096 and (!$self->{'use-binary'} or $bin) and defined (my $d = $self->{_Z_DEFLATE})) {
+ my ($status, $buf);
+ # send a Z_FULL_FLUSH at the start and end of large non-text
+ # literals, as hinted at in RFC 4978 section 4
+ $status = $d->flush($buf, Z_FULL_FLUSH);
+ $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+ push @command, $buf if $buf ne '';
+
+ undef $buf;
+ $status = $d->deflate($lit, $buf);
+ $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
+ push @command, $buf if $buf ne '';
+
+ undef $buf;
+ $status = $d->flush($buf, Z_FULL_FLUSH);
+ $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+ push @command, $buf if $buf ne '';
+ }
+ else {
push @command, $self->_z_deflate($lit);
- push @command, $self->_z_flush(Z_FULL_FLUSH);
}
}
push @command, $self->_z_deflate($command, "\r\n");
@@ -1779,6 +1793,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 ] : [];
}
@@ -1788,7 +1810,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};
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-05 12:26:40 +0000