File Coverage

blib/lib/Log/Any/Adapter/Daemontools.pm

Criterion	Covered	Total	%
statement	98	105	93.3
branch	16	24	66.6
condition	11	15	73.3
subroutine	29	31	93.5
pod	4	8	50.0
total	158	183	86.3

package Log::Any::Adapter::Daemontools;
use 5.008; # need weak reference support
our @ISA; BEGIN { require Log::Any::Adapter::Base; @ISA= 'Log::Any::Adapter::Base' };
use strict;
use warnings;
use Log::Any::Adapter::Util 'numeric_level';
use Log::Any 1.03;
use Log::Any::Adapter::Daemontools::Config;

our $VERSION= '0.101';

# ABSTRACT: Logging adapter suitable for use in a Daemontools-style logging chain


our $global_config;
sub global_config {
	$global_config ||= shift->new_config;
}

sub new_config {
	my $class= shift;
	$class= ref($class) || $class;
	my $cfg= "${class}::Config"->new(@_);
	return $cfg;
}


sub category { shift->{category} }
sub config   { shift->{config} }


# Special carp/croak that ignore Log::Any infrastructure
sub carp { Log::Any::Adapter::Daemontools::Config::carp(@_) }
sub croak { Log::Any::Adapter::Daemontools::Config::croak(@_) }

# Log::Any::Adapter constructor, also named 'init'
sub init {
	my $self= shift;

	$self->{config} ||= $self->global_config;

	# Warn about unsupported/deprecated features from 0.002
	carp "filter is deprecated.  Use config->log_level" if exists $self->{filter};
	carp "dumper is unsupported. See Log::Any::Proxy" if exists $self->{dumper};


	# This constructor gets called for each Adapter instance, so we need
	# to track whether we applied the -init to the config yet.
	if ($self->{'-init'} && !$self->{config}{_adapter_init_applied}) {
		++$self->{config}{_adapter_init_applied};
		$self->{config}->init( $self->{'-init'} );
	}

	# Set up our lazy caching system (re-blesses current object)
	$self->_uncache_config;
}


sub _squelch_base_class { ref($_[0]) || $_[0] }

# Create per-squelch-level subclasses of a given package
# This is an optimization for minimizing overhead when using disabled levels
sub _build_squelch_subclasses {
	my $class= shift;
	my %numeric_levels= ( map { $_ => 1 } -1, map { numeric_level($_) } Log::Any->logging_methods() );
	my %subclass;
	foreach my $level_num (keys %numeric_levels) {
		my $package= $class.'::Squelch'.($level_num+1);
		$subclass{$package}{_squelch_base_class}= sub { $class };
		foreach my $method (Log::Any->logging_methods(), 'fatal') {
			if ($level_num < numeric_level($method)) {
				$subclass{$package}{$method}= sub {};
				$subclass{$package}{"is_$method"}= sub { 0 };
			}
		}
	}
	$subclass{"${class}::Lazy"}{_squelch_base_class}= sub { $class };
	foreach my $method (Log::Any->logging_and_detection_methods(), 'fatal', 'is_fatal') {
		# Trampoline code that lazily re-caches an adaptor the first time it is used
		$subclass{"${class}::Lazy"}{$method}= sub {
			$_[0]->_cache_config;
			goto $_[0]->can($method)
		};
	}

	# Create subclasses and install methods
	for my $pkg (keys %subclass) {
		no strict 'refs';
		@{$pkg.'::ISA'}= ( $class );
		for my $method (keys %{ $subclass{$pkg} }) {
			*{$pkg.'::'.$method}= $subclass{$pkg}{$method};
		}
	}
	1;
}

# The set of adapters which have been "squelch-cached"
# (i.e. blessed into a subclass)
our %_squelch_cached_adapters;

BEGIN {
	foreach my $method ( Log::Any->logging_methods() ) {
		my $m= sub { my $self= shift; $self->{_writer}->($self, $method, @_); };
		no strict 'refs';
		*{__PACKAGE__ . "::$method"}= $m;
		*{__PACKAGE__ . "::is_$method"}= sub { 1 };
	}
	__PACKAGE__->_build_squelch_subclasses();
}

# Cache the ->config settings into this adapter, which also
# re-blesses it based on the current log level.
sub _cache_config {
	my $self= shift;
	$self->{_writer}= $self->config->compiled_writer;
	my $lev= $self->config->log_level_num;
	# Backward compatibility with version 0.002
	if (exists $self->{filter}) {
		$lev= Log::Any::Adapter::Util::NOTICE - _coerce_filter_level($self->{filter});
	}
	bless $self, $self->_squelch_base_class.'::Squelch'.($lev+1);
	$self->config->_register_cached_adapter($self);
}

# Re-bless adapter back to its "Lazy" config cacher class
sub _uncache_config {
	bless $_[0], $_[0]->_squelch_base_class . '::Lazy';
}

#-------------------------------------------------------------------
# Backward compatibility with version 0.002.  Do not use in new code.

sub write_msg {
	my ($self, $level, $message)= @_;
	# Don't bother optimizing and caching
	$self->config->compiled_writer->($self, $level, $message);
}

sub _default_dumper {
	require Data::Dumper;
	my $val= shift;
	local $@;
	my $dump= eval { Data::Dumper->new([$val])->Indent(0)->Terse(1)->Useqq(1)->Quotekeys(0)->Maxdepth(4)->Sortkeys(1)->Dump };
	if (!defined $dump) {
		my $x= "$@";
		$x =~ s/\n//;
		substr($x, 50)= '...' if length $x >= 50;
		$dump= "";
	};
	return $dump;
}

sub _coerce_filter_level {
	my $val= shift;
	my %level_map= (
		trace    => -2,
		debug    => -1,
		info     =>  0,
		notice   =>  1,
		warning  =>  2,
		error    =>  3,
		critical =>  4,
		fatal    =>  4,
	);
	return (!defined $val || $val eq 'none')? $level_map{trace}-1
		: Scalar::Util::looks_like_number($val)? $val
		: exists $level_map{$val}? $level_map{$val}
		: ($val =~ /^debug-(\d+)$/)? $level_map{debug} - $1
		: croak "unknown log level '$val'";
}

1;

__END__