Log-Info/lib/Log/Info.pm
# (X)Emacs mode: -*- cperl -*-
package Log::Info;
=head1 NAME
Log::Info - Wrapper around Log::Log4perl
=head1 DESCRIPTION
This tool is now just a wrapper around Log::Log4perl. The author recommends
that you use that module instead; this module is maintained purely to provide
a migration path thereto.
All documentation for using Log::Info has been excised, except for that which
will aid migration.
=head1 SYNOPSIS
use Log::Info qw( :log_levels :default_channels Log Logf );
# The Log::Info default channels appear in Log::Log4perl as loggers called
# colon-lowercase-<channelname>, e.g., INFO appears as ':info'.
#
# note, use init, not init_once, since Log::Info has already called init
# if you have used :default_channels to auto-create the default channels
# (or else contrived to call Log() or Logf() already)
Log::Log4perl::init
(+{
'log4perl.rootLogger' => 'WARN, tempfile',
'log4perl.appender.tempfile' =>
'Log::Log4perl::Appender::File',
'log4perl.appender.tempfile.filename' => $tempfn,
'log4perl.appender.tempfile.layout' =>
'Log::Log4perl::Layout::PatternLayout',
'log4perl.appender.tempfile.layout.ConversionPattern' =>
'[%P:%p] %F >%c< - %m%n',
'log4perl.logger.:info' => 'INFO',
'log4perl.appender.:info' =>
'Log::Log4perl::Appender::Screen',
'log4perl.appender.:info.stderr' => 1,
'log4perl.appender.:info.layout' =>
'Log::Log4perl::Layout::PatternLayout',
'log4perl.appender.:info.layout.ConversionPattern' =>
'[%r] %F %L %c - %m%n',
});
# you can still call Log, Logf, in the old Log::Info style,
# just for migration...
Log(CHAN_INFO, LOG_ERR, 'this is an error message');
# ...but now you should use Log::Log4perl
Log::Log4perl->get_logger->warn('l1 warn');
# here we can even use the Log::Info
Log::Log4perl->get_logger(':info')->warn('l2 warn');
=cut
# ----------------------------------------------------------------------------
# Pragmas -----------------------------
use 5.10.0;
use strict;
use warnings;
# Inheritance -------------------------
use base qw( Exporter );
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
@EXPORT_OK = qw( $PACKAGE $VERSION );
}
# Utility -----------------------------
use Carp qw( carp croak );
use Env qw( @PATH );
use Fatal 1.02 qw( :void close open seek sysopen );
use Fcntl 1.03 qw( O_WRONLY O_APPEND O_CREAT O_EXCL );
use File::Spec::Functions 1.1 qw( catfile );
use FindBin 1.42 qw( $Script );
use IO::Handle 1.21 qw( );
use IO::Pipe 1.121 qw( );
use IO::Select 1.14 qw( );
use List::Util qw( min max );
use Log::Log4perl qw( );
use POSIX 1.03 qw( strftime );
use Sys::Syslog 0.01 qw( openlog closelog syslog setlogmask setlogsock );
use Log::Info::SubAppender qw( );
# can't use the full name of the RHS below with a ->{} form if the {} contain
# a $var because CVS tries to expand...
my $LOGGERS_BY_NAME = $Log::Log4perl::Logger::LOGGERS_BY_NAME;
# ----------------------------------------------------------------------------
# -------------------------------------
# PACKAGE VARS
# -------------------------------------
my %channel;
our $dying; # Set to one when calling within a caught 'die'
# -------------------------------------
# PACKAGE CONSTANTS
# -------------------------------------
use constant ETA_ACCURACY => 5; # Update progress bar at least this often (in
# seconds) to ensure ETA is up-to-date
use constant LOG_LEVELS => qw( LOG_EMERG LOG_ALERT LOG_CRIT LOG_ERR
LOG_WARNING LOG_NOTICE LOG_INFO
LOG_DEBUG );
# translate our levels to Log4perl
use Log::Log4perl::Level qw( );
use Log::Log4perl::Logger qw( );
BEGIN {
Log::Log4perl::Logger::create_custom_level('NOTICE', 'WARN');
Log::Log4perl::Level::add_priority('EMERG',
4 * Log::Log4perl::Level::to_priority('FATAL'),
);
Log::Log4perl::Level::add_priority('ALERT',
3 * Log::Log4perl::Level::to_priority('FATAL'),
1, 6,
);
Log::Log4perl::Level::add_priority('CRIT',
2 * Log::Log4perl::Level::to_priority('FATAL'),
);
}
# The following constants are available for use as arguments to the
# C<facility> attribute of the C<SYSLOG> sink type. All of these constants
# will be imported inidividually on request, or grouped together with the
# C<:syslog_facilities> tag.
use constant LOG_FACILITIES => qw( FTY_AUTHPRIV FTY_CRON
FTY_DAEMON FTY_LPR FTY_MAIL FTY_NEWS
FTY_SYSLOG FTY_USER FTY_UUCP
FTY_LOCAL0 FTY_LOCAL1 FTY_LOCAL2
FTY_LOCAL3 FTY_LOCAL4 FTY_LOCAL5
FTY_LOCAL6 FTY_LOCAL7
);
# here we translate LOG_ALL to LOG_DEBUG, for the sake of syslog which
# has no LOG_ALL.
use constant LOG_LEVEL => { LOG_ALL => Sys::Syslog::xlate('LOG_DEBUG'),
map { $_ => Sys::Syslog::xlate($_) }
LOG_LEVELS
};
use constant LOG_NAME => { reverse %{LOG_LEVEL()} };
use constant LOG4PERL_LEVELMAP => +{qw( LOG_EMERG EMERG
LOG_ALERT ALERT
LOG_CRIT FATAL
LOG_ERR ERROR
LOG_WARNING WARN
LOG_NOTICE NOTICE
LOG_INFO INFO
LOG_DEBUG DEBUG
LOG_ALL ALL
)};
use constant LOG4PERL_LEVELS => +{
map {; LOG_LEVEL->{$_} =>
Log::Log4perl::Level::to_priority(LOG4PERL_LEVELMAP->{$_}) }
LOG_LEVELS
};
# In ascending numeric order
use constant LOG_LEVEL_VALUES => sort { $a <=> $b } values %{LOG_LEVEL()};
BEGIN {
# Create constant subs for each log level (to export).
for (LOG_LEVELS, 'LOG_ALL') {
no strict 'refs';
*{join('::', __PACKAGE__, $_)} = eval "sub() { LOG_LEVEL->{$_} }";
}
# Create constant subs for each log facility (to export).
for (LOG_FACILITIES) {
no strict 'refs';
my $name = lc substr($_, 4);
*{join('::', __PACKAGE__, $_)} = sub { $name };
}
push @EXPORT, qw( Log Logf );
push @EXPORT_OK, LOG_LEVELS;
push @EXPORT_OK, LOG_FACILITIES;
$EXPORT_TAGS{log_levels} = [ LOG_LEVELS ];
$EXPORT_TAGS{syslog_facilities} = [ LOG_FACILITIES ];
}
sub __dump_levels{
my ($max) = sort { $b <=> $a } map length, LOG_LEVELS;
printf "%${max}s % 02d\n", $_, LOG_LEVEL->{$_}
for LOG_LEVELS;
}
# -------------------------------------
=head2 Default Channel (and Sink) Names
Each of the following channels exist by default, and have their channel level
set to C<undef>. Only L<CHAN_INFO|"CHAN_INFO"> has a sink by default; called
SINK_STDERR (a name exported with the C<:default_channels> tag), which is a
filehandle to STDERR, and is set at level L<LOG_WARNING|"LOG_WARNING">.
Each channel and sink name will be exported upon request, or together using
the C<:default_channels> tag.
=over 4
=item CHAN_PROGRESS
Intended for progress reports, e.g., C<done 1 of 3 files>, or C<20% through>.
Default level: LOG_WARNING
=item CHAN_DEBUG
Intended for debugging messages, such as those you might output with
C<--debug> flag on.
Default level: LOG_WARNING
=item CHAN_STATS
Intended for output of statistical information; e.g., C<found 300 items> or
C<output file is 30M, parsing took 79s>.
Default level: LOG_WARNING
=item CHAN_INFO
Intended for warning and error messages, and those that would be output by
C<-v>.
Messages that would be used with C<warn> should be logged at level
L<LOG_WARNING|"LOG_WARNING">, those for a C<-v> flag with level
L<LOG_INFO|"LOG_INFO"> (and C<LOG_DEBUG|"LOG_DEBUG"> for increased verbosity).
C<die> messages should be logged at C<LOG_ERR|"LOG_ERR"> level.
L<LOG_EMERG|"LOG_EMERG"> should be reserved for conditions detected which have
a significant, time-critical effect on the operating system as a whole (e.g.,
anything which will cause the operating system to hang or crash).
L<LOG_ALERT|"LOG_ALERT"> should be used for conditions which may affect the
correct operation of the operating system, but will not cause the system to
fail (e.g., detected filesystem faults).
L<LOG_CRIT|"LOG_CRIT"> should be used to indicate that some problem has been
identified that is likely to adversely affect the correct operation of a
system (other than the operating system) of which this program is a part, not
including that this program is going to fail. An example of this is an error
in a shared configuration file.
L<LOG_NOTICE|"LOG_NOTICE"> should be used for abnormal, but not worrying
conditions. For example, if a grep-like program might log a message for each
file read at level L<LOG_INFO|"LOG_INFO">, but log at
L<LOG_NOTICE|"LOG_NOTICE"> files which it has not permissions to read.
=back
=cut
use constant SINK_STDERR => ':stderr';
use constant DEFAULT_CHANNELS => qw( CHAN_PROGRESS CHAN_DEBUG
CHAN_STATS CHAN_INFO );
BEGIN {
for (DEFAULT_CHANNELS) {
no strict 'refs';
# Prefix with ':' to make illegal name (for anyone else!)
# (to avoid namespace clash)
my $name = ':' . lc substr($_, 5);
*{join('::', __PACKAGE__, $_)} = sub { $name };
}
push @EXPORT_OK, DEFAULT_CHANNELS, 'SINK_STDERR';
$EXPORT_TAGS{default_channels} = [ DEFAULT_CHANNELS, 'SINK_STDERR' ];
}
# -------------------------------------
=head2 SINK_TERM_PROGRESS
Here is a fine kettle of fish.
This sink sniffs its filehandle (upon sink creation), and if it smells like a
TTY, it uses it as a progress bar. Otherwise, it just sets up a
file/filehandle sink as usual.
In progress-bar mode, incoming messages are examined. If they look like
m!\[([\d_,.]+/[\d_,.]+|[\d_,.]+%)(\s+[^]]*)?\s+Done\]!
Then that is treated as progress information, and the bar updated
accordingly.
=over 4
=item ARGUMENTS
=over 4
=item fh
Filehandle to output to, or name of file. B<Beware>: if you present a
filehandle, you probably want to provide a glob ref (e.g., C<\*STDERR>); the
C<*foo{THING}> will never act as a terminal. undef defaults to STDERR.
=item level
B<Optional> A sink message cutoff level. Defaults to C<undef>
=cut
# FOR TESTING
our ($__SINK_TERM_FORCE) = 0;
my ($last_time, $last_now);
sub SINK_TERM_PROGRESS {
eval "use Term::ProgressBar 2.00;";
croak sprintf("Cannot use sink %s without Term::ProgressBar present:\n %s",
(caller 0)[3], $@)
if $@;
my ($fh, $level) = @_;
my $fn;
if ( defined $fh ) {
if ( ! ref $fh ) {
$fn = $fh;
CORE::sysopen $fh, $fn, O_WRONLY
or croak "Cannot open $fh for writing: $!\n";
}
} else {
$fh = \*STDERR;
}
Term::ProgressBar->__force_term($__SINK_TERM_FORCE)
if $__SINK_TERM_FORCE;
if ( $__SINK_TERM_FORCE || -t $fh ) {
my ($next) = (0);
my $progress = Term::ProgressBar->new({count => 100,
fh => $fh,
ETA => 'linear'});
return 'SUBR', undef,
{ subr => sub {
if ( my ($prefix, $now, $end, $percent, $suffix) =
($_[0] =~ m!(.*)
\[(?:([\d_,.]+)/([\d_,.]+) |
(?:([\d_,.]+)%))
(?:\s+[^]]*)?\s+Done\]
(.*)!x) ) {
tr/_,//d
for grep defined, $now, $end, $percent;
($now, $end) = ($percent, 100)
if defined $percent;
my $message_printed = 0;
if ( defined $suffix and $suffix !~ /^\s*$/ ) {
s!^\s*(.*?)\s*$!$1!
for grep defined, $suffix, $prefix;
if ( defined $prefix and $prefix !~ /^\s*$/ ) {
$progress->message("$prefix $suffix");
} else {
$progress->message($suffix);
}
$message_printed = 1;
}
if ( $end != $progress->target ) {
$progress->target($end);
$next = $progress->update($now)
} else {
$next = $progress->update($now)
if($message_printed or
$now >= $next or
time >= $last_time + ETA_ACCURACY ) ;
}
$last_now = $now;
} else {
$progress->message($_[0]);
$progress->update($last_now);
}
$last_time = time;
}
};
} else {
if ( defined $fn ) {
return 'FILE', $level, { fn => $fh };
} else {
return 'FH', $level, { fh => $fh };
}
}
}
# -------------------------------------
=head2 Default Translators
Default translator units provided for communal edification.
=over 4
=item TRANS_UDT
(UDT =E<gt> "Un*x-Date-Time"). Prefix each message with the date and time, first
in Un*x (seconds since Jan 1, 1970) format, then as the scalar gmtime output.
gmtime is deliberately chosen to avoid weirdness over, say, daylight-savings
time changes.
=back
=cut
use constant TRANS_UDT =>
sub { my $time = time;
sprintf('[%d %s] %s',
$time, scalar gmtime $time, $_[0]) };
{ # Very unpleasant hackery to discern timezone offset on systems with backward
# strftimes. Bloody Solaris.
my $save = $!+0;
my $format = '(%d%b %H:%M:%S%z)';
my $check = strftime('%z',localtime);
if ( $check eq '%z' ) {
$format = undef;
ATTEMPT:
# sfw for recent Solaris boxen
for my $path (@PATH, '/opt/sfw/bin') {
for my $dname (qw( date gdate )) {
my $date = catfile $path, $dname;
next
unless -x $date;
my $date_version = qx( $date --version 2>&1 );
{
local $/ = undef;
open *DATE, "$date --version 2>&1 |";
$date_version = <DATE>;
# Don't check the return code; it'll often be >0 since we're
# running a utility (--version)
CORE::close *DATE;
}
if ( $date_version =~ m/^date \(GNU.*\) ([\d.]+)$/m ) {
(my $version = $1);
my @v = split /\./, $version;
$version = join('.', $v[0],
join '', map sprintf('%03d', $_), @v[1..$#_]);
if ( $version >= 2 ) {
chomp(my $timezone = qx( $date +%z ));
$format = "(%d%b %H:%M:%S$timezone)";
last ATTEMPT;
} # end if ( $version >= 2 )
} # end if ( $date_version =~ m/^date \(GNU.*\) ([\d.]+)$/m )
} # for my $dname (qw( date gdate ))
} # end for my $path (@PATH)
# A questionable llseek on Solaris leaves ESPIPE in $!
$! = $save;
} # end if ( $check eq '%z' )
# TRANS_CDT: [1285701228(28Sep 19:13:48+0000):./def-trans.t] Dibble
# epochtime time+TZ script($0) msg
use constant TRANS_CDT =>
sub { my $time = time;
die "Cannot determine timezone info. Sorry. Perhaps installing gnu date will help\n"
unless defined $format;
sprintf('[%d%s:%s] %s',
$time,
strftime($format, localtime($time)),
$0, $_[0]); };
}
# -------------------------------------
our $PACKAGE = 'Log-Info';
our $VERSION = '2.00';
# -------------------------------------
# PACKAGE CONSTRUCTION
# -------------------------------------
# -------------------------------------
# PACKAGE DESTRUCTION
# -------------------------------------
END {
delete_channel($_)
for keys %channel;
}
# -------------------------------------
# PACKAGE COMPONENTS
# -------------------------------------
# Channels -------------------------------------------------------------------
=head2 CHANNELS
=cut
# Map from channel name to details.
# Each detail is a hashref, with the following keys:
# sinks ) Hashref of data sinks, by name. The name itself is for
# identifying the sink for adding, removing, altering. It has no
# semantic value.
# Each sink is itself a hashref, with keys:
# type )
# Currently recognized types are
# FILE )
# Values recognized:
# fn ) (base) filename
# maxsize ) max file size
# fh ) open fh, if previously used. This is
# generated and used by Log() directly; do
# not manhandle.
# FH )
# fh ) open fh. May be an IO thing (*FOO{IO}),
# a glob ref, a glob, or an instance of
# IO::Handle
# SUBR )
# subr ) a subroutine that will be invoked with the
# log text as its single argument.
# values )
# Hashref with Type-specific keys; see the (type)
# documentation
# trans )
# If defined, a translation applied for the sink. This is
# aplied to the result of any channel-specific translation.
# level )
# If defined, a level cutoff for the sink. This level is
# checked only if the channel level is passed; hence, a level
# greater than or equal to the channel level has no effect.
# trans ) Arrayref of sub refs for channel data translators. Each array
# member is applied in order, list head first, with cumulative
# results.
# level ) Number for channel level output cutoff
=head2 add_channel
Create a new channel.
=over 4
=item PRECONDITIONS
chan is not already a channel name
$chan =~ /^[\w-]+$/;
=item ARGUMENTS
=over 4
=item chan
name of channel. Translates directly to a Log::Log4perl channel name.
=item level
Optional. Logging level; defaults to LOG_NOTICE. Pass C<undef> to log all
messages.
=back
=back
=cut
sub add_channel {
my ($chan, $level) = @_;
if ( ! defined $level ) {
if ( 1 == @_ ) { # true default
$level = LOG_NOTICE();
} else { # undef was passed
$level = LOG_ALL();
}
}
croak "Invalid channel name :->$chan<-\n"
unless $chan =~ /^[\w-]+$/ or caller eq __PACKAGE__;
croak "Channel already exists: $chan\n"
if exists $channel{$chan};
$channel{$chan} = Log::Log4perl->get_logger($chan);
$channel{$chan}->level(LOG4PERL_LEVELS->{$level});
}
BEGIN {
add_channel(eval "$_", undef)
for DEFAULT_CHANNELS;
}
# -------------------------------------
=head2 delete_channel
delete an existing channel. Implicitly deletes all attached sinks.
=over 4
=item PRECONDITIONS
chan is an existing channel name
=item ARGUMENTS
=over 4
=item chan
name of channel to delete
=back
=back
=cut
sub delete_channel {
my ($chan) = @_;
croak "Channel does not exist: $chan\n"
unless exists $channel{$chan};
delete_sink($chan, $_)
for keys %{$channel{$chan}{sinks}};
delete $channel{$chan};
delete $LOGGERS_BY_NAME->{$chan};
}
# -------------------------------------
=head2 channel_exists
=over 4
=item ARGUMENTS
=over 4
=item chan
Channel name to test for
=back
=item RETURNS
=over 4
=item exists
Whether the name channel is known to Log::Info
=back
=back
=cut
sub channel_exists { return exists $channel{$_[0]} }
# -------------------------------------
=head2 set_channel_out_level
set output cutoff level on channel
=over 4
=item ARGUMENTS
=over 4
=item chan
channel to set output cutoff level on
=item lvl
level to set to; subsequent log entries will only be written if they have
level E<lt>= lvl.
=back
=back
=cut
sub set_channel_out_level {
my ($chan, $level) = @_;
my $logger = Log::Log4perl->get_logger($chan)
or croak "Channel does not exist: $chan\n";
if ( defined $level ) {
$logger->level(LOG4PERL_LEVELS->{$level} // _generate_l4p_level($level));
} else {
$logger->level('ALL');
}
$logger->set_output_methods;
}
# -------------------------------------
=head2 add_chan_trans
Add a translator to a channel.
=over 4
=item ARGUMENTS
=over 4
=item chan
The channel to add the translator to.
=item trans
The translator to add. The translator will be called in order after any
previously added translators, and will be given the results of the log string
having been through those translators. The results of the translation
provided by this translator will be passed to any translators installed after
this one, and to any sink-specific translators.
=back
=back
=cut
sub add_chan_trans {
my ($chan, $trans, $name) = @_;
state $trans_name = 'aaa';
$name //= join ':', qw( trans chan ), $chan, $trans_name++;
croak "Channel does not exist: $chan\n"
unless exists $channel{$chan};
croak sprintf("Translator for channel %s not a subroutine: %s\n",
$chan, ref $trans || $trans)
unless UNIVERSAL::isa ($trans, 'CODE');
push @{$channel{$chan}{trans}}, $trans;
our %chan_trans;
$chan_trans{$chan}->{$name} = +{ pos => $#{$channel{$chan}{trans}},
tran => $trans,
create_line => join(':', (caller)[1,2]),
};
return $name;
}
sub remove_chan_trans {
my ($chan, $name) = @_;
croak "Channel does not exist: $chan\n"
unless exists $channel{$chan};
our %chan_trans;
croak "translator '$name' is not on channel '$chan'"
unless my $trans_info = delete $chan_trans{$chan}->{$name};
splice @{$channel{$chan}{trans}}, $trans_info->{pos}, 1;
$_->{pos}--
for grep $_->{pos} > $trans_info->{pos}, values %{$chan_trans{$chan}};
return;
}
# Sinks ----------------------------------------------------------------------
=head2 SINKS
=cut
# -------------------------------------
=head2 add_sink
=over 4
=item PRECONDITIONS
$chan is an existing channel name
$sink =~ /^[\w-]+$/;
=item ARGUMENTS
=over 4
=item chan
channel to add sink to
=item name
name of sink
=item type
sink type as string. See L<params|"params"> for acceptable types.
=item level
Output cutoff level. Set to 'undef' to accept any messages accepted by the
channel. This level is checked after the channel level; therefore, if this
level is higher than the channel level, it will have no effect.
=item params
A hashref of type-specific parameters. Recognized keys are type specific:
=over 4
=item FILE
Output to file. If the file exists, it will be appended to. Each message
(call to L<Log|"Log">) will be newline-terminated. Keys are:
=over 4
=item fn
Filename
=item maxsize
Optional; maximum filesize. Files will be closed, datestamped (name will have
date appended) and a new file opened if this size is about to be exceeded.
Defaults to 1Gb.
=back
=item FH
Output to filehandle. Creation of, and closing of, the filehandle are the
responsibility of the client. Do not delete the filehandle without closing
the sink first. Each message (call to L<Log|"Log">) will be
newline-terminated. Keys are:
=over 4
=item fh
Filehandle to output to. May be an IO handle (*foo{IO}), a glob ref, a glob,
or an instance of IO::Handle.
=back
=item SUBR
Callback subroutine. Keys are:
=over 4
=item subr
Subr to call back to (once for each call to L<Log|"Log">). String will be
passed to subr. No line terminator will be added.
=back
=item SYSLOG
Log to C<syslog> service. Any C<LOG_I<X>> value provided by this module is a
valid syslog level; any level that is provided that is not valid for syslog is
rounded down to the nearest value. Any level that is less than all valid
values is defaulted to LOG_EMERG. The message is logged with the basename of
the running script, and pid.
Due to an artifact of L<Sys::Syslog>, messages have a space appended when they
appear in the log.
Keys are:
=over 4
=item facility
Optional; facility to pass to syslog to log messages under. Valid values are
the C<FTY_> constants.
=back
=back
=back
=back
=cut
my $syslog_initialized = 0;
use constant REQUIRED_PARAMS =>
{
FILE => [ qw( fn ) ],
FH => [ qw( fh ) ],
SUBR => [ qw( subr )],
SYSLOG => [ qw( ) ],
};
sub add_sink {
my ($chan, $name, $type, $level, $params) = @_;
croak "Channel does not exist: $chan\n"
unless exists $channel{$chan};
croak sprintf("params arg must be hashref, not %s\n", ref $params)
if defined $params and not UNIVERSAL::isa($params, 'HASH');
croak "Invalid sink name :->$name<-\n"
unless $name =~ /^[\w-]+$/ or caller eq __PACKAGE__;
my %values;
my $required_params = REQUIRED_PARAMS->{$type};
croak "Unrecognized sink type: '$type'\n"
unless defined $required_params;
croak sprintf ("%s undefined for %s sink type; channel/sink %s/%s\n",
$_, $type, $chan, $name)
for grep ! defined $params->{$_}, @$required_params;
my $appender_name = "${chan}::${name}";
my $appender;
if ( $type eq 'FILE' ) {
@values{qw( fn maxsize )} = @{$params}{qw( fn maxsize )};
$values{maxsize} //= 1_024 ** 3; # 1Gb
my ($class, @attrs);
if ( $values{maxsize} ) {
$class = 'Log::Dispatch::FileRotate';
# in _log_to_file, we specified no max count
@attrs = (size => $values{maxsize}, max => 1000);
} else {
$class = 'Log::Dispatch::File';
}
eval "require $class";
die "%>require $class<% failed: $@"
if @$;
$appender = Log::Log4perl::Appender->new($class,
name => $appender_name,
filename => $values{fn},
@attrs);
$appender->layout(Log::Log4perl::Layout::PatternLayout->new('%m%n'));
} elsif ( $type eq 'FH' ) {
$values{fh} = $params->{fh};
croak
sprintf ("fh type not acceptable for channel/sink %s/%s: %s\n",
$chan, $name, ref $values{fh})
unless UNIVERSAL::isa ($values{fh}, 'IO::Handle')
or UNIVERSAL::isa ($values{fh}, 'GLOB');
my $handle = $values{fh};
$handle = Log::Info::GlobHandle->new($handle)
if UNIVERSAL::isa ($values{fh}, 'GLOB');
$appender = Log::Log4perl::Appender->new
('Log::Dispatch::Handle',
name => $appender_name,
handle => $handle,
);
$appender->layout(Log::Log4perl::Layout::PatternLayout->new('%m%n'));
} elsif ( $type eq 'SUBR' ) {
my $subr = $params->{subr};
croak
sprintf ("subr type not acceptable for channel/sink %s/%s: %s\n",
$chan, $name, ref $subr)
unless UNIVERSAL::isa ($subr, 'CODE');
$appender = Log::Log4perl::Appender->new('Log::Info::SubAppender',
name => $appender_name,
subr => $subr
);
$appender->layout(Log::Log4perl::Layout::PatternLayout->new('%m'));
} elsif ( $type eq 'SYSLOG' ) {
my $facility = $params->{facility};
my @args = ('Log::Dispatch::Syslog',
name => $appender_name,
);
if ( $facility ) {
croak "Invalid facility: '$facility'"
unless grep $_ eq 'FTY_' . uc $facility, LOG_FACILITIES;
push @args, facility => $facility;
}
$appender = Log::Log4perl::Appender->new(@args);
$appender->layout(Log::Log4perl::Layout::PatternLayout->new('%m%n'));
} else {
croak "unrecognized sink type: $type\n";
}
$appender->threshold(LOG4PERL_LEVELS->{$level})
if defined $level;
Log::Log4perl->get_logger($chan)->add_appender($appender);
}
# -------------------------------------
=head2 delete_sink
Remove a sink from a channel.
=over 4
=item ARGUMENTS
=over 4
=item chan
Name of the channel to delete the sink from.
=item sink
Name of the sink to delete.
=back
=back
=cut
sub delete_sink {
my ($chan, $sink) = @_;
my $logger = Log::Log4perl->get_logger($chan)
or croak "Channel does not exist: $chan\n";
my $appender_name = "${chan}::${sink}";
croak "Channel/Sink does not exist: $chan/$sink\n"
unless grep $appender_name eq $_, @{$logger->{appender_names}};
$logger->remove_appender($appender_name);
}
# -------------------------------------
=head2 set_sink_out_level
set output cutoff level on channel
=over 4
=item ARGUMENTS
=over 4
=item chan
channel whose sink to amend
=item sink
sink to set output level of
=item lvl
level to set to; subsequent log entries will only be written if they have
level E<lt>= lvl.
=back
=back
=cut
sub set_sink_out_level {
my ($chan, $sink, $level) = @_;
my $logger = Log::Log4perl->get_logger($chan)
or croak "Channel does not exist: $chan\n";
my $appender_name = "${chan}::${sink}";
my $appender = Log::Log4perl->appenders->{$appender_name}
or croak "cannot find appender $appender_name (Channel/Sink: $chan/sink\n";
if ( defined $level ) {
$appender->threshold(LOG4PERL_LEVELS->{$level});
} else {
$appender->threshold('ALL');
}
$logger->set_output_methods;
}
# -------------------------------------
=head2 add_sink_trans
Add a translator to a channel sink.
=over 4
=item ARGUMENTS
=over 4
=item chan
The channel to add the translator to.
=item sink
The sink to add the translator to.
=item trans
The translator to add. The translator will be called in order after any
previously added (sink-specific) translators, all of which are called after
any channel translators, and will be given the results of the log string
having been through those translators. The results of the translation
provided by this translator will be passed to any (sink-specific) translators
installed after this one.
=back
=back
=cut
sub add_sink_trans {
my ($chan, $sink, $trans) = @_;
croak sprintf "Translator for %s/%s not a subroutine: %s\n",
$chan, $sink, ref $trans
unless UNIVERSAL::isa($trans, 'CODE');
# @{$channel{$chan}{sinks}{$sink}{trans}}
# is (trans0, trans1, trans2, writer) where trans0 is the first translator,
# trans1 is the second, etc. and writer is the appender that does the actual
# writing
# trans_by_cs: translator by channel & sink
# each value is is an arrayref. First element is the writer,
# i.e. the logger that does the writing. Latter elements are
# the translating loggers, in order of addition
state %trans_by_cs;
my $logger = Log::Log4perl->get_logger($chan)
or croak "Channel does not exist: $chan\n";
my $cs = "${chan}::${sink}";
$trans_by_cs{$cs} //= [ Log::Log4perl->appenders->{$cs} ]
or croak "no such channel::sink: $cs\n";
my ($writer, @trans) = @{$trans_by_cs{$cs}};
my $old_last_app;
if ( @trans ) {
$old_last_app = $trans[-1];
} else {
$logger->remove_appender($cs);
}
state $name_suffix = 'aaa';
my $comp_name = join ':', $chan, $sink, $name_suffix++;
my $subr = sub {
my ($p, $sub_ap) = @_;
my $child_ap = $sub_ap->{child_ap};
$p->{message} = $trans->($p->{message});
$child_ap->log($p,
$p->{log4p_category},
$p->{log4p_level});
};
my $comp = Log::Log4perl::Appender->new('Log::Info::SubAppender',
name => $comp_name,
full_p => 1,
child_ap => $writer,
subr => $subr,
);
$comp->layout(Log::Log4perl::Layout::PatternLayout->new('%m'));
if ( $old_last_app ) {
$old_last_app->{appender}->{child_ap} = $comp;
} else {
$logger->add_appender($comp);
}
# remember to push onto trans_by_cs here, rather than @trans, because
# because @trans is ephemeral
push @{$trans_by_cs{$cs}}, $comp;
}
# -------------------------------------
# PACKAGE FUNCTIONS
# -------------------------------------
=head1 PACKAGE FUNCTIONS
Z<>
=cut
sub get_level {
my ($level) = @_;
return
unless defined $level;
if ( $level !~ /^-?\d+/ ) {
if ( exists LOG_LEVEL->{$level} ) {
$level = LOG_LEVEL->{$level};
} else {
croak "unrecognized level: $level\n";
}
}
return $level;
}
# -------------------------------------
=head2 Log
log a message
=over 4
=item ARGUMENTS
=over 4
=item channel
channel to log to
=item level
message log level. Only if the log level is equal to or less than the channel
log level will it be logged. For each sink, if the sink also has a level, the
message will be logged to that sink only if the message level is equal to or
below the sink level I<as well as> the channel level.
=item string
The string to log. Do not append a line terminator; the sinks will do so
themselves if necessary.
=back
=back
=cut
sub Log {
my ($channel, $level, $string) = @_;
Log::Log4perl::init_once
(+{
'log4perl.rootLogger' => 'DEBUG, devnull',
'log4perl.appender.stderr' => 'Log::Log4perl::Appender::Screen',
'log4perl.appender.stderr.stderr' => 1,
'log4perl.appender.stderr.layout' =>
'Log::Log4perl::Layout::SimpleLayout',
'log4perl.appender.devnull' => 'Log::Log4perl::Appender::File',
'log4perl.appender.devnull.filename' => '/dev/null',
'log4perl.appender.devnull.layout' =>
'Log::Log4perl::Layout::SimpleLayout',
});
croak "no such Log::Info channel '$channel'"
unless exists $LOGGERS_BY_NAME->{$channel};
my $logger = Log::Log4perl->get_logger($channel);
my $l4p_level = LOG4PERL_LEVELS->{$level} // _generate_l4p_level($level);
$string = $_->($string)
for @{$channel{$channel}{trans}};
$logger->log($l4p_level, $string);
croak "Log::Info::Log : unrecognized channel: $channel\n"
unless exists $channel{$channel};
}
# -------------------------------------
=head2 Logf
=over 4
=item ARGUMENTS
=over 4
=item channel
As for L<Log|"Log">
=item level
As for L<Log|"Log">
=item format
As for L<sprintf/"sprintf">.
=item args
As for L<sprintf/"sprintf">.
=back
=back
=cut
sub Logf {
my ($channel, $level, $format, @args) = @_;
if ( ! exists $channel{$channel} ) {
carp "Log::Info::Log : unrecognized channel: $channel\n";
return;
}
if ( ! defined $format ) {
my @caller = caller 1;
Log ($channel, $level,
sprintf('Log::Info::Logf: sprintf format not defined ' .
'(called by %s::%s, at %s line %d)',
@caller[0,3,1,2]));
return;
}
if ( grep ! defined, @args ) {
my @caller = caller 1;
for (grep ! defined $args[$_], 0..$#args) {
Log ($channel, $level,
sprintf('Log::Info::Logf: format argument %s not defined ' .
'(called by %s::%s, at %s line %d)',
$_, @caller[0,3,1,2]));
$args[$_] = '';
}
}
Log ($channel, $level, sprintf $format, @args);
}
# Subroutines picked out from log to simplify things
sub _log_to_file {
my ($values, $sinkstring, $channel, $name, $level) = @_;
my ($logfn, $maxsize, $fh) = @{$values}{qw( fn maxsize fh )};
local $/ = "\n"; chomp $sinkstring;
$sinkstring .= "\n";
SIZE_CHECK:
while (1) {
if ( defined $fh ) {
# Check if write to fh would take size past max; if so, close fh,
# move name to unused old name, and undefine $fh to get new one
# generated
# tell() doesn't work for appended filehandles :-(
my $fsize = (stat $fh)[7];
my $new_size = $fsize + length $sinkstring;
if ( $new_size > $maxsize and $fsize ) { # If this is this first
# message, log it whatever
$fh->close
or warn("Log::Info::Log : ",
"Failure to close output log $logfn: $!\n");
my ($dd, $mm, $yy) = (gmtime)[3..5];
my $tname = sprintf ("%s-%d-%02d-%02d", $logfn,
$yy+1900, $mm+1, $dd);
my $tail = '00';
$tail++
while -e join '-', $tname, $tail;
rename $logfn, join '-', $tname, $tail
or warn sprintf ("Log::Info::Log : " .
"Failure to rename output log %s to %s: $!\n",
$logfn, join '-', $tname, $tail);
$fh = undef;
delete $values->{fh};
} else {
last SIZE_CHECK;
}
}
if ( ! defined $fh ) {
# Open a shiny new fh, and assign it to fh
if ( sysopen $fh, $logfn, O_WRONLY | O_APPEND | O_CREAT ) {
$values->{fh} = $fh;
} else {
warn "Log::Info::Log : Couldn't open $logfn for appending: $!\n";
delete_sink ($channel, $name);
last SIZE_CHECK;
}
}
}
# Write the output!
if ( defined $fh ) {
$fh->syswrite($sinkstring)
or warn sprintf ("Log::Info::Log : " .
"Print failed on file %s (name/chan %s/%s): $!\n",
$logfn, $name, $channel);
}
}
# -------------------------------------
sub _log_to_fh {
my ($values, $sinkstring, $channel, $name, $level) = @_;
local $/ = "\n"; chomp $sinkstring;
eval {
$values->{fh}->syswrite("$sinkstring\n")
or warn sprintf ("Log::Info::Log : " .
"Print failed on filehandle %s (channel %s): $!\n",
$name, $channel);
}; if ( $@ ) {
warn("Log::Info::Log : " .
"Print to filehandle $name on channel $channel failed:\n $@\n");
}
}
# -------------------------------------
sub _log_to_subr {
my ($values, $sinkstring, $channel, $name, $level) = @_;
eval {
$values->{subr}->($sinkstring);
}; if ( $@ ) {
warn("Log::Info::Log : " .
"Invocation of subr $name on channel $channel failed:\n $@\n");
}
}
# -------------------------------------
sub _log_to_syslog {
my ($values, $sinkstring, $channel, $name, $level) = @_;
my $sysloglevel = LOG_NAME->{$level};
if ( defined $values->{facility} ) {
$sysloglevel = join '|', $values->{facility}, $sysloglevel;
}
if ( ! defined $sysloglevel ) {
# Bump level up to next defined level
LOG_LEVEL:
foreach (LOG_LEVEL_VALUES) {
if ( $_ < $level ) {
$sysloglevel = LOG_NAME->{$_};
} else { # $_ > $level
# $_ != $level because ! defined $sysloglevel on loop entry
last LOG_LEVEL; # LOG_LEVEL_VALUES is sorted; hence all successive
# values will also be > $level
}
}
}
if ( ! defined $sysloglevel ) {
# Looks like none of the values are higher. Default to LOG_EMERG.
# call LOG_EMERG, then deref, just to check it's a valid level
$sysloglevel = LOG_NAME->{LOG_EMERG()};
}
# Unset log mask
my $oldmask = setlogmask (Sys::Syslog::LOG_UPTO(Sys::Syslog::LOG_DEBUG));
syslog $sysloglevel, $sinkstring;
setlogmask ($oldmask);
}
# -------------------------------------
# PACKAGE PROCEDURES
# -------------------------------------
=head1 PACKAGE PROCEDURES
Z<>
=cut
=head2 trap_warn_die
Add handlers to warn(), die(), to log messages to the log system. Any
existing handlers are invoked after those added.
The die handler logs the message to C<CHAN_INFO> at C<LOG_ERR>. The warn
handler logs the message to C<CHAN_INFO> at C<LOG_WARNING>.
This also traps C<Carp> messages.
=over 4
=item ARGUMENTS
I<None>
=back
=cut
sub import {
my $class = shift;
my (@bad_names, @export_symbols);
my %export_ok = map({; $_ => 1 }
':DEFAULT', @EXPORT, @EXPORT_OK,
map(":$_", keys %EXPORT_TAGS));
for (@_) {
if ( $_ eq ':trap' ) {
__trap_warn_die();
} elsif ( $_ eq ':default_channels' ) {
push @export_symbols, $_;
add_sink(CHAN_INFO, SINK_STDERR, 'FH', LOG_WARNING, { fh => *STDERR{IO} });
} elsif ( exists $export_ok{$_} ) {
push @export_symbols, $_;
} else {
push @bad_names, $_;
}
}
croak ("Arguments to " . __PACKAGE__ .
" import not recognized: ",
join (', ', @bad_names), "\n")
if @bad_names;
$class->export_to_level(1, $class, @export_symbols);
}
my %redef_subr = (die => 1); # track of subrs intentionally redefined to
# exclude from warnings
sub trap_warn_die {
Log(CHAN_INFO, LOG_WARNING,
"trap_warn_die subr deprecated; use the import tag :trap instead\n");
__trap_warn_die();
}
sub __trap_warn_die {
my $lastmessage = '';
my $package;
{
my $i = 0;
do {
($package) = (caller($i))[0];
$i++;
} while ( $package eq __PACKAGE__ );
}
my $file = __FILE__;
my $warnhook = $SIG{__WARN__};
$SIG{__WARN__} = sub {
# Nasty hack to avoid irritating mandatory redefine warnings bug
if ( my ($subrname) = ($_[0] =~ /^Subroutine ([:\w]+) redefined at $file/ )
) {
if ( exists $redef_subr{$subrname} or
( index($subrname,':') == -1 and
exists $redef_subr{"main::$subrname"} ) or
( $subrname =~ /^(?:main|CORE::GLOBAL)::([a-z_]\w+)$/ and
exists $redef_subr{$1} )
) {
return;
}
}
my $message = join '', grep defined, @_;
Log(CHAN_INFO, LOG_WARNING, $message);
$warnhook->(@_)
if defined $warnhook and UNIVERSAL::isa($warnhook, 'CODE');
};
my $save;
my $diehook = $SIG{__DIE__};
# Carp doesn't call die directly. I know not how or why. So this traps
# calls to carp that didn't make it via the override
$SIG{__DIE__} = sub {
my $message = join '', grep defined, @_;
if ( $message !~ /\A[\s\n]*\Z/ ) {
Log(CHAN_INFO, LOG_ERR, $message)
unless $dying or $message eq $lastmessage;
}
local $dying = 1;
if ( defined $diehook and UNIVERSAL::isa($diehook, 'CODE') ) {
$diehook->(@_);
}
$! = $save
if $save;
};
# Override Carp messages if present
for (qw( croak confess )) {
no strict 'refs';
my $subr_name = defined $package ? "${package}::$_" : "main::$_";
my $subr = \&{$subr_name};
if ( defined $subr ) {
$redef_subr{$subr_name} = $redef_subr{$_} = 1;
*{"$subr_name"} = sub {
$save = $!+0;
$subr->(@_);
};
}
}
*CORE::GLOBAL::die =
sub {
local $dying = 1;
$save = $! + 0;
my $message = join '', grep defined, @_;
if ( $message !~ /\A[\s\n]*\Z/ ) {
# Always terminate with a newline. This ensures conformity of message
# with that checked in SIG{__DIE__}, which otherwise may have an
# "\n at line..." appended.
# If we want such appendages, we can add them ourselves
$message =~
s/([^\n])\z/sprintf("%s at %s line %d", $1, (caller)[1,2]) . "\n"/e;
$message =~ s/\n+\z/\n/;
Log(CHAN_INFO, LOG_ERR, "$message")
unless $message eq $lastmessage;
$lastmessage = $message;
}
$! = $save
if $save;
# this causes the message to percolate to the default die handler, which
# typically writes it to stderr. So the message may get output twice.
# That is unfortunate, but we need to do this to ensure that $@ is still
# set to the message after we exit. Merely setting $@=$message doesn't
# do it.
CORE::die($message);
};
}
# -------------------------------------
=head2 enable_file_channel
Set up output channel (for string based command-line options).
=over 4
=item ARGUMENTS
=over 4
=item channel_name
name of the channel to log to.
=item fn
value of option presented by user. If this option looks like a simple number,
it is treated as a log level (see below). If this option looks like a simple
file name (C<m!^[A-Za-z0-9_.\\/-]+$>), it will be treated as an output file
(but output with the 'FH' type, so no auto-rotate, and special files will
work). If this option looks like C<m!^:\d+!>, the numeric value will be
treated as a file descriptor, and output sent there. If this value is
defined, but a blank string, then output will be sent to stderr.
If a value of the form C<\+\d+> precedes a file descriptor, or succeeds a
filename, then the numeric value is used to set the log level of the output
sink. If not set, it defaults to C<LOG_INFO>, which is equivalent to C<+1>.
Hence, C<+0> is equivalent to C<LOG_INFO - 1>.
If this value is not defined, then no action is taken (this is to allow
compatibility with options processors, where a value is left undefined if its
option is never invoked).
If this value is defined but empty (C<''>), then the log level is set to
LOG_INFO (first time), and the output sent to STDERR. If the option is seen
again, still with an empty string value, and with the same channel & sink
names, then the log level is increased one place. This is to allow C<-v -v
-v>(or C<-vvv>)-style options.
=item option_name
name of the option invoked (used for error messages).
=item sink_name
the name of the sink to create.
=item term_progress
I<Optional> If true, generate a sink with SINK_TERM_PROGRESS
=back
=back
=cut
my %seen_channel_sink;
sub enable_file_channel {
my ($channel_name, $fn, $option_name, $sink_name, $term_progress) = @_;
if ( defined $fn ) { # Else option not invoked
$fn =~ s/\s*(.*?)\s*$/$1/;
my $fh;
my $level = LOG_INFO;
if ( $fn =~ s/\+(\d+)// or $fn =~ s/^(\d+)$// ) {
$level += $1-1;
} else {
my $key = join "\0", $channel_name, $sink_name;
$level += $seen_channel_sink{$key}++;
}
if ( $fn eq '' ) {
$fh = \*STDERR;
} elsif ( substr($fn, 0, 1) eq ':' ) {
my $fd = substr($fn, 1);
if ( $fd =~ /^\d+/ ) {
unless ( CORE::open $fh, ">&=$fd" ) {
# Don't use Log::Info when the channels haven't opened...
croak "Could not open file descriptor $fd for writing: $!\n";
}
select(((select $fh), $| = 1)[0]);
} else {
croak sprintf("Cannot handle non-integer file descriptor " .
"argument to %s: %s", $option_name, $fn);
}
} elsif ( $fn =~ m!^[A-Za-z0-9_.\\/-]+$! ) {
unless ( CORE::sysopen $fh, $fn, O_CREAT | O_EXCL | O_WRONLY ) {
croak "Could not open file $fn for (create &) writing: $!\n";
}
} else {
croak "Cannot handle argument to $option_name: $fn\n";
}
if ( defined $fh ) {
if ( $term_progress ) {
add_sink($channel_name, $sink_name, SINK_TERM_PROGRESS($fh, $level));
} else {
add_sink($channel_name, $sink_name, 'FH', $level, { fh => $fh });
}
}
return $level - (LOG_INFO - 1);
}
}
sub _generate_l4p_level {
my ($level) = @_;
my $l4p_level;
my @keys = keys %{LOG4PERL_LEVELS()};
my ($minkey, $maxkey) = (min(@keys), max(@keys));
given ( $level ) {
when ( $_ < $minkey ) { $l4p_level = 2 * LOG4PERL_LEVELS->{$minkey} }
when ( $_ > $maxkey ) { $l4p_level = LOG4PERL_LEVELS->{$maxkey} / 2 }
default {
my $lower = max grep $_ < $level, @keys;
my $upper = min grep $_ > $level, @keys;
$l4p_level = (LOG4PERL_LEVELS->{$lower} + LOG4PERL_LEVELS->{$upper}) / 2;
}
}
LOG4PERL_LEVELS->{$level} = $l4p_level;
my $level_name = sprintf "LEVEL%d", $level;
Log::Log4perl::Level::add_priority(sprintf($level_name), $l4p_level);
Log::Log4perl::Logger::create_log_level_methods($level_name);
Log::Log4perl::Logger::reset_all_output_methods; # generate all the code-generated levels, etc.
return $l4p_level;
}
# ----------------------------------------------------------------------------
=head1 EXAMPLES
Z<>
=head1 BUGS
=over 4
=item *
C<%m> strings will get expanded to $! in C<SYSLOG> sinks; this is a bug, and
may get fixed at any time.
=back
=head1 REPORTING BUGS
Email the author.
=head1 AUTHOR
Martyn J. Pearce C<fluffy@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2001, 2002, 2003, 2005, 2010 Martyn J. Pearce. This program is
free software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=head1 SEE ALSO
Z<>
=cut
# ----------------------------------------------------------------------------
package Log::Info::GlobHandle;
# compatibility adapter to allow us to use Log::Dispatch::File to log to GLOBs
sub new {
my ($class, $handle) = @_;
select((select($handle), $|=1)[0]);
my $self = \$handle;
bless $self, $class;
}
sub print {
my ($self, @msg) = @_;
my $handle = $$self;
print $handle @msg;
}
# ----------------------------------------------------------------------------
1; # keep require happy.
__END__