#!/usr/bin/perl -w

# awm - Archive Weasel's Mail
#
#    Copyright (C) 2002 Peter Palfrader <peter@palfrader.org>
#
#    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 2 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, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

=pod

=head1 NAME

awm - Archive Weasel's Mail

=head1 SYNOPSIS

=over

=item B<awm> [B<--help>]

=item B<awm> [B<--quiet>] [B<--verbose> [B<--verbose>]] [B<--older=>I<date>] B<--base=>I<base> [I<folder> [I<folder> ...]]

=back

=head1 DESCRIPTION

B<awm> is a simple mail archiver for MailDir style mail folders. It moves mails
older than the specified time to I<folder>.I<yyyy.mm> folders where I<yyyy.mm>
is the date when the mail was received (last Received header) or sent (Date
header) if no Received header can be found.

It archives the Maildir folder I<base> as well as all subfolders (Maildirs in the
same directory as I<base> that name starts with a period (B<.>)).  If you list
one of more folders it will only archive them.

=head1 OPTIONS

=over

=item B<--verbose>

Verbose mode. Causes B<awm> to print debugging messages about its progress. May
be used more than once to increase verbosity.

=item B<--quiet>

Quiet mode. Be even more quient than normally (supress some warnings).

=item B<--help>

Print a short help and exit sucessfully.

=item B<--version>

Print version number and exit sucessfully.

=item B<--base>=I<base>

Specify the base of B<awm>'s operation. Example: C<--base=$(HOME)/Maildir>.

=item B<--older>=I<date>

Archive mails older than the specified date. Example: C<--older='-2 months'>
or C<--older='2002-01-01'>. Defaults to two months ago. See
C<Time::ParseDate(3)> for reognised formats.

=back

=head1 AUTHOR

Peter Palfrader E<lt>peter@palfrader.orgE<gt>

=head1 BUGS

Please report them to the author.

=cut

use strict;
use FindBin qw{ $Bin };
use Getopt::Long;
use Time::ParseDate;
use Mail::Internet;
use English;

my $VERBOSE = 0;
my $QUIET = 0;
my $VERSION = '0.0.1';
my $ARCHIVE_OLDER = '-2 months';
my $BASE;

sub make_target($$$) {
	my ($folder, $dir, $time) = @_;

	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($time);
	$folder .= sprintf(".%04d.%02d", $year+1900, $mon+1);
	$folder =~ s/^\.\././;
	unless (-d $folder) {
		for my $d ($folder, $folder.'/cur', $folder.'/new', $folder.'/tmp') {
			mkdir ($d) or
				warn ("$PROGRAM_NAME: Cannot mkdir $d: $!"),
				return undef;
		};
	};
	return $folder.'/'.$dir;
};

sub readfile($) {
	my ($file) = @_;
	open (F, $file) or
		warn("$PROGRAM_NAME: Cannot open $file: $!\n"),
		return undef;
	my @result = <F>;
	close (F) or
		warn("$PROGRAM_NAME: Cannot read $file: $!\n"),
		return undef;
	return \@result;
};

sub gettime($) {
	my ($file) = @_;
	my $maillines = readfile($file) or
		warn("$PROGRAM_NAME: Cannot read $file\n"),
		return undef;
	
	my $mail = new Mail::Internet($maillines);
	my $header = $mail->head();
	my $received = $header->get('Received', 0);
	my ($date, $time);
	($date) = $received =~ /;([^;]+)$/ if defined $received;
	$time = parsedate($date) if defined $date;
	unless (defined $time) {
		$QUIET or warn ("$PROGRAM_NAME: Falling back to date header in $file\n");
		$date = $header->get('Date');
		$time = parsedate($date) if defined $date;
		warn ("$PROGRAM_NAME: Cannot get time for mail $file\n"),
			return undef
			unless defined $time;
	};
	return $time;
};

sub archive_MailDir($$) {
	my ($older, $folder) = @_;
	for my $dir (qw{cur new}) {
		opendir(DIR, $folder.'/'.$dir);
		my @files = grep { ! /^\./ } readdir(DIR);
		closedir(DIR);

		for my $file (@files) {
			my $time = gettime($folder.'/'.$dir.'/'.$file) or
				warn("$PROGRAM_NAME: Cannot get time from $folder/$dir/$file\n"),
				next;
			my $date = gmtime($time);
			if ($time < $older) {
				my $target = make_target($folder, $dir, $time);
				warn ("$PROGRAM_NAME: Target not defined\n"), next unless defined $target;
				print "  Moving $folder/$dir/$file to $target/$file ($date)\n"
					if ($VERBOSE >= 2);
				link($folder.'/'.$dir.'/'.$file, $target.'/'.$file) or 
					warn ("$PROGRAM_NAME: Cannot move $folder/$dir/$file to $target/$file\n"),
					next;
				unlink($folder.'/'.$dir.'/'.$file) or
					warn ("$PROGRAM_NAME: Cannot unlink $folder/$dir/$file\n"),
					next;
			} else {
				print "  Not moving $folder/$dir/$file ($date)\n"
					if ($VERBOSE >= 2);
			};
		};
	};
};


my $HELP = 0;
my $PRINTVERSION = 0;


my $USAGE = "Usage: $PROGRAM_NAME [--help] [--quiet] [--verbose [--verbose]] [--older=<date>] --base=<base> [folder [folder]]\n";
Getopt::Long::config('bundling');
GetOptions (
	'--verbose+' => \$VERBOSE,
	'--quiet' => \$QUIET,
	'--base=s' => \$BASE,
	'--older=s' => \$ARCHIVE_OLDER,
	'--help' => \$HELP,
	'--version' => \$PRINTVERSION,
) &&
(defined $BASE) or
	die ($USAGE);
$HELP and
	print $USAGE,
	exit(0);
$PRINTVERSION and
	print "$PROGRAM_NAME version $VERSION",
	exit(0);
if ($ARCHIVE_OLDER =~ /[^0-9]/) {
	$ARCHIVE_OLDER = parsedate($ARCHIVE_OLDER, PREFER_PAST => 1, WHOLE => 1);
	die ("Cannot parse timestamp\n") unless defined $ARCHIVE_OLDER;
};


my @files;

chdir($BASE);
umask(0007);
if (scalar @ARGV) {
	@files = @ARGV
} else {
	opendir(DIR, '.');
	@files = grep { $_ ne '..' && $_ ne 'cur' && $_ ne 'new' && $_ ne 'tmp' && -d $_ && (! m/\.\d\d$/) } readdir(DIR);
	closedir(DIR);
};

for my $dir (@files) {
	print "Doing $dir\n"
		if ($VERBOSE >= 1);
	archive_MailDir($ARCHIVE_OLDER, $dir);
};


# vim:set ts=2:
# vim:set shiftwidth=2: