File Coverage

blib/lib/MojoX/Log/Log4perl.pm

Criterion	Covered	Total	%
statement	53	62	85.4
branch	9	14	64.2
condition	4	4	100.0
subroutine	19	23	82.6
pod	10	14	71.4
total	95	117	81.2

package MojoX::Log::Log4perl;
use Mojo::Base 'Mojo::EventEmitter';
use Log::Log4perl;

use warnings;
use strict;

our $VERSION = '0.12';

has history          => sub { [] };
has max_history_size => 10;

my $format_warning_was_shown = 0;

# development notes: Mojo::Log provides 'path' 'handle' and 'format'
# to handle log location and formatting. Those make no sense in a Log4perl
# environment (where you can set appenders as you wish) so they are
# not implemented here; 'format' simply returns the passed-in strings joined by
# newlines as otherwise Mojo::Log complains (RT #98034).
sub path   { warn 'path() is not implemented in MojoX::Log::Log4perl. Please use appenders.'   }
sub handle { warn 'handle() is not implemented in MojoX::Log::Log4perl. Please use appenders.' }
sub format {
    if (!$format_warning_was_shown) {
        $format_warning_was_shown = 1;
        warn 'format() is not properly implemented in MojoX::Log::Log4perl. Please use appenders.';
    }
    return sub { '[' . localtime(shift) . '] [' . shift() . '] ' . join("\n", @_, '') };
}

# development notes: Mojo::Log provides 'context'
# Mojo::Log (Mojolicious 8.23) was updated to add method context which
# needs to exist here or we die
sub context {
    my ($self) = @_;
    return $self;
}

sub new {
	my ($class, $conf_file, $watch) = (@_);

	$conf_file ||= {
		'log4perl.rootLogger' => 'DEBUG, SCREEN',
		'log4perl.appender.SCREEN' => 'Log::Log4perl::Appender::Screen',
		'log4perl.appender.SCREEN.layout' => 'PatternLayout',
		'log4perl.appender.SCREEN.layout.ConversionPattern' => '[%d] [mojo] [%p] %m%n',
	};

	if ($watch) {
		Log::Log4perl::init_and_watch($conf_file, $watch);
	}
	else {
		Log::Log4perl->init_once($conf_file);
	}

	my $self = $class->SUPER::new();
	$self->on( message => \&_message );
	return $self;
}

# Hmm. Ah, a picture of my mommy.
{
    no strict 'refs';
    for my $level (
      qw/ trace
          debug
          info
          warn
          error
          fatal
          logwarn
          logdie
          error_warn
          error_die
          logcarp
          logcluck
          logcroak
          logconfess
        / ) {

        *{ __PACKAGE__ . "::$level" } =
            sub {
                return shift->emit( message => $level => @_ );
            };
    }
}

sub _message {
	my ($self, $level, @message ) = @_;
	my $depth = 3;
	local $Log::Log4perl::caller_depth
      = $Log::Log4perl::caller_depth + $depth;

	if ($self->_get_logger( $depth )->$level( @message )) {
		my $history = $self->history;
		my $max     = $self->max_history_size;
		push @$history => [ time, $level, @message ];
		splice (@$history, 0, scalar @$history - $max)
		    if scalar @$history > $max;
	}
	return $self;
}

sub log { shift->emit('message', lc(shift), @_) }

sub is_trace { shift->_get_logger->is_trace }
sub is_debug { shift->_get_logger->is_debug }
sub is_info  { shift->_get_logger->is_info  }
sub is_warn  { shift->_get_logger->is_warn  }
sub is_error { shift->_get_logger->is_error }
sub is_fatal { shift->_get_logger->is_fatal }

sub is_level {
	my ($self, $level) = (@_);
	return 0 unless $level;

	if ($level =~ m/^(?:trace|debug|info|warn|error|fatal)$/o) {
		my $is_level = "is_$level";
		return $self->_get_logger->$is_level;
	}
	else {
		return 0;
	}
}

sub level {
	my ($self, $level) = (@_);
	my $logger = $self->_get_logger;

	require Log::Log4perl::Level;
	if ($level) {
		return $logger->level( Log::Log4perl::Level::to_priority(uc $level) );
	}
	else {
		return Log::Log4perl::Level::to_level( $logger->level() );
	}
}

# $_[0] == $self, $_[1] == optional caller level (defaults to 1)
sub _get_logger {
	return Log::Log4perl->get_logger( scalar caller( $_[1] || 1 ) );
}

1;
__END__