Add an option "purge-after" to remove old messages.

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();
 }