package Log::Log4perl::Logger;
use 5.006;
use strict;
use warnings;
use Log::Log4perl;
use Log::Log4perl::Level;
use Log::Log4perl::Layout;
use Log::Log4perl::Appender;
use Log::Log4perl::Appender::String;
use Log::Log4perl::Filter;
use Carp;
$Carp::Internal{"Log::Log4perl"}++;
$Carp::Internal{"Log::Log4perl::Logger"}++;
use constant _INTERNAL_DEBUG => 0;
our $ROOT_LOGGER;
our $LOGGERS_BY_NAME = {};
our %APPENDER_BY_NAME = ();
our $INITIALIZED = 0;
our $NON_INIT_WARNED;
our $DIE_DEBUG = 0;
our $DIE_DEBUG_BUFFER = "";
our $STRING_APP_NAME = "_l4p_warn";
our $STRING_APP = Log::Log4perl::Appender->new(
"Log::Log4perl::Appender::String",
name => $STRING_APP_NAME);
$STRING_APP->layout(Log::Log4perl::Layout::PatternLayout->new("%m"));
our $STRING_APP_CODEREF = generate_coderef([[$STRING_APP_NAME, $STRING_APP]]);
__PACKAGE__->reset();
sub warning_render {
my($logger, @message) = @_;
$STRING_APP->string("");
$STRING_APP_CODEREF->($logger,
@message,
Log::Log4perl::Level::to_level($ALL));
return $STRING_APP->string();
}
sub cleanup {
Log::Log4perl->easy_closure_global_cleanup();
$LOGGERS_BY_NAME = {};
undef $ROOT_LOGGER;
%APPENDER_BY_NAME = ();
undef $INITIALIZED;
}
sub DESTROY {
CORE::warn "Destroying logger $_[0] ($_[0]->{category})"
if $Log::Log4perl::CHATTY_DESTROY_METHODS;
}
sub reset {
$ROOT_LOGGER = __PACKAGE__->_new("", $OFF);
%APPENDER_BY_NAME = ();
undef $INITIALIZED;
undef $NON_INIT_WARNED;
Log::Log4perl::Appender::reset();
foreach my $logger (values %$LOGGERS_BY_NAME){
$logger->{appender_names} = [];
next if $logger eq $ROOT_LOGGER;
$logger->{level} = undef;
$logger->level(); }
Log::Log4perl::Filter::reset();
}
sub _new {
my($class, $category, $level) = @_;
print("_new: $class/$category/", defined $level ? $level : "undef",
"\n") if _INTERNAL_DEBUG;
die "usage: __PACKAGE__->_new(category)" unless
defined $category;
$category =~ s/::/./g;
if(exists $LOGGERS_BY_NAME->{$category}) {
print "_new: exists already\n" if _INTERNAL_DEBUG;
return $LOGGERS_BY_NAME->{$category};
}
my $self = {
category => $category,
num_appenders => 0,
additivity => 1,
level => $level,
layout => undef,
};
bless $self, $class;
$level ||= $self->level();
$LOGGERS_BY_NAME->{$category} = $self;
$self->set_output_methods;
print("Created logger $self ($category)\n") if _INTERNAL_DEBUG;
return $self;
}
sub category {
my ($self) = @_;
return $self->{ category };
}
sub reset_all_output_methods {
print "reset_all_output_methods: \n" if _INTERNAL_DEBUG;
foreach my $loggername ( keys %$LOGGERS_BY_NAME){
$LOGGERS_BY_NAME->{$loggername}->set_output_methods;
}
$ROOT_LOGGER->set_output_methods;
}
sub set_output_methods {
my ($self) = @_;
my (@appenders, %seen);
my ($level) = $self->level();
print "set_output_methods: $self->{category}/$level\n" if _INTERNAL_DEBUG;
for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
foreach my $appender_name (@{$logger->{appender_names}}){
next if $seen{$appender_name} ++ &&
$Log::Log4perl::one_message_per_appender;
push (@appenders,
[$appender_name,
$APPENDER_BY_NAME{$appender_name},
]
);
}
last unless $logger->{additivity};
}
my $noop = generate_noop_coderef();
my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders));
my %priority = %Log::Log4perl::Level::PRIORITY;
foreach my $levelname (keys %priority){
if (Log::Log4perl::Level::isGreaterOrEqual($level,
$priority{$levelname}
)) {
print " ($priority{$levelname} <= $level)\n"
if _INTERNAL_DEBUG;
$self->{$levelname} = $coderef;
$self->{"is_$levelname"} = generate_is_xxx_coderef("1");
print "Setting is_$levelname to 1\n" if _INTERNAL_DEBUG;
}else{
print " ($priority{$levelname} > $level)\n" if _INTERNAL_DEBUG;
$self->{$levelname} = $noop;
$self->{"is_$levelname"} = generate_is_xxx_coderef("0");
print "Setting is_$levelname to 0\n" if _INTERNAL_DEBUG;
}
print(" Setting [$self] $self->{category}.$levelname to ",
($self->{$levelname} == $noop ? "NOOP" :
("Coderef [$coderef]: " . scalar @appenders . " appenders")),
"\n") if _INTERNAL_DEBUG;
}
}
sub generate_coderef {
my $appenders = shift;
print "generate_coderef: ", scalar @$appenders,
" appenders\n" if _INTERNAL_DEBUG;
my $watch_check_code = generate_watch_code("logger", 1);
return sub {
my $logger = shift;
my $level = pop;
my $message;
my $appenders_fired = 0;
$message = [map { ref $_ eq "HASH" &&
exists $_->{filter} &&
ref $_->{filter} eq 'CODE' ?
$_->{filter}->($_->{value}) :
ref $_ eq "CODE" ?
$_->() : $_
} @_];
print("coderef: $logger->{category}\n") if _INTERNAL_DEBUG;
if(defined $Log::Log4perl::Config::WATCHER) {
return unless $watch_check_code->($logger, @_, $level);
}
foreach my $a (@$appenders) { my ($appender_name, $appender) = @$a;
print(" Sending message '<$message->[0]>' ($level) " .
"to $appender_name\n") if _INTERNAL_DEBUG;
$appender->log(
{ name => $appender_name,
level => $Log::Log4perl::Level::L4P_TO_LD{
$level},
message => $message,
},
$logger->{category},
$level,
) and $appenders_fired++;
}
return $appenders_fired;
}; }
sub generate_noop_coderef {
my $watch_delay_code;
my $watch_check_code = generate_watch_code("logger", 1);
my $coderef;
if(defined $Log::Log4perl::Config::WATCHER) {
$coderef = $watch_check_code;
} else {
$coderef = sub { undef };
}
return $coderef;
}
sub generate_is_xxx_coderef {
my($return_token) = @_;
return generate_watch_code("checker", $return_token);
}
sub generate_watch_code {
my($type, $return_token) = @_;
print "generate_watch_code:\n" if _INTERNAL_DEBUG;
if(! defined $Log::Log4perl::Config::WATCHER) {
return sub { $return_token };
}
my $cond = generate_watch_conditional();
return sub {
print "exe_watch_code:\n" if _INTERNAL_DEBUG;
if(_INTERNAL_DEBUG) {
print "Next check: ",
"$Log::Log4perl::Config::Watch::NEXT_CHECK_TIME ",
" Now: ", time(), " Mod: ",
(stat($Log::Log4perl::Config::WATCHER->file()))[9],
"\n";
}
if( $cond->() ) {
my $init_permitted = 1;
if(exists $Log::Log4perl::Config::OPTS->{ preinit_callback } ) {
print "Calling preinit_callback\n" if _INTERNAL_DEBUG;
$init_permitted =
$Log::Log4perl::Config::OPTS->{ preinit_callback }->(
Log::Log4perl::Config->watcher()->file() );
print "Callback returned $init_permitted\n" if _INTERNAL_DEBUG;
}
if( $init_permitted ) {
Log::Log4perl->init_and_watch();
} else {
return 1;
}
my $logger = shift;
my $level = pop;
if($type eq "checker") {
return $logger->$level();
} elsif( $type eq "logger") {
my $methodname = lc($level);
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 3;
$logger = Log::Log4perl::get_logger( $logger->{category} );
$logger->$methodname(@_); return undef; } else {
die "internal error: unknown type";
}
} else {
if(_INTERNAL_DEBUG) {
print "Conditional returned false\n";
}
return $return_token;
}
};
}
sub generate_watch_conditional {
if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) {
return sub {
return $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT;
};
}
return sub {
return
( time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME and
$Log::Log4perl::Config::WATCHER->change_detected() );
};
}
sub parent_string {
my($string) = @_;
if($string eq "") {
return undef; }
my @components = split /\./, $string;
if(@components == 1) {
return "";
}
pop @components;
return join('.', @components);
}
sub level {
my($self, $level, $dont_reset_all) = @_;
if(defined $level) {
croak "invalid level '$level'"
unless Log::Log4perl::Level::is_valid($level);
if ($level =~ /\D/){
$level = Log::Log4perl::Level::to_priority($level);
}
$self->{level} = $level;
&reset_all_output_methods
unless $dont_reset_all;
return $level;
}
if(defined $self->{level}) {
return $self->{level};
}
for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
if($logger->{category} eq "") {
return $ROOT_LOGGER->{level};
}
if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) {
return $LOGGERS_BY_NAME->{$logger->{category}}->{level};
}
}
die "We should never get here.";
}
sub parent_logger {
my($logger) = @_;
if($logger->{category} eq "") {
return undef;
}
my $parent_class = parent_string($logger->{category});
while($parent_class ne "" and
! exists $LOGGERS_BY_NAME->{$parent_class}) {
$parent_class = parent_string($parent_class);
$logger = $LOGGERS_BY_NAME->{$parent_class};
}
if($parent_class eq "") {
$logger = $ROOT_LOGGER;
} else {
$logger = $LOGGERS_BY_NAME->{$parent_class};
}
return $logger;
}
sub get_root_logger {
my($class) = @_;
return $ROOT_LOGGER;
}
sub additivity {
my($self, $onoff) = @_;
if(defined $onoff) {
$self->{additivity} = $onoff;
}
return $self->{additivity};
}
sub get_logger {
my($class, $category) = @_;
unless(defined $ROOT_LOGGER) {
Carp::confess "Internal error: Root Logger not initialized.";
}
return $ROOT_LOGGER if $category eq "";
my $logger = $class->_new($category);
return $logger;
}
sub add_appender {
my($self, $appender, $dont_reset_all) = @_;
$INITIALIZED = 1;
my $appender_name = $appender->name();
$self->{num_appenders}++;
unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){
$self->{appender_names} = [sort @{$self->{appender_names}},
$appender_name];
}
$APPENDER_BY_NAME{$appender_name} = $appender;
reset_all_output_methods
unless $dont_reset_all;
return $appender;
}
sub remove_appender {
my($self, $appender_name, $dont_reset_all, $sloppy) = @_;
my %appender_names = map { $_ => 1 } @{$self->{appender_names}};
if(!exists $appender_names{$appender_name}) {
die "No such appender: $appender_name" unless $sloppy;
return undef;
}
delete $appender_names{$appender_name};
$self->{num_appenders}--;
$self->{appender_names} = [sort keys %appender_names];
&reset_all_output_methods
unless $dont_reset_all;
}
sub eradicate_appender {
shift if $_[0] eq __PACKAGE__;
my($appender_name, $dont_reset_all) = @_;
return 0 unless exists
$APPENDER_BY_NAME{$appender_name};
foreach my $logger (values %$LOGGERS_BY_NAME){
$logger->remove_appender($appender_name, 0, 1);
}
$ROOT_LOGGER->remove_appender($appender_name, 0, 1);
delete $APPENDER_BY_NAME{$appender_name};
&reset_all_output_methods
unless $dont_reset_all;
return 1;
}
sub has_appenders {
my($self) = @_;
return $self->{num_appenders};
}
sub log {
my ($self, $priority, @messages) = @_;
confess("log: No priority given!") unless defined($priority);
$_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if
defined $Log::Log4perl::Config::WATCHER;
init_warn() unless $INITIALIZED or $NON_INIT_WARNED;
croak "priority $priority isn't numeric" if ($priority =~ /\D/);
my $which = Log::Log4perl::Level::to_level($priority);
$self->{$which}->($self, @messages,
Log::Log4perl::Level::to_level($priority));
}
sub create_custom_level {
my $level = shift || die("create_custom_level: " .
"forgot to pass in a level string!");
my $after = shift || die("create_custom_level: " .
"forgot to pass in a level after which to " .
"place the new level!");
my $syslog_equiv = shift; my $log_dispatch_level = shift;
die("create_custom_level must be called before init or " .
"first get_logger() call") if ($INITIALIZED);
my %PRIORITY = %Log::Log4perl::Level::PRIORITY;
die("create_custom_level: no such level \"$after\"! Use one of: ",
join(", ", sort keys %PRIORITY)) unless $PRIORITY{$after};
my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1);
my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2);
die(qq{create_custom_level: Calculated level of $cust_prio already exists!
This should only happen if you've made some insane number of custom
levels (like 15 one after another)
You can usually fix this by re-arranging your code from:
create_custom_level("cust1", X);
create_custom_level("cust2", X);
create_custom_level("cust3", X);
create_custom_level("cust4", X);
create_custom_level("cust5", X);
into:
create_custom_level("cust3", X);
create_custom_level("cust5", X);
create_custom_level("cust4", 4);
create_custom_level("cust2", cust3);
create_custom_level("cust1", cust2);
}) if (${Log::Log4perl::Level::LEVELS{$cust_prio}});
Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv,
$log_dispatch_level);
print("Adding prio $level at $cust_prio\n") if _INTERNAL_DEBUG;
# get $LEVEL into namespace of Log::Log4perl::Logger to
# create $logger->foo nd $logger->is_foo
my $name = "Log::Log4perl::Logger::";
my $key = $level;
no strict qw(refs);
# be sure to use ${Log...} as CVS adds log entries for Log
*{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
# now, stick it in the caller's namespace
$name = caller(0) . "::";
*{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
use strict qw(refs);
create_log_level_methods($level);
return 0;
}
sub create_log_level_methods {
my $level = shift || die("create_log_level_methods: " .
"forgot to pass in a level string!");
my $lclevel = lc($level);
my $levelint = uc($level) . "_INT";
my $initial_cap = ucfirst($lclevel);
no strict qw(refs);
*{__PACKAGE__ . "::$lclevel"} = sub {
if(_INTERNAL_DEBUG) {
my $level_disp = (defined $_[0]->{level} ? $_[0]->{level}
: "[undef]");
print "$lclevel: ($_[0]->{category}/$level_disp) [@_]\n";
}
init_warn() unless $INITIALIZED or $NON_INIT_WARNED;
$_[0]->{$level}->(@_, $level) if defined $_[0]->{$level};
};
my $islevel = "is_" . $level;
my $islclevel = "is_" . $lclevel;
*{__PACKAGE__ . "::is_$lclevel"} = sub {
$_[0]->{$islevel}->($_[0], $islclevel);
};
*{__PACKAGE__ . "::is".$initial_cap."Enabled"} =
\&{__PACKAGE__ . "::is_$lclevel"};
use strict qw(refs);
return 0;
}
foreach my $level (keys %Log::Log4perl::Level::PRIORITY){
create_log_level_methods($level);
}
sub init_warn {
CORE::warn "Log4perl: Seems like no initialization happened. " .
"Forgot to call init()?\n";
$NON_INIT_WARNED = 1;
}
sub callerline {
my $message = join ('', @_);
my $caller_offset =
Log::Log4perl::caller_depth_offset(
$Log::Log4perl::caller_depth + 1 );
my ($pack, $file, $line) = caller($caller_offset);
if (not chomp $message) { $message .= " at $file line $line";
if (defined &Thread::tid) {
my $tid = Thread->self->tid;
$message .= " thread $tid" if $tid;
}
}
return ($message, "\n");
}
sub and_warn {
my $self = shift;
CORE::warn(callerline($self->warning_render(@_)));
}
sub and_die {
my $self = shift;
my $arg = $_[0];
my($msg) = callerline($self->warning_render(@_));
if($DIE_DEBUG) {
$DIE_DEBUG_BUFFER = "DIE_DEBUG: $msg";
} else {
if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) {
die("$msg\n");
}
die $arg;
}
}
sub logwarn {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
if ($self->is_warn()) {
my @chomped = @_;
chomp($chomped[-1]);
$self->warn(@chomped);
}
$self->and_warn(@_);
}
sub logdie {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
if ($self->is_fatal()) {
my @chomped = @_;
chomp($chomped[-1]);
$self->fatal(@chomped);
}
$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
$self->and_die(@_) :
exit($Log::Log4perl::LOGEXIT_CODE);
}
sub logexit {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
if ($self->is_fatal()) {
my @chomped = @_;
chomp($chomped[-1]);
$self->fatal(@chomped);
}
exit $Log::Log4perl::LOGEXIT_CODE;
}
sub logcluck {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
local $Carp::CarpLevel =
$Carp::CarpLevel + 1;
my $msg = $self->warning_render(@_);
if ($self->is_warn()) {
my $message = Carp::longmess($msg);
foreach (split(/\n/, $message)) {
$self->warn("$_\n");
}
}
Carp::cluck($msg);
}
sub logcarp {
my $self = shift;
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
my $msg = $self->warning_render(@_);
if ($self->is_warn()) {
my $message = Carp::shortmess($msg);
foreach (split(/\n/, $message)) {
$self->warn("$_\n");
}
}
Carp::carp($msg);
}
sub logcroak {
my $self = shift;
my $arg = $_[0];
my $msg = $self->warning_render(@_);
local $Carp::CarpLevel =
$Carp::CarpLevel + 1;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
if ($self->is_fatal()) {
my $message = Carp::shortmess($msg);
foreach (split(/\n/, $message)) {
$self->fatal("$_\n");
}
}
my $croak_msg = $arg;
if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) {
$croak_msg = $msg;
}
$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
Carp::croak($croak_msg) :
exit($Log::Log4perl::LOGEXIT_CODE);
}
sub logconfess {
my $self = shift;
my $arg = $_[0];
local $Carp::CarpLevel =
$Carp::CarpLevel + 1;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
my $msg = $self->warning_render(@_);
if ($self->is_fatal()) {
my $message = Carp::longmess($msg);
foreach (split(/\n/, $message)) {
$self->fatal("$_\n");
}
}
my $confess_msg = $arg;
if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) {
$confess_msg = $msg;
}
$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
confess($confess_msg) :
exit($Log::Log4perl::LOGEXIT_CODE);
}
sub error_warn {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
if ($self->is_error()) {
$self->error(@_);
}
$self->and_warn(@_);
}
sub error_die {
my $self = shift;
local $Log::Log4perl::caller_depth =
$Log::Log4perl::caller_depth + 1;
my $msg = $self->warning_render(@_);
if ($self->is_error()) {
$self->error($msg);
}
$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
$self->and_die($msg) :
exit($Log::Log4perl::LOGEXIT_CODE);
}
sub more_logging {
my ($self) = shift;
return $self->dec_level(@_);
}
sub inc_level {
my ($self, $delta) = @_;
$delta ||= 1;
$self->level(Log::Log4perl::Level::get_higher_level($self->level(),
$delta));
$self->set_output_methods;
}
sub less_logging {
my ($self) = shift;
return $self->inc_level(@_);
}
sub dec_level {
my ($self, $delta) = @_;
$delta ||= 1;
$self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta));
$self->set_output_methods;
}
1;
__END__
=head1 NAME
Log::Log4perl::Logger - Main Logger Class
=head1 SYNOPSIS
# It's not here
=head1 DESCRIPTION
While everything that makes Log4perl tick is implemented here,
please refer to L<Log::Log4perl> for documentation.
=head1 LICENSE
Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt>
and Kevin Goess E<lt>cpan@goess.orgE<gt>.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Please contribute patches to the project on Github:
http://github.com/mschilli/log4perl
Send bug reports or requests for enhancements to the authors via our
MAILING LIST (questions, bug reports, suggestions/patches):
log4perl-devel@lists.sourceforge.net
Authors (please contact them via the list above, not directly):
Mike Schilli <m@perlmeister.com>,
Kevin Goess <cpan@goess.org>
Contributors (in alphabetical order):
Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles,
Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik
Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang.