aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2016-03-07 16:01:51 +0100
committerGuilhem Moulin <guilhem@fripost.org>2016-03-07 16:21:07 +0100
commit247cc63d7710e1907b114a75125c27de946415aa (patch)
tree30d31ff9298b092196661f5dd717d48b8ce2ad6f
parent5d8b7a1bef1c1bb1a4efaeff9398f0ed81cb59b1 (diff)
Add an option "purge-after" to remove old messages.
-rw-r--r--lib/Net/IMAP/InterIMAP.pm24
-rwxr-xr-xpullimap31
2 files changed, 51 insertions, 4 deletions
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/) {
diff --git a/pullimap b/pullimap
index cca0ee8..7e737f2 100755
--- a/pullimap
+++ b/pullimap
@@ -62,6 +62,7 @@ my $CONF = read_config( delete $CONFIG{config} // $NAME,
, 'deliver-method' => qr/\A((?:[ls]mtp:)?\[.*\](?::\d+)?)\z/
, 'deliver-ehlo' => qr/\A(\P{Control}+)\z/
, 'deliver-rcpt' => qr/\A(\P{Control}+)\z/
+ , 'purge-after' => qr/\A(\d+)d\z/
)->{$ARGV[0]};
my ($MAILBOX, $STATE);
@@ -220,6 +221,34 @@ sub smtp_send(@) {
$CONF->{'logger-fd'} = \*STDERR if $CONFIG{debug};
my $IMAP = Net::IMAP::InterIMAP::->new( %$CONF, %CONFIG{qw/quiet debug/} );
+# Remove messages with UID < UIDNEXT and INTERNALDATE at most
+# $CONF->{'purge-after'} days ago.
+my $LAST_PURGED;
+sub purge() {
+ my $days = $CONF->{'purge-after'} // return;
+ $days =~ s/d$//;
+ my ($uidnext) = $IMAP->get_cache('UIDNEXT');
+ return unless 1<$uidnext;
+ my $set = "1:".($uidnext-1);
+
+ my $now = time;
+ return if defined $LAST_PURGED and $now - $LAST_PURGED < 6*3600;
+ $LAST_PURGED = $now;
+
+ unless ($days == 0) {
+ my @now = gmtime($now - $days*86400);
+ my @m = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; # RFC 3501's date-month
+ my $date = sprintf("%02d-%s-%04d", $now[3], $m[$now[4]], $now[5]+1900);
+ my @uid = $IMAP->search("UID $set BEFORE $date");
+ return unless @uid;
+
+ $set = compact_set(@uid);
+ $IMAP->log("Removing ".($#uid+1)." UID(s) $set") unless $CONFIG{quiet};
+ }
+ $IMAP->silent_store($set, '+', '\Deleted');
+ $IMAP->expunge($set);
+}
+
# Use BODY.PEEK[] so if something gets wrong, unpulled messages
# won't be marked as \Seen in the mailbox
my $ATTRS = "ENVELOPE INTERNALDATE BODY.PEEK[]";
@@ -288,6 +317,7 @@ do {
}
}
pull($ignore);
+ purge();
};
exit 0 unless defined $CONFIG{idle};
@@ -295,4 +325,5 @@ $CONFIG{idle} = 1740 if defined $CONFIG{idle} and $CONFIG{idle} == 0; # 29 mins
while(1) {
my $r = $IMAP->idle($CONFIG{idle}, sub() { $IMAP->has_new_mails($MAILBOX) });
pull() if $r;
+ purge();
}