File Coverage

blib/lib/Log/Dispatch/Dir.pm

Criterion	Covered	Total	%
statement	122	131	93.1
branch	32	42	76.1
condition	22	29	75.8
subroutine	15	15	100.0
pod	2	2	100.0
total	193	219	88.1

package Log::Dispatch::Dir;

our $DATE = '2015-12-16'; # DATE
our $VERSION = '0.14'; # VERSION

use 5.010001;
use warnings;
use strict;
use Log::Dispatch::Output;
use base qw(Log::Dispatch::Output);

use File::Slurp::Tiny qw(write_file);
#use File::Stat qw(:stat); # doesn't work in all platforms?
use Params::Validate qw(validate SCALAR CODEREF);
use POSIX;

Params::Validate::validation_options( allow_extra => 1 );

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my %p = @_;

    my $self = bless {}, $class;

    $self->_basic_init(%p);
    $self->_make_handle(%p);

    return $self;
}

sub _make_handle {
    my $self = shift;

    my %p = validate(
        @_,
        {
            dirname             => { type => SCALAR },
            permissions         => { type => SCALAR , optional => 1 },
            filename_pattern    => { type => SCALAR , optional => 1 },
            filename_sub        => { type => CODEREF, optional => 1 },
            max_size            => { type => SCALAR , optional => 1 },
            max_files           => { type => SCALAR , optional => 1 },
            max_age             => { type => SCALAR , optional => 1 },
            rotate_probability  => { type => SCALAR , optional => 1 },
        });

    $self->{dirname}            = $p{dirname};
    $self->{permissions}        = $p{permissions};
    $self->{filename_pattern}   = $p{filename_pattern} ||
        '%Y-%m-%d-%H%M%S.pid-%{pid}.%{ext}';
    $self->{filename_sub}       = $p{filename_sub};
    $self->{max_size}           = $p{max_size};
    $self->{max_files}          = $p{max_files};
    $self->{max_age}            = $p{max_age};
    $self->{rotate_probability} = ($p{rotate_probability}) || 0.25;
    $self->_open_dir();
}

sub _open_dir {
    my $self = shift;

    unless (-e $self->{dirname}) {
        my $perm = $self->{permissions} // 0755;
        mkdir($self->{dirname}, $perm)
            or die "Cannot create directory `$self->{dirname}: $!";
        $self->{chmodded} = 1;
    }

    unless (-d $self->{dirname}) {
        die "$self->{dirname} is not a directory";
    }

    if ($self->{permissions} && ! $self->{chmodded}) {
        chmod $self->{permissions}, $self->{dirname}
            or die "Cannot chmod $self->{dirname} to $self->{permissions}: $!";
        $self->{chmodded} = 1;
    }
}

my $default_ext = "log";
my $libmagic;

sub _resolve_pattern {
    my ($self, $p) = @_;
    my $pat = $self->{filename_pattern};
    my $now = time;

    my @vars = qw(Y y m d H M S z Z %);
    my $strftime = POSIX::strftime(join("|", map {"%$_"} @vars),
                                   localtime($now));
    my %vars;
    my $i = 0;
    for (split /\|/, $strftime) {
        $vars{ $vars[$i] } = $_;
        $i++;
    }

    push @vars, "{pid}";
    $vars{"{pid}"} = $$;

    push @vars, "{ext}";
    $vars{"{ext}"} = sub {
        my $p = shift;
        unless (defined $libmagic) {
            if (eval { require File::LibMagic; require Media::Type::Simple }) {
                $libmagic = File::LibMagic->new;
            } else {
                print "err = $@\n";
                $libmagic = 0;
            }
        }
        return $default_ext unless $libmagic;
        my $type = $libmagic->checktype_contents($p->{message} // '');
        return $default_ext unless $type;
        $type =~ s/[; ].*//; # only get the mime type
        my $ext = Media::Type::Simple::ext_from_type($type);
        ($ext) = $ext =~ /(.+)/ if $ext; # untaint
        return $ext || $default_ext;
    };

    my $res = $pat;
    $res =~ s[%(\{\w+\}|\S)]
             [defined($vars{$1}) ?
                  ( ref($vars{$1}) eq 'CODE' ?
                        $vars{$1}->($p) : $vars{$1} ) :
                            die("Invalid filename_pattern `%$1'")]eg;
    $res;
}

sub log_message {
    my $self = shift;
    my %p = @_;

    my $filename0 = defined($self->{filename_sub}) ?
        $self->{filename_sub}->(%p) :
        $self->_resolve_pattern(\%p);

    my $filename = $filename0;
    my $i = 0;
    while (-e "$self->{dirname}/$filename") {
        $i++;
        $filename = "$filename0.$i";
    }

    write_file("$self->{dirname}/$filename", $p{message});
    $self->_rotate(\%p) if (rand() < $self->{rotate_probability});
}

sub _rotate {
    my ($self, $p) = @_;

    my $ms = $self->{max_size};
    my $mf = $self->{max_files};
    my $ma = $self->{max_age};

    return unless (defined($ms) || defined($mf) || defined($ma));

    my @entries;
    my $d = $self->{dirname};
    my $now = time;
    local *DH;
    opendir DH, $self->{dirname};
    while (my $e = readdir DH) {
        ($e) = $e =~ /(.*)/s; # untaint
        next if $e eq '.' || $e eq '..';
        my @st = stat "$d/$e";
        push @entries, {name => $e, age => ($now-$st[10]), size => $st[7]};
    }
    closedir DH;

    @entries = sort {$a->{age} <=> $b->{age}} @entries;

    # max files
    if (defined($mf) && @entries > $mf) {
        unlink "$d/$_->{name}" for (splice @entries, $mf);
    }

    # max age
    if (defined($ma)) {
        my $i = 0;
        for (@entries) {
            if ($_->{age} > $ma) {
                unlink "$d/$_->{name}" for (splice @entries, $i);
                last;
            }
            $i++;
        }
    }

    # max size
    if (defined($ms)) {
        my $i = 0;
        my $tot_size = 0;
        for (@entries) {
            $tot_size += $_->{size};
            if ($tot_size > $ms) {
                unlink "$d/$_->{name}" for (splice @entries, $i);
                last;
            }
            $i++;
        }
    }
}

1;
# ABSTRACT: Log messages to separate files in a directory, with rotate options

__END__