#!/usr/bin/perl -w

/*
    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

use Date::Parse; 
use Date::Format;
use File::Basename;
use Mail::Header;
use Getopt::Long;
use Pod::Usage;

use strict;

# This script archives emails (sent through ARGV) that were sent > 15
# days ago into a folder named $YEAR.q$QUARTER.$CURRENTFOLDERNAME (so,
# for example, .New.bugs will be archived to .2005.Q2.bugs, if
# that email was sent in Q2.

my $man = 0;
my $help = 0;
my $dry_run = 0;
my $verbose = 1;
my $maildir = "$ENV{HOME}/Maildir";
my $archive_format = "%Y.Q%q";
my $maxage_days = 15;

GetOptions('help|?|h' => \$help, 
	   'man' => \$man,
	   'dry-run|n' => \$dry_run,
	   'verbose|v' => \$verbose,
	   'archive-format=s' => \$archive_format,
	   'maildir=s' => \$maildir,
	   'max-age=i' => \$maxage_days,
	   ) or pod2usage(2);

pod2usage(1) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $man;
pod2usage(2) if (! -d $maildir);
pod2usage(2) if ($#ARGV == -1);

my $maxage = $maxage_days * 24 * 60 * 60;

my $now = time();

foreach my $path (@ARGV) {
    open(FH, "< $path") || die "can't open $path: $!";
    my $head = new Mail::Header [<FH>], Modify => 0;
    my $date = $head->get("Date");
    if ($date) {
        my $message_time = str2time($date);
        if ($message_time && $maxage + $message_time < $now) {
            my $archivePrefix = time2str($archive_format, $message_time);
	    # Maildir format is always "Maildir/.something/cur/actual.msg"
            my $folder = basename(dirname(dirname($path)));
	    $folder =~ s/^\.new(\.)?/$1/i;
	    $folder =~ s/Maildir//i;
            my $archiveFolder = $archivePrefix.$folder;
            print "$path > $archiveFolder\n" if $verbose;
            if (! -d $maildir."/.".$archiveFolder && !$dry_run) {
                system("maildirmake -f $archiveFolder $maildir") == 0 || die "Failed to make Maildir folder $archiveFolder in $maildir: $!";
            }
            my $newpath = $maildir."/.".$archiveFolder."/cur/".basename($path);
            rename($path, $newpath) if (!$dry_run);
        }
    } 
}

__END__

=head1 NAME

autoarchive - Tool to inspect a qmail-style Maildir, moving email in a
given set of folders that are older than some set time into a archival
folder for posterity.

=head1 SYNOPSIS

autoarchive [OPTION]... path-to-email...

=head1 OPTIONS

=over 8

=item B<--archive-format>

A date format string. See Date::Parse. Defaults to "%Y.Q%q" ("2005.Q2", for example)

=item B<--maildir>

The Maildir to put the archive emails into. Defaults to "~/Maildir".

=item B<--max-age>

The maximum time (in days) that an email can age before it should be archived.

=item B<--dry-run, -n>

Show what would have been done, but don't modify the filesystem.

=item B<--help, -h>

Print a brief help message and exits.

=item B<--man>

Prints the manual page and exits.

=back

=head1 DESCRIPTION

B<This program> will read the given input file(s) and do someting
useful with the contents thereof.

=cut