Windows環境でApacheの古いログを圧縮する

Linuxとは違いlogrotateのような便利なツールがないWindows環境でApacheの古くなったログを圧縮するには一工夫が必要です。

ActivePerlをインストールした環境では次のようなスクリプトを書いて、適当なフォルダに保存してタスクスケジューラで一日に一回実行させれば古いログは圧縮されて別のフォルダに残ります。

下記のコードではC:\Program Files\Apache Group\Apache2\logsにたまったaccess.log.2008-03-22のような形式でローテーションされたログファイルを圧縮してC:\Program Files\Apache Group\Apache2\ziplogsに保存しています

#! C:/perl/bin/perl

use Archive::Zip;
use DirHandle;
use File::Copy;
use Cwd;

my $access_pattern = 'access\.log\.[0-9]{4}-[0-9]{2}-[0-9]{2}';
my $error_pattern = 'error\.log\.[0-9]{4}-[0-9]{2}-[0-9]{2}';

my $lastmodified_time;
my $current_time = time();
my $difference_time;
my $base_dir = getcwd;
my $from, $to;

&zip_logs('C:\Program Files\Apache Group\Apache2\logs', 'C:\Program Files\Apache Group\Apache2\ziplogs', $access_pattern);
&zip_logs('C:\Program Files\Apache Group\Apache2\logs', 'C:\Program Files\Apache Group\Apache2\ziplogs', $error_pattern);

#zip
sub zip_logs {
    my ($original_dir, $zip_dir, $pattern) = @_;  
    $original_dir = trim($original_dir);
    if (-d $original_dir) {
        my $original_dir_handle = new DirHandle $original_dir;
        if (-d trim($zip_dir)) {
            $zip_dir = trim($zip_dir);
        } else {
            $zip_dir = $original_dir; 
        }
        @file_list = $original_dir_handle->read;
        $original_dir_handle->close;

        foreach my $file_name (sort @file_list) {
            if ($file_name =~ $pattern) {
                $lastmodified_time = (stat $file_name)[9];
                $difference_time = $current_time - $lastmodified_time;
                if ($difference_time > 86400) {
                    my $zip = Archive::Zip->new();
                    $zip->addFile("$original_dir" . "\\" . "$file_name");
                    !$zip->writeToFileNamed("$zip_dir" . "\\" . "$file_name" . ".zip")  or die "Cannot zip $file_name:$!";
                    my $zip_file_name = "$file_name" . ".zip";
                    unlink "$original_dir" . "\\" . "$file_name" or die "Cannot delete $file_name";
                }
            }   
        }    
    }   
}

sub trim {
    my $val = shift;
    $val =~ s/^ *(.*?) *$/$1/;
    return $val;
}