1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
#!/usr/bin/perl -w
# This program is free software. It comes without any warranty, to the
# extent permitted by applicable law. You can redistribute it and/or
# modify it under the terms of the Do What The Fuck You Want To Public
# License, Version 2, as published by Sam Hocevar.
# See http://sam.zoy.org/wtfpl/COPYING for more details.
use Pod::Usage;
use Mail::IMAPClient;
use IO::Socket::SSL;;
use File::Spec::Functions qw /catfile/;
use Env qw /HOME/;
use strict;
=head1 NAME
imapurge.pl - prune your email accounts
=head1 SYNOPSIS
B<imapurge.pl>
=head1 DESCRIPTION
B<IMAPurge> cleans up your accounts from B<old> B<seen> and B<unflagged> emails
that are B<not drafts>. It connects on the IMAP servers via SSL on port 993.
=head1 CONFIGURATION
B<IMAPurge> reads its configuration from the file I<$HOME/.imapurge.rc>.
This file has to be the content of a Perl hash e.g.,
account1 => {
hostname => 'imap.example.com',
username => 'username',
password => '******',
ignore => [ 'folder1', 'folder2' ],
only => [ 'folder3', 'folder4' ],
oldest => 90
},
account2 => {
...
}
The fields I<hostname>, I<username>, and I<password> are required, while
I<ignore>, I<only>, and I<oldest> are optional.
If you wish to to filter away some folders, you can fill in the field
I<ignore>. If on the other hand you want to only clean up some folders (hence
ignore all the others), you can fill in the field I<only>. The default
behavior is to explore all the folders on the server.
By setting the field I<oldest>, you can also define a time limit (in
days) for each account; Seen and unflagged emails that are not drafts
and have been sent before the given value (for the server's time!) will
be deleted. Default value: 90.
If the IMAP server you connect to implements the XLIST extension (such
as GMail), the folders you choose via the fields I<only> and I<ignore>
refer to either the alias or the actual folder names (C<Trash> versus
C<[Gmail]/Trash>) for instance).
On some IMAP servers, the messages marked as deleted and expunged are
not immediately deleted, but archived for instance. Check out your
settings then.
=head1 AUTHOR
Copyright 2011-2012 Guilhem Moulin. See the source for copying conditions.
=cut
if (@ARGV) {
pod2usage(-exitstatus => 0, -verbose => 2) if $ARGV[0] eq '--man';
pod2usage(2);
}
my $confile = catfile ($HOME, '.imapurge.rc');
die "Can't read `" .$confile. "'\n" unless -f $confile;
my %accounts = do $confile;
die "Error in `" .$confile. "'\n" if $@ || not %accounts;
# Remotely delete mails that have been sent >90 days ago
my $oldest = 90;
my $count = 0;
while (my ($account,$config) = each %accounts) {
my $n = &prune ($config);
print $account, ": ", $n, "\n";
$count += $n;
}
print "-----------\n";
print "Total: $count emails have been deleted.\n";
#######################################################################
# Prune the given account
sub prune {
my $config = $_[0];
# Create the SSL socket and login to the server
my $socket = IO::Socket::SSL->new(
PeerAddr => $config->{hostname},
PeerPort => 993,
) or die "Can't create SSL socket: $@\n";
my $client = Mail::IMAPClient->new(
Socket => $socket,
User => $config->{username},
Password => $config->{password},
SSL => 1,
Uid => 1,
) or die "Can't login: $@\n";
my $count = 0;
# I'll delete the emails that have a date < $maxdate (on the server)
my $maxdate = $oldest;
$maxdate = $config->{oldest} if exists $config->{oldest};
$maxdate *= 24 * 60 * 60; # Convert seconds to days
$maxdate = $client->Rfc3501_date(time-$maxdate);
# Browse in the folder list
my $folders = $client->xlist_folders;
my @folders;
if (defined $folders) {
# XLIST extension is implemented
@folders = map {$folders->{$_}} (keys %$folders);
}
else {
@folders = $client->folders or die "Can't list folders: $@\n";
}
foreach my $folder (@folders) {
# Filter on the (manually set) 'ignore' & 'only' lists
next if exists $config->{ignore}
&& grep {$_ eq $folder or (defined ($folders)
&& exists ($folders->{$_})
&& $folders->{$_} eq $folder)}
@{$config->{ignore}};
next if exists $config->{only}
&& not (grep {$_ eq $folder or (defined ($folders)
&& exists ($folders->{$_})
&& $folders->{$_} eq $folder)}
@{$config->{only}});
# Explore the folder
if ($client->select($folder)) {
# Search for the mail UIDs I'm gonna delete
my @msgs = $client->search( \( 'SENTBEFORE', $maxdate
, 'UNDRAFT'
, 'UNFLAGGED'
, 'SEEN' )
);
if (@msgs) {
my $del = $client->delete_message(\@msgs)
or die "Can't delete messages: $@\n";
warn " Folder `$folder': only $del/" .($#msgs+1).
" messages have been deleted.\n"
unless $del == $#msgs+1;
$count += $del;
}
else {
die "Can't search: $@\n" if $@;
}
# Unselect the folder & commit the changes on the server
$client->close($folder) or die "Can't close: $@\n";
}
}
# Logout
$client->disconnect();
die "Can't logout: $@\n" unless $client->IsUnconnected;
return $count;
}
|