package Log::Dispatch::CronoDir;
use 5.008001;
use strict;
use warnings;
use parent qw(Log::Dispatch::Output);
our $VERSION = "0.06";
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,
optional => 1,
},
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});
if (defined $self->{_permissions}) {
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__
=encoding utf-8
=head1 NAME
Log::Dispatch::CronoDir - Log dispatcher for logging to time-based directories
=head1 SYNOPSIS
use Log::Dispatch::CronoDir;
my $log = Log::Dispatch::CronoDir->new(
dirname_pattern => '/var/log/%Y/%m/%d',
permissions => 0777,
filename => 'output.log',
mode => '>>:unix',
binmode => ':utf8',
autoflush => 1,
);
# Write log to file `/var/log/2000/01/01/output.log`
$log->log(level => 'error', message => 'Something has happened');
=head1 DESCRIPTION
Log::Dispatch::CronoDir is a file log dispatcher with time-based directory management.
=head1 METHODS
=head2 new(Hash %args)
Creates an instance. Accepted hash keys are:
=over 4
=item dirname_pattern => Str
Directory name pattern where log files to be written to.
POSIX strftime's conversion characters C<%Y>, C<%m>, and C<%d> are currently accepted.
=item permissions => Octal
Directory permissions when specified directory does not exist. Optional.
When not specified, creating directory's permissions are based on current umask.
Note that this won't work on Windows OS.
=item filename => Str
Log file name to be written in the directory.
=item mode => Str
Mode to be used when opening a file handle. Default: ">>"
=item binmode => Str
Binmode to specify with C<binmode>. Optional. Default: None
=item autoflush => Bool
Enable or disable autoflush. Default: 1
=back
=head2 log(Hash %args)
Writes log to file.
=over 4
=item level => Str
Log level.
=item message => Str
A message to write to log file.
=back
=head1 SEE ALSO
L<Log::Dispatch>
=head1 LICENSE
Copyright (C) yowcow.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
yowcow E<lt>yowcow@cpan.orgE<gt>
=cut