#!/usr/bin/perl -w # awm - Archive Weasel's Mail # # Copyright (C) 2002 Peter Palfrader # # 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 [B<--help>] =item B [B<--quiet>] [B<--verbose> [B<--verbose>]] [B<--older=>I] B<--base=>I [I [I ...]] =back =head1 DESCRIPTION B is a simple mail archiver for MailDir style mail folders. It moves mails older than the specified time to I.I folders where I 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 as well as all subfolders (Maildirs in the same directory as I 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 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 Specify the base of B's operation. Example: C<--base=$(HOME)/Maildir>. =item B<--older>=I 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 for reognised formats. =back =head1 AUTHOR Peter Palfrader Epeter@palfrader.orgE =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 = ; 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=] --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: