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__