This runs though my Maildir and puts old mail into a .archive mailbox to make the main mailbox access faster.

cleanup_maildirs.pl

#!/usr/bin/perl
# $Id: cleanup_maildirs,v 1.27 2011/02/22 00:36:24 andrew Exp $
# Copyright (c) 2013 Andrew Fresh <[email protected]>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
use strict;
use warnings;

use 5.010;

use Email::Date;

use File::Spec;
use File::Path qw/ make_path remove_tree /;
use File::Copy qw/ mv /;

my $Min_Tot_Messages   = 3;
my $Max_Cur_Messages   = 1000;
my $Min_Cur_Age        = 30 * 24 * 60 * 60;    # 1 month
my $Min_Dir_Age        = 7 * 24 * 60 * 60;     # 1 week
my $Archive_Dir_Suffix = '.archive';

my @Skip_Dirs = (
    qr/\/\.Drafts\b/, qr/\/\.Trash\b/,
    qr/\/\.Sent\b/, #qr/\/\.saved\b/,
                    #qr/\/\.personal\.friends\./, qr/\/\.work\.people\./,
                    #qr/\/\.misc\.[^\.]+$/,       qr/\/\.lists.newsletters\./,
);

my @Skip_Files = ( qr/^dovecot.*/, );

my @Maildir_Subs      = qw(new cur tmp);
my $Mailbox_Separator = '.';

my $Now = time;

my $Start_Dir = shift || '.';
$Start_Dir =~ s/[\\\/]$//;

push @Skip_Dirs, qr/^$Start_Dir$/;

search_dir($Start_Dir);

sub search_dir {
    my ( $dir, $siblings ) = @_;

    opendir my $d, $dir or die "Couldn't opendir $dir";
    my @files = grep { !/^\.\.?$/ } readdir $d;
    closedir $d;

    if ( !@files ) {
        my $age = ( stat($dir) )[9];
        remove($dir) if ( $Now - $age ) > $Min_Dir_Age;
        return;
    }

    my %count = ();

    my @dirs;
FILE: foreach my $f ( sort @files ) {
        next FILE if $f ~~ @Maildir_Subs;
        next FILE if $f ~~ @Skip_Files;

        if ( -d "$dir/$f" ) {
            $siblings->{"$dir/$f"} = q{};
            push @dirs, "$dir/$f";
        }
        else {
            $count{msc}++;
        }
    }
    $count{tot} = $count{msc};

    search_dir( $_, $siblings ) foreach reverse sort @dirs;

    return if $dir ~~ @Skip_Dirs;

    @files = ();

    $count{msg} = 0;
DIR: foreach my $s (@Maildir_Subs) {
        $count{$s} = 0;
        next DIR unless ( -d "$dir/$s" );

        opendir my $d, "$dir/$s" || die "Couldn't opendir '$dir/$s': $!";
        my @f = grep { -f "$dir/$_" } map { "$s/$_" } readdir $d;
        closedir $d;

        $count{$s} = scalar @f;
        $count{msg} += $count{$s};

        push @files, @f;
    }

    if (   exists $count{cur}
        && $count{cur} > $Max_Cur_Messages
        && $dir !~ /$Archive_Dir_Suffix$/ )
    {
        print "Archiving old messages ($count{cur}) \n",
            "\tin $dir \n\tto $dir$Archive_Dir_Suffix\n";
        my $archived = archive($dir);
        print "\tDone. Moved $archived.\n";

        $count{$_} -= $archived for qw( cur msg );
    }

    $count{tot} += $count{msg};

    if ( $count{msg} && $count{msg} < $Min_Tot_Messages ) {
        my $diff = 0;

        if (!$count{new}) {
            my $date = 0;
            foreach my $file (@files) {
                my $d = read_date( "$dir/$file" );
                $date = $d->epoch if $d && $d->epoch > $date;
            }

            if ($date) {
                $diff = $Now - $date;
            }
        }

        if ( $diff > $Min_Cur_Age ) {
            my $newdir = $dir;
            $newdir =~ s/\.[^\.]+$//;
            if ($dir eq $newdir) {
                $newdir =~ s{/[^/]+$}{};
            }
            if ($dir eq $newdir) {
                warn "Cannot move $dir up\n";
                return;
            }

            add($newdir) if !-d $newdir;

            say "move $dir contents up to $newdir";
            for (@files) {
                move_message("$dir/$_", "$newdir/$_") or return;
                $count{msg}--;
                $count{tot}--;
            }

        }
        else {
            print "Only $count{msg} message";
            print 's' if $count{msg} != 1;
            print " in $dir\n";
        }
    }

    if ( $count{msg} == 0 && !has_subdirs( $dir, $siblings ) ) {
        print "Removing empty $dir\n";
        remove($dir);
        delete $siblings->{$dir};
        return 1;
    }
    check_parent_dirs( $dir, $siblings );
}

