CentOS LAMP 環境の courier maildir フォルダスクリプト

結局、何の反応もなく、問題を解決する手がかりも多くありませんでした。

私は現在、すべてのアカウントを通過して30日後のメッセージを次の構造のフォルダに移動するPerlスクリプトを使用しています。

/home/account/domain.com/mail/mailbox/.00 ライブラリー Inbox.2012.08 8 月 /home/account/domain.com/mail/mailbox/.00 ライブラリー Sent.2012.08 8月

#!/usr/bin/perl
# encoding: utf-8
#

use strict;
use warnings;

use User::pwent;
use POSIX qw( strftime );
use YAML::Any qw( LoadFile );
use File::Copy;
use File::Basename;
use File::Spec::Functions;

our $USER    = q(the-account-user-name);
our $LIMIT   = 100000;
our $AGE     = 30;
our $STAGGER = 1;

our $PW      = getpwnam( $USER );
our $UID     = $PW->uid;
our $GID     = $PW->gid;
our $HOME    = $PW->dir;
our $ERRORS  = 0;
our $NOW     = time;

$AGE and $AGE *= 24 * 60 * 60;

our $stored_list = LoadFile( "$HOME/.archived-emails" );
our @EMAILS = @$stored_list;


sub shell_escape {
  my $token = shift;
  if ( length( $token ) == 0 ) { return "''"; }
  $token =~ s/([^A-Za-z0-9_\-\.,:\/@\n])/\\$1/g;
  $token =~ s/\n/'\n'/g;
  return $token;
}
sub folder_to_dir {
  my ( $base, $folder ) = @_;

  if ( $folder eq "INBOX" ) {
    return $base;
  } else {
    $folder =~ s/^INBOX(?=\.)//;
    return catfile( $base, $folder );
  }
}

sub email_to_dir {
  my ( $address ) = @_;

  my ( $mail_user, $domain ) = split( /@/, $address, 2 );
  return "$HOME/mail/$domain/$mail_user";
}

sub create_mail_dir {
  my ( $base, $name ) = @_;
  my $full = "$base/.$name";
  unless ( -d "$full/cur" ) {
    system( "/usr/lib/courier-imap/bin/maildirmake", '-f', $name, $base );
    chown $UID, $GID, "$base/.$name", glob( "$base/.$name/*" );
  }
  return $full;
}


sub subscribe {
  my ( $base, @names ) = @_;
  my $subscribed = "$base/courierimapsubscribed";

  my %folder_set = map { $_ => 1 } map { "INBOX.$_" } @names;
  my $f;

 if ( -f $subscribed ) {
    open $f, "< $subscribed";
    while ( <$f> ) {
      chomp;
      /^\s*$/ and next;
      s(^\s+|\s+$)()g;
      $folder_set{$_} = 1;
    }
    close $f;
  }

  open( $f, "> $subscribed" );
  for my $folder_name ( sort keys %folder_set ) {
    print $f "$folder_name\n";
  }
  close $f;

  chown $UID, $GID, $subscribed;
  chmod 0644, $subscribed;
}


sub archive {
  my ( $email, @folders ) = @_;
  my $root = email_to_dir $email;

  unless ( -d $root ) {
    print "$email: Skipping as it does not appear to be an existing e-mail\n";
    $ERRORS++;
    return;
  }

  print "$email: Archiving\n";
  for my $folder_name ( @folders ) {
#   print "folder_name $folder_name \n";

    my $archive = $folder_name eq "INBOX.Sent" ? "00 Archive Sent" : "00 Archive $folder_name" || $folder_name eq "INBOX" ? "00 Archive Inbox" : "00 Archive $folder_name";
    my $dir     = folder_to_dir( $root, $folder_name );

 if ( -d "$dir/cur" ) {
      my %subscribed   = ( "$archive" => 1 );
      my $archive_base = create_mail_dir $root, $archive;

      my @targets = grep { -d } map { "$dir/$_" } qw( cur new );
      my $find_cmd = join( ' ', map { shell_escape( $_ ) } ( "find", @targets, "-type", 'f' ) );

      my @files;
      for ( `$find_cmd` ) {
        chomp;

        my $file = basename( $_ );
        if ( $file =~ /^(\d+)\./ ) {
          my $timestamp = 0 + $1;
          my $path      = $_;

          push @files, [ $timestamp, $path ];
        }
      }

      if ( @files ) {
        my ( @move_list, @stay_list );
        @files     = sort { $b->[ 0 ] <=> $a->[ 0 ] } @files;
        @stay_list = @files;

        if ( $LIMIT and @stay_list > $LIMIT ) {
          @move_list = @stay_list[ $LIMIT ... $#stay_list ];
          @stay_list = @stay_list[ 0 ... $LIMIT - 1 ];
        }

        if ( $AGE ) {
          AGE_LOOP:
            while ( @stay_list ) {
              my $oldest_entry = $stay_list[ $#stay_list ];
              if ( $NOW - $oldest_entry->[ 0 ] > $AGE ) {
                push @move_list, pop( @stay_list );
              } else {
                last AGE_LOOP;
                            }
            }
        }

        for my $entry ( @move_list ) {
          my ( $timestamp, $path ) = @$entry;
          my $archive_path;

          if ( $STAGGER ) {
            my $date         = strftime( "%Y.%m %B", localtime( $timestamp ) );
            $archive_path    = create_mail_dir( $root, "$archive.$date" );
            $subscribed{"$archive.$date"} = 1;
          } else {
            $archive_path = $archive_base;
          }
          move( $path, "$archive_path/cur" ) or warn( $! );
#   print "archive path $archive_path \n";
        }

        my $c = scalar @move_list;
        print "  - $folder_name: moved \e[32m$c\e[0m messages to archive folders\n";
      } else {
        print "  - $folder_name: found no messages to archive\n";
      }

      if ( my @subs = keys %subscribed ) {
        subscribe $root, @subs;
      }

    } else {
      print "  - $folder_name: skipping as this does not appear to be a valid mail folder\n";
    }
  }
}


for my $email ( @EMAILS ) {
  archive $email, "INBOX", "INBOX.Sent";
}

exit $ERRORS;

このスクリプトで私が気に入らない唯一のことは、移動したメールのctime（UNIX epoch時間）を現在の時刻に変更することです。少なくともmtimeは変更されていません。