File Coverage

blib/lib/Log/Dispatch/CronoDir.pm

Criterion	Covered	Total	%
statement	72	72	100.0
branch	17	22	77.2
condition	8	12	66.6
subroutine	14	14	100.0
pod	1	2	50.0
total	112	122	91.8

package Log::Dispatch::CronoDir;
use 5.008001;
use strict;
use warnings;
use parent qw(Log::Dispatch::Output);

our $VERSION = "0.04";

use File::Path qw(make_path);
use Params::Validate qw(validate SCALAR BOOLEAN);
use Scalar::Util qw(openhandle);

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

sub new {
    my ($proto, %args) = @_;
    my $class = ref $proto || $proto;
    my $self = bless {}, $class;
    $self->_basic_init(%args);
    $self->_init(%args);
    $self;
}

sub _init {
    my $self = shift;
    my %args = validate(
        @_,
        {   dirname_pattern => { type => SCALAR },
            permissions     => {
                type    => SCALAR,
                default => 0755,
            },
            filename => { type => SCALAR },
            mode     => {
                type    => SCALAR,
                default => '>>',
            },
            binmode => {
                type     => SCALAR,
                optional => 1,
            },
            autoflush => {
                type    => BOOLEAN,
                default => 1,
            },
        }
    );

    my @rules;
    $args{dirname_pattern} =~ s{ \% (\w) }{
        $1 eq 'Y' ? do {
            push @rules, { pos => 5, offset => 1900 };
            '%04d';
        } : $1 eq 'm' ? do {
            push @rules, { pos => 4, offset => 1 };
            '%02d';
        } : $1 eq 'd' ? do {
            push @rules, { pos => 3, offset => 0 };
            '%02d';
        } : '';
    }egx;

    $self->{_rules}           = \@rules;
    $self->{_dirname_pattern} = $args{dirname_pattern};
    $self->{_permissions}     = $args{permissions};
    $self->{_filename}        = $args{filename};
    $self->{_mode}            = $args{mode};
    $self->{_binmode}         = $args{binmode};
    $self->{_autoflush}       = $args{autoflush};

    $self->_get_current_fh;
}

sub _localtime { localtime }

sub _find_current_dir {
    my $self = shift;
    my @now  = _localtime();
    sprintf(
        $self->{_dirname_pattern},
        map { $now[ $_->{pos} ] + $_->{offset} } @{ $self->{_rules} },
    );
}

sub _get_current_fh {
    my $self    = shift;
    my $dirname = $self->_find_current_dir;

    if (!exists $self->{_current_dir} || $dirname ne $self->{_current_dir}) {
        close $self->{_current_fh}
            if $self->{_current_fh} and openhandle($self->{_current_fh});

        make_path $dirname;
        $self->{_current_dir} = $dirname;
        $self->{_current_filepath} = File::Spec->catfile($dirname, $self->{_filename});

        chmod $self->{_permissions}, $dirname
            or die "Failed chmod $dirname to $self->{_permissions}: $!";

        open my $fh, $self->{_mode}, $self->{_current_filepath}
            or die "Failed opening file $self->{current_filepath} to write: $!";

        binmode $fh, $self->{_binmode} if $self->{_binmode};

        do {
            my $oldfh = select $fh;
            $| = 1;
            select $oldfh;
        } if $self->{_autoflush};

        $self->{_current_fh} = $fh;
    }

    $self->{_current_fh};
}

sub log_message {
    my ($self, %args) = @_;
    print { $self->_get_current_fh } $args{message}
        or die "Cannot write to file $self->{_current_file}: $!";
}

sub DESTROY {
    my $self = shift;
    close $self->{_current_fh}
        if $self->{_current_fh} and openhandle($self->{_current_fh});
}

1;
__END__