sub archive {
    my ($dir) = @_;

    my $archive_dir = $dir . $Archive_Dir_Suffix;

    my $archived = 0;
    opendir my $d, "$dir/cur" or die "Couldn't opendir $dir: $!";
FILE: foreach my $file ( readdir $d ) {
        next FILE if $file =~ /^\.\.?$/;

        my $date = read_date("$dir/cur/$file");
        my $diff = 0;
        if ($date) {
            $diff = $Now - $date->epoch;
        }

        if ( $diff > $Min_Cur_Age ) {
            add($archive_dir);

            move_message("$dir/cur/$file", "$archive_dir/cur/$file") 
                || next FILE;
            $archived++;

            #print "moving ", $file, "\t";
            #print $date->ymd('.'), "\t";
            #print $diff, "\n";
        }
    }
    closedir $d;

    return $archived;
}

sub move_message {
    my ($src, $dst) = @_;

    if ( -e $dst ) {
        warn "$src already exists in $dst!\n";
        return;
    }

    return mv( $src, $dst ) or die "Couldn't mv $src to $dst: $!";
}

sub remove {
    my ($dir) = @_;

    foreach my $d (@Maildir_Subs) {
        if ( !-d "$dir/$d" ) {
            warn "$dir is not a Maildir, not removing\n";
            return;
        }
    }

    opendir my $d, $dir or die "Couldn't opendir $dir: $!";
    while (my $f = readdir $d) {
        next if $f =~ /^\.\.?$/;
        next if $f ~~ @Skip_Files;
        next if $f ~~ @Maildir_Subs;

        warn "Strange file in Maildir [$dir/$f], not removing\n";
        closedir $d;
        return;
    }
    closedir $d;
    
    remove_tree($dir, { verbose => 1 } ) or die "Couldn't remove $dir: $!";

    return 1;
}

sub check_parent_dirs {
    my ( $dir, $dirs ) = @_;

    #return unless $dirs;

    my (@curdirs) = File::Spec->splitdir($dir);
    my $name = pop @curdirs;
    my @parts = split /\Q$Mailbox_Separator\E/xms, $name;

PART: while ( pop @parts ) {

        my $subname = join $Mailbox_Separator, @parts;
        my $subdir = File::Spec->catdir( @curdirs, $subname );

        next PART if ( exists $dirs->{$subdir} || -d $subdir );

        if ( add($subdir) ) {
            $dirs->{$subdir} = 'added';
        }
    }

    return 1;
}

sub add {
    my ($dir) = @_;

    print "Creating Maildir [$dir]\n" if !-e $dir;

    if (make_path( ( map { File::Spec->catdir( $dir, $_ ) } @Maildir_Subs ) ),
        { verbose => 1, mode => 0777 }
        )
    {
        return 1;
    }
    else {
        print "Error creating Maildir [$dir]\n";
        return;
    }
}

sub has_subdirs {
    my ( $dir, $dirs ) = @_;

    return 1 if grep {/^\Q$dir$Mailbox_Separator\E/xms} keys %{$dirs};
}

sub read_date {
    my ($file) = @_;

    open my $f, '<', $file or die "Couldn't open $file: $!";
    my $email = do { local $/; <$f> };
    close $f;

    return find_date($email);
}