mail-expire 0.7 / usr / bin / mail-expire

#!/usr/bin/perl

# SEE DEBIAN CHANGELOG FOR NEWER ENTRIES

# mail-expire, Version 0.2; Fri, 16 Aug 2002 11:39:10 +0200
# Copyright: Eduard Bloch <blade@debian.org>
#
# This file 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. The full text of GPL can be
# found on http://www.gnu.org or in /usr/share/common-licenses/GPL on
# modern Debian systems.
#
# ----------------------------------------------------------
# If you make changes to this script, please forward the new 
# version to <blade@debian.org> or <eduard@bloch.com>
# ----------------------------------------------------------
# 
# REQUIRED PACKAGES:
#
# libcompress-zlib-perl - Perl module for creation of gzip files 
# libdate-calc-perl - Perl library for accessing dates
# 
# Changes by Johannes Kolb:
#  * use Date::Calc instead of Date::Manip to increase performance
#  * no buffering of whole mailbox-files in memory
#
# Changes by Florian Krohs <krohs@uni.de>
#  * append old mails to mailbox.month_year.gz
#  * added zlib to free some space:]
#
# Changes by Eduard Bloch <blade@debian.org>
#  * small hack to vary the output filename to prevent overwritting
#  * some cosmetics, fixed typos
#  * dropped silly size comparison, trust return values of syswrite

use strict;

my $target="./";

sub help {
    die "Usage: $0 [ options ] DAYS FILES
    where
    DAYS is an integer specifying the maximum age of a mail in days and
    FILES one or more mbox file(s).

    Options:
    -u        choose different filenames if the target file already exists
    --delete  drops the old messages. Be warned, no backup will be made!
    -t DIR    new target directory DIR

";
}

use Getopt::Long qw(:config no_ignore_case bundling pass_through);
my $uoption=0;
my $deloption=0;
my $help;

my %opts = (
    "t=s", \$target, 
    "delete", \$deloption,
    "help|h", \$help,
    "u", \$uoption
);

&help if !GetOptions(%opts);
&help if $help;
my $days=shift(@ARGV);
die "Please specify a valid day count!\n" if abs($days)<1;
die "Please specify mbox file names!\n" if ! @ARGV;
for(@ARGV) { 
    die "Unable to read $_\n" if not -r $_
};

use Date::Calc qw(Parse_Date Today Delta_Days);
use Compress::Zlib ;
use Fcntl;
use Mail::Mbox::MessageParser;

my $c=-1;
my @today = Today();
my $old_all = localtime(time - $days * 86400);
$old_all =~ s/\ +/\ /g;
my @splitdate=split(/\ /,$old_all);
my $olddate=$splitdate[1] . "_" . $splitdate[4] . ".gz";

JOB: 
foreach my $filename (@ARGV) {
    my @st;
    my @time;
    my $c;

    my $oldsize = (stat($filename))[7];
    if ($oldsize == 0) {
        syswrite(STDOUT,"Empty file $filename, skipping.");
        next JOB;
    };

    if(-e "$filename.new")
    { 
        syswrite(STDOUT,"Temporary file $filename.new already exists, skipping $filename.\n");
        next JOB;
    };

    if(!open(fh,$filename)) {
        syswrite(STDOUT,"$filename could not be opened, skipping");
        next JOB;
    };
    if(flock(fh,2|4)){
        # lock when not locked already by another process
        flock(fh,2) || die "unexpected trouble on locking $filename";
    } else {
        # skip file
        close(fh);
        syswrite(STDOUT,"$filename is locked by an other prozess, skipping.");
        next JOB;
    };

    my $file_handle = new FileHandle($filename);
    my $folder_reader = new Mail::Mbox::MessageParser( {
            'file_name' => $filename,
            'file_handle' => $file_handle,
            'enable_cache' => 0
        } );

     #die "he? ".ref($folder_reader);
    #die ref($folder_reader);
    if (ref($folder_reader) ne "Mail::Mbox::MessageParser::Grep" && ref($folder_reader) ne "Mail::Mbox::MessageParser::Perl" ) {
        syswrite STDERR, "Unable to parse contents of $filename, skipping.\n";
        next JOB;
    }

    sysopen(neu,"$filename.new", O_RDWR|O_EXCL|O_CREAT) || die "Error creating temporary file, move $filename.new out of the way";
    my $gzfilename="$target/$filename".".$olddate";

    while(-s $gzfilename && $uoption)
    {
        my $modnumber += 0; # to preset a value
        $gzfilename="$target/$filename.".$splitdate[1] . "($modnumber)_" . $splitdate[4] . ".gz";;
        $modnumber++;
    }

    my $gzfile_ist_neu=1 if(!-e $gzfilename);
    my $alt;

    if(!$deloption) {
        $alt = gzopen($gzfilename, "ab") 
            or die "cannot open file: $gzerrno\n";
    }
    syswrite (STDOUT,"I: Reading and splitting $filename ($oldsize bytes)...\n");
    syswrite(STDOUT, "I: Analyzing ages (days before expiration): ");
    my $alte=0;
    my $neue=0;

    while(!$folder_reader->end_of_file())
    {
        my $email = $folder_reader->read_next_email();
        my $isold;

        $$email=~/^From\s\S+\s+(.*)/m;
        my $date=$1;
        #syswrite (STDERR, "hm, $1\n");

        if($1) {
            $c++;
            my @maildate = Parse_Date($date);
            @maildate = (1970,1,1) if scalar @maildate ==0;
            my $diff = Delta_Days(@maildate,@today);
            if ($#maildate != 2) {
                # mail header broken
                $neue++;
                syswrite(STDOUT, "(new: date could not be parsed!), ");
            }
            else
            # mail okay
            {
                syswrite(STDOUT, $diff);
                if ($diff > $days) {
                    $isold = 1;
                    $alte++;
                    syswrite(STDOUT, "(old), ");
                }
                else {
                    $neue++;
                    syswrite(STDOUT, "(new), ");
                }
            }
        }
        if ($isold) {
            if(!$deloption) {
                $alt->gzwrite($$email) 
                    or die "error writing to gz buffer : $gzerrno\n";
            }

        } else {
            defined(syswrite(neu, $$email)) || die "Failure while writting - disc full?";
        }
    }

    $alt->gzclose if(!$deloption);
    flock(fh, 8);
    close(fh);
    close(neu);

    #die  "ohje";
    if($alte==0 && $gzfile_ist_neu==1 && !$deloption)
    {
        unlink($gzfilename)|| die "failed - removed gzip file [empty]\n";
    }

    if( ($alte+$neue) < 1) {
        syswrite STDOUT, "No changes, ignoring file\n";
        next JOB;
    }

    my $newsize = (stat($gzfilename))[7];

    # no longer interessting, beautify it
    $gzfilename=~s!^\.//?!!;

    syswrite (STDOUT,"\n\nI: Wrote $neue new entries to $filename.new\n") if(!$deloption);
    syswrite (STDOUT,"\nI: Wrote $alte old entries to $gzfilename\n");

    syswrite (STDOUT,"Deleting $filename... ");
    unlink($filename) || die "failed while deleting original mbox";
    syswrite (STDOUT,"replacing with the new mailbox... ");
    rename("$filename.new", $filename) || die "failed";
    syswrite (STDOUT,"done");
#    syswrite (STDOUT," (saved $diff bytes)") if(!$deloption);
    syswrite (STDOUT,".\n");
    if(-e "$filename.new"){unlink("$filename.new") || die "Could not remove temporary file... Odd things happen!";}
}