#!/usr/bin/perl
#-----------------------------------------------------------------------------
#
#  POPular -- A POP3 server and proxy for large mail systems
#
#  $Id: expire,v 1.3 2001/02/09 15:59:07 sqrt Exp $
#
#  http://www.remote.org/jochen/mail/popular/
#
#-----------------------------------------------------------------------------
#
#  Expire for mailboxes.
#
#-----------------------------------------------------------------------------
#
#  Copyright (C) 1999-2001  Jochen Topf <jochen@remote.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
#
#-----------------------------------------------------------------------------

use strict;

my $POPDIR    = "/pop";		# Directory where all the mailboxes are
my $DEBUG     = 1;		# Debug output

# Expiretime (in days) for each namespace. There must be a special "namespace"
# called "OLD", which contains the expire time for deleted mailboxes.
my %expire = ("OLD", 30,	# 1 month
              "example", 190);	# 6 month + grace period

#-----------------------------------------------------------------------------

my $time = time();

# Depending on the directory layout, you have to change this. This calls
# scandir($dir) for every directory where there are mailboxes. This version
# uses a two-level directory hierarchy like this: 1/23/mailboxname=namespace/
foreach my $h (0x0 .. 0xf) {
  foreach my $d (0x00 .. 0xff) {
    my $dir = sprintf("%x/%02x", $h, $d);
    print STDERR "$dir\n" if ($DEBUG);
    scandir($dir);
  }
}

exit 0;


#-----------------------------------------------------------------------------
#
#  scandir($dir)
#
#  Changes current directory into $dir, scans it for mailbox dirs, and calls
#  expiremailbox() for each.
#
#-----------------------------------------------------------------------------
sub scandir {
  my ($dir) = @_;
  my ($name, $ns, $expire);

  chdir("$POPDIR/$dir") or die("Can't chdir to $POPDIR/$dir: $!\n");

  # read directory, skip dot-files
  opendir(DIR, ".") or die("Can't scan dir $dir: $!\n");
  my @files = grep(!/^\./, readdir(DIR));
  closedir(DIR);

  foreach my $file (@files) {
    if ($file =~ /_\d{8}\.\d{6}$/) {
      $ns = "OLD";
    } else {
      ($name, $ns) = split(/=/, $file);
    }
    if ($expire{$ns}) {
      $expire = $expire{$ns};
    } else {
      print STDERR "No expire for namespace of mailbox $file\n";
    }
    print "$dir/$file ($ns, $expire)\n" if ($DEBUG);
    expiremailbox($file, $ns, $expire * 60 * 60 * 24);
  }
}


#-----------------------------------------------------------------------------
#
#  expiremailbox($mailbox, $ns, $expire)
#
#  Expire all mails in mailbox $mailbox if they are older then $expire
#  seconds. $ns is the namespace or 'OLD' if the mailbox is deleted.
#
#-----------------------------------------------------------------------------
sub expiremailbox {
  my ($mailbox, $ns, $expire) = @_;

  opendir(DIR, "$mailbox/cur") or die("Can't opendir $mailbox/cur: $!\n");
  my @cur = grep(!/^\./, readdir(DIR));
  closedir(DIR);
   
  opendir(DIR, "$mailbox/new") or die("Can't opendir $mailbox/new: $!\n");
  my @new = grep(!/^\./, readdir(DIR));
  closedir(DIR);

  # Delete old mailboxes if they are empty
  if ($ns eq "OLD" && $#cur == -1 && $#new == -1) {
    rmdir("$mailbox/new") or print STDERR "Can't rmdir $mailbox/new: $!\n";
    rmdir("$mailbox/cur") or print STDERR "Can't rmdir $mailbox/cur: $!\n";
    rmdir("$mailbox/tmp") or print STDERR "Can't rmdir $mailbox/tmp: $!\n";
    rmdir("$mailbox")     or print STDERR "Can't rmdir $mailbox: $!\n";
    return;
  }

  # Now the old files are expired. All files with a name beginning with
  # "0QUOTA" are deleted, too. They are created by the "checksize" script
  # and contain a mail to warn the user, that his quota is exceeded or nearly
  # exceeded. A new "0QUOTA" mail is created each night, so we can just delete
  # it here.
  foreach my $file (@cur) {
    if ($file =~ /^0QUOTA/) {
      unlink("$mailbox/cur/$file")
    } else {
      expirefile("$mailbox/cur/$file", $expire);
    }
  }

  foreach my $file (@new) {
    if ($file =~ /^0QUOTA/) {
      unlink("$mailbox/new/$file")
    } else {
      expirefile("$mailbox/new/$file", $expire);
    }
  }
}


#-----------------------------------------------------------------------------
#
#  expirefile($file, $expire)
#
#  Unlink file $file if it is older then $expire seconds.
#
#-----------------------------------------------------------------------------
sub expirefile {
  my ($file, $expire) = @_;

  my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
	$blksize,$blocks) = stat($file);

  if ($time - $mtime > $expire) {
    unlink($file) or print STDERR "Can't unlink $file: $!\n";
    print " $file (", $time - $mtime, " $expire) EXPIRE\n" if ($DEBUG);
  }
}


#-- THE END ------------------------------------------------------------------