Imported Upstream version 1.09
This commit is contained in:
Mario Fetka
328
lib/Log/Dispatch/File/Rolling.pm
Executable file
328
lib/Log/Dispatch/File/Rolling.pm
Executable file
@@ -0,0 +1,328 @@
|
||||
## no critic
|
||||
package Log::Dispatch::File::Rolling;
|
||||
|
||||
use 5.006001;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Log::Dispatch::File '2.37';
|
||||
use Log::Log4perl::DateFormat;
|
||||
use Fcntl ':flock'; # import LOCK_* constants
|
||||
|
||||
our @ISA = qw(Log::Dispatch::File);
|
||||
|
||||
our $VERSION = '1.09';
|
||||
|
||||
our $TIME_HIRES_AVAILABLE = undef;
|
||||
|
||||
BEGIN { # borrowed from Log::Log4perl::Layout::PatternLayout, Thanks!
|
||||
# Check if we've got Time::HiRes. If not, don't make a big fuss,
|
||||
# just set a flag so we know later on that we can't have fine-grained
|
||||
# time stamps
|
||||
|
||||
eval { require Time::HiRes; };
|
||||
if ($@) {
|
||||
$TIME_HIRES_AVAILABLE = 0;
|
||||
} else {
|
||||
$TIME_HIRES_AVAILABLE = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Preloaded methods go here.
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
|
||||
my %p = @_;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
|
||||
# only append mode is supported
|
||||
$p{mode} = 'append';
|
||||
|
||||
# base class initialization
|
||||
$self->_basic_init(%p);
|
||||
|
||||
# split pathname into path, basename, extension
|
||||
if ($p{filename} =~ /^(.*)\%d\{([^\}]*)\}(.*)$/) {
|
||||
$self->{rolling_filename_prefix} = $1;
|
||||
$self->{rolling_filename_postfix} = $3;
|
||||
$self->{rolling_filename_format} = Log::Log4perl::DateFormat->new($2);
|
||||
$self->{filename} = $self->_createFilename();
|
||||
} elsif ($p{filename} =~ /^(.*)(\.[^\.]+)$/) {
|
||||
$self->{rolling_filename_prefix} = $1;
|
||||
$self->{rolling_filename_postfix} = $2;
|
||||
$self->{rolling_filename_format} = Log::Log4perl::DateFormat->new('-yyyy-MM-dd');
|
||||
$self->{filename} = $self->_createFilename();
|
||||
} else {
|
||||
$self->{rolling_filename_prefix} = $p{filename};
|
||||
$self->{rolling_filename_postfix} = '';
|
||||
$self->{rolling_filename_format} = Log::Log4perl::DateFormat->new('.yyyy-MM-dd');
|
||||
$self->{filename} = $self->_createFilename();
|
||||
}
|
||||
|
||||
$self->{rolling_fh_pid} = $$;
|
||||
$self->_make_handle();
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub log_message { # parts borrowed from Log::Dispatch::FileRotate, Thanks!
|
||||
my $self = shift;
|
||||
my %p = @_;
|
||||
|
||||
my $filename = $self->_createFilename();
|
||||
if ($filename ne $self->{filename}) {
|
||||
$self->{filename} = $filename;
|
||||
$self->{rolling_fh_pid} = 'x'; # force reopen
|
||||
}
|
||||
|
||||
if ( $self->{close} ) {
|
||||
$self->_open_file;
|
||||
$self->_lock();
|
||||
my $fh = $self->{fh};
|
||||
print $fh $p{message};
|
||||
$self->_unlock();
|
||||
close($fh);
|
||||
$self->{fh} = undef;
|
||||
} elsif (defined $self->{fh} and ($self->{rolling_fh_pid}||'') eq $$ and defined fileno $self->{fh}) { # flock won't work after a fork()
|
||||
my $inode = (stat($self->{fh}))[1]; # get real inode
|
||||
my $finode = (stat($self->{filename}))[1]; # Stat the name for comparision
|
||||
if(!defined($finode) || $inode != $finode) { # Oops someone moved things on us. So just reopen our log
|
||||
$self->_open_file;
|
||||
}
|
||||
$self->_lock();
|
||||
my $fh = $self->{fh};
|
||||
print $fh $p{message};
|
||||
$self->_unlock();
|
||||
} else {
|
||||
$self->{rolling_fh_pid} = $$;
|
||||
$self->_open_file;
|
||||
$self->_lock();
|
||||
my $fh = $self->{fh};
|
||||
print $fh $p{message};
|
||||
$self->_unlock();
|
||||
}
|
||||
}
|
||||
|
||||
sub _lock { # borrowed from Log::Dispatch::FileRotate, Thanks!
|
||||
my $self = shift;
|
||||
flock($self->{fh},LOCK_EX);
|
||||
# Make sure we are at the EOF
|
||||
seek($self->{fh}, 0, 2);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _unlock { # borrowed from Log::Dispatch::FileRotate, Thanks!
|
||||
my $self = shift;
|
||||
flock($self->{fh},LOCK_UN);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _current_time { # borrowed from Log::Log4perl::Layout::PatternLayout, Thanks!
|
||||
# Return secs and optionally msecs if we have Time::HiRes
|
||||
if($TIME_HIRES_AVAILABLE) {
|
||||
return (Time::HiRes::gettimeofday());
|
||||
} else {
|
||||
return (time(), 0);
|
||||
}
|
||||
}
|
||||
|
||||
sub _createFilename {
|
||||
my $self = shift;
|
||||
return $self->{rolling_filename_prefix}
|
||||
. $self->_format()
|
||||
. $self->{rolling_filename_postfix};
|
||||
}
|
||||
|
||||
sub _format {
|
||||
my $self = shift;
|
||||
my $result = $self->{rolling_filename_format}->format($self->_current_time());
|
||||
$result =~ s/(\$+)/sprintf('%0'.length($1).'.'.length($1).'u', $$)/eg;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=for changes stop
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Log::Dispatch::File::Rolling - Object for logging to date/time/pid
|
||||
stamped files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Log::Dispatch::File::Rolling;
|
||||
|
||||
my $file = Log::Dispatch::File::Rolling->new(
|
||||
name => 'file1',
|
||||
min_level => 'info',
|
||||
filename => 'Somefile%d{yyyyMMdd}.log',
|
||||
mode => 'append' );
|
||||
|
||||
$file->log( level => 'emerg',
|
||||
message => "I've fallen and I can't get up\n" );
|
||||
|
||||
=head1 ABSTRACT
|
||||
|
||||
This module provides an object for logging to files under the
|
||||
Log::Dispatch::* system.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module subclasses Log::Dispatch::File for logging to date/time
|
||||
stamped files. See L<Log::Dispatch::File> for instructions on usage.
|
||||
This module differs only on the following three points:
|
||||
|
||||
=over 4
|
||||
|
||||
=item fork()-safe
|
||||
|
||||
This module will close and re-open the logfile after a fork.
|
||||
|
||||
=item multitasking-safe
|
||||
|
||||
This module uses flock() to lock the file while writing to it.
|
||||
|
||||
=item stamped filenames
|
||||
|
||||
This module supports a special tag in the filename that will expand to
|
||||
the current date/time/pid.
|
||||
|
||||
It is the same tag Log::Log4perl::Layout::PatternLayout uses, see
|
||||
L<Log::Log4perl::Layout::PatternLayout>, chapter "Fine-tune the date".
|
||||
In short: Include a "%d{...}" in the filename where "..." is a format
|
||||
string according to the SimpleDateFormat in the Java World
|
||||
(http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.html).
|
||||
See also L<Log::Log4perl::DateFormat> for information about further
|
||||
restrictions.
|
||||
|
||||
In addition to the format provided by Log::Log4perl::DateFormat this
|
||||
module also supports '$' for inserting the PID. Repeat the character to
|
||||
define how many character wide the field should be. This should not be
|
||||
needed regularly as this module also supports logfile sharing between
|
||||
processes, but if you've got a high load on your logfile or a system
|
||||
that doesn't support flock()...
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item new()
|
||||
|
||||
See L<Log::Dispatch::File> and chapter DESCRIPTION above.
|
||||
|
||||
=item log_message()
|
||||
|
||||
See L<Log::Dispatch::File> and chapter DESCRIPTION above.
|
||||
|
||||
=back
|
||||
|
||||
=for changes continue
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over 8
|
||||
|
||||
=item 0.99
|
||||
|
||||
Original version; created by h2xs 1.22 with options
|
||||
|
||||
-A
|
||||
-C
|
||||
-X
|
||||
-b5.6.1
|
||||
-nLog::Dispatch::File::Rolling
|
||||
--skip-exporter
|
||||
-v0.99
|
||||
|
||||
=item 1.00
|
||||
|
||||
Initial coding
|
||||
|
||||
=item 1.01
|
||||
|
||||
Someone once said "Never feed them after midnight!"---Ok, let's append:
|
||||
"Never submit any code after midnight..."
|
||||
|
||||
Now it is working, I also included 4 tests.
|
||||
|
||||
=item 1.02
|
||||
|
||||
No code change, just updated Makefile.PL to include correct author
|
||||
information and prerequisites.
|
||||
|
||||
=item 1.03
|
||||
|
||||
Changed the syntax of the '$' format character because I noticed some
|
||||
problems while making Log::Dispatch::File::Alerts. You need to change
|
||||
your configuration!
|
||||
|
||||
=item 1.04
|
||||
|
||||
Got a bug report where the file handle got closed in mid-execution somehow.
|
||||
Added a additional check to re-open it instead of writing to a closed
|
||||
handle.
|
||||
|
||||
=item 1.05
|
||||
|
||||
Updated packaging for newer standards. No changes to the coding.
|
||||
|
||||
=item 1.06
|
||||
|
||||
Fixed a subtle bug that prevented us from locking the logfile after a fork if no
|
||||
PID was used in the filename.
|
||||
|
||||
Also disabled forced double opening of the logfile at startup. It was in place
|
||||
because I didn't trust L<Log::Dispatch::File> to really open the file at the
|
||||
right moment.
|
||||
|
||||
Thanks to Peter Lobsinger for the patch. Please always wrap non-standard Test::*
|
||||
modules in eval and make your testfile clean up after itself... ;)
|
||||
|
||||
=item 1.07
|
||||
|
||||
Fixed rt.cpan.org bug #89001. Seems L<Log::Dispatch::File> changed its
|
||||
initialization procedure---and we are inheriting from it.
|
||||
|
||||
=item 1.08
|
||||
|
||||
Fixed dependency on L<Log::Dispatch::File>. The change in 1.07 only works with
|
||||
2.37 or later. For older versions of L<Log::Dispatch::File> use 1.06.
|
||||
|
||||
=item 1.09
|
||||
|
||||
Dependency change of 1.08 was missing from the Makefile.PL. Oops.
|
||||
|
||||
=back
|
||||
|
||||
=for changes stop
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Log::Dispatch::File>, L<Log::Log4perl::Layout::PatternLayout>,
|
||||
http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.html,
|
||||
L<Log::Log4perl::DateFormat>, 'perldoc -f flock', 'perldoc -f fork'.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
M. Jacob, E<lt>jacob@j-e-b.netE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2003, 2004, 2007, 2010, 2013 M. Jacob E<lt>jacob@j-e-b.netE<gt>
|
||||
|
||||
Based on:
|
||||
|
||||
Log::Dispatch::File::Stamped by Eric Cholet <cholet@logilune.com>
|
||||
Log::Dispatch::FileRotate by Mark Pfeiffer, <markpf@mlp-consulting.com.au>
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user