Add awm

git-svn-id: svn+ssh://asteria.noreply.org/svn/weaselutils/trunk@550 bc3d92e2-beff-0310-a7cd-cc87d7ac0ede

1 files changed, 235 insertions, 0 deletions

diff --git a/awm b/awm
new file mode 100755
index 0000000..0f89936
--- /dev/null
+++ b/awm
@@ -0,0 +1,235 @@
+#!/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) = $received =~ /;([^;]+)$/ if defined $received;
+	my $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: