diff options
| -rwxr-xr-x | awm | 235 |
1 files changed, 235 insertions, 0 deletions
@@ -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: |