]> git.donarmstrong.com Git - bin.git/blob - mailbox_deduplicate
add common subscriber
[bin.git] / mailbox_deduplicate
1 #!/usr/bin/perl
2 # mailbox_deduplicate Deduplicates mail boxes by moving or deleting
3 # and is released under the terms of the GNU GPL version 3, or any
4 # later version, at your option. See the file README and COPYING for
5 # more information.
6 # Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
7
8
9 use warnings;
10 use strict;
11
12 use Getopt::Long;
13 use Pod::Usage;
14
15 use File::Copy;
16 use IO::Dir;
17 use IO::File;
18
19 =head1 NAME
20
21 mailbox_deduplicate - Deduplicates mail boxes by moving or deleting
22
23 =head1 SYNOPSIS
24
25 mailbox_deduplicate [options] [mailboxes]
26
27  Options:
28   --move-to Target to move mail (Default .duplicated)
29   --delete Delete mail instead of moving it
30   --simulate, -n Don't actually do anything
31   --debug, -d debugging level (Default 0)
32   --help, -h display this help
33   --man, -m display manual
34
35 =head1 OPTIONS
36
37 =over
38
39 =item B<--move-to>
40
41 Mail box to move duplicate mail to. Defaults to .duplicated
42
43 =item B<--delete>
44
45 Delete duplicate mail instead of moving it.
46
47 =item B<--debug, -d>
48
49 Debug verbosity. (Default 0)
50
51 =item B<--help, -h>
52
53 Display brief usage information.
54
55 =item B<--man, -m>
56
57 Display this manual.
58
59 =back
60
61 =head1 EXAMPLES
62
63 mailbox_deduplicate
64
65 =cut
66
67
68 use vars qw($DEBUG);
69
70 my %options = (debug           => 0,
71                help            => 0,
72                man             => 0,
73                simulate        => 0,
74                move_to         => '.duplicated',
75                );
76
77 GetOptions(\%options,
78            'simulate|n!',
79            'move_to|move-to=s',
80            'delete',
81            'debug|d+','help|h|?','man|m');
82
83 pod2usage() if $options{help};
84 pod2usage({verbose=>2}) if $options{man};
85
86 $DEBUG = $options{debug};
87
88 my @USAGE_ERRORS;
89 if (0) {
90     push @USAGE_ERRORS,"You must pass something";
91 }
92
93 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
94
95
96 if (not @ARGV) {
97     push @ARGV,'.';
98 }
99
100 my %messages;
101 for my $mb (@ARGV) {
102     if (not -d $mb) {
103         print STDERR "No directory named '$mb'\n";
104         exit 1;
105     }
106     for my $nc (qw(new cur)) {
107         if (not -d "$mb/$nc") {
108             print STDERR "This probably isn't a mailbox; no '$nc' directory inside\n";
109             exit 1;
110         }
111         my $dir = IO::Dir->new("$mb/$nc") or
112             die "Unable to open directory '$mb/$nc' for reading: $!";
113         my $message;
114         while (defined ($message = $dir->read())) {
115             my $msg_id = get_message_id("$mb/$nc/$message");
116             if (not defined $msg_id) {
117                 print STDERR "No message id for $mb/$nc/$message\n" if $DEBUG;
118                 next;
119             }
120             print STDERR "$mb/$nc/$message is $msg_id\n" if $DEBUG;
121             push @{$messages{$msg_id}},"$mb/$nc/$message";
122         }
123     }
124 }
125
126 # handle duplicated messages
127 if (not $options{delete}) {
128     for my $dir ('','/new','/cur') {
129         if (not -d $options{move_to}.$dir) {
130             mkdir($options{move_to}.$dir) or
131                 die "Unable to make directory $options{move_to}.$dir";
132         }
133     }
134 }
135 for my $msg_id (keys %messages) {
136     # if there is only one message with this message id, do nothing.
137     next unless @{$messages{$msg_id}} > 1;
138     # otherwise, we need to remove or move the message to the
139     # duplicate folder
140     for my $i (1..$#{$messages{$msg_id}}) {
141         my ($nc) = $messages{$msg_id}[$i] =~ /(new|cur)/;
142         $nc //= 'new';
143         if ($options{delete}) {
144             if ($options{simulate} or $options{verbose}) {
145                 print "rm $messages{$msg_id}[$i] (duplicate of $msg_id $messages{$msg_id}[0])\n";
146             }
147             if (not $options{simulate}) {
148                 unlink($messages{$msg_id}[$i]) or
149                     die "Unable to unlink message $messages{$msg_id}[$i]";
150             }
151         } else {
152             if ($options{simulate} or $options{verbose}) {
153                 print "mv $messages{$msg_id}[$i] $options{move_to}/$nc/. (duplicate of $msg_id $messages{$msg_id}[0])\n";
154             }
155             if (not $options{simulate}) {
156                 move($messages{$msg_id}[$i],
157                      "$options{move_to}/$nc/."
158                     ) or die "Unable to move message $messages{$msg_id}[$i]";
159             }
160         }
161     }
162 }
163
164 sub get_message_id{
165     my ($message) = @_;
166
167     my $fh = IO::File->new($message,'r') or
168         die "Unable to open $message for reading: $!";
169     my $msg_id;
170     while (<$fh>) {
171         chomp;
172         if (/^$/) {
173             last;
174         }
175         if (/^Message-Id:\s+(<?)(\S+)\1/i) {
176             $msg_id = $2;
177             last;
178         }
179     }
180     close($fh);
181     return $msg_id;
182 }
183
184
185 __END__