File Coverage

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

Criterion	Covered	Total	%
statement	90	155	58.0
branch	17	56	30.3
condition	11	22	50.0
subroutine	22	38	57.8
pod	6	8	75.0
total	146	279	52.3

package Log::Any::Adapter::Filtered;
use strict;
use warnings;
use parent 'Log::Any::Adapter::Base';
use Carp ();
use Scalar::Util ();
use Data::Dumper ();

our $VERSION= '0.000000';

# ABSTRACT: Logging adapter base class with support for filtering


our %level_map;              # mapping from level name to numeric level
BEGIN {
	# Initialize globals, and use %ENV vars for defaults
	%level_map= (
		min       => -1,
		trace     => -1,
		debug     =>  0,
		info      =>  1,
		notice    =>  2,
		warning   =>  3,
		error     =>  4,
		critical  =>  5,
		alert     =>  6,
		emergency =>  7,
		max       =>  7,
	);
	# Make sure we have numeric levels for all the core logging methods
	for ( Log::Any->logging_methods() ) {
		if (!defined $level_map{$_}) {
			# This is an attempt at being future-proof to the degree that a new level
			# added to Log::Any won't kill a program using this logging adapter,
			# but will emit a warning so it can be fixed properly.
			warn __PACKAGE__." encountered unknown log level '$_'";
			$level_map{$_}= 4;
		}
	}
	# Now add numeric values for all the aliases, too
	my %aliases= Log::Any->log_level_aliases;
	$level_map{$_} ||= $level_map{$aliases{$_}}
		for keys %aliases;
}

sub _log_level_value { $level_map{$_[1]} }


sub filter { $_[0]{filter} }


sub _coerce_filter_level {
	my ($class, $val)= @_;
	my $n;
	return (!defined $val || $val eq 'none')? $class->_log_level_value('min') - 1
		: ($val eq 'all')? $class->_log_level_value('max')
		: defined ($n= $class->_log_level_value($val))? $n
		: ($val =~ /^([A-Za-z]+)([-+][0-9]+)$/) && defined ($n= $class->_log_level_value(lc $1))? $n + $2
		: Carp::croak "unknown log level '$val'";
}


our %_default_filter;
BEGIN {
	%_default_filter= ( '' => 'debug' );
}

sub _default_filter_stack {
	return ( \%_default_filter );
}

sub _init_default_filter_var {
	my $class= shift;
	local $@;
	eval '
		package '.$class.';
		our %_default_filter;
		sub _default_filter_stack {
			return ( \%_default_filter, $_[0]->SUPER::_default_filter_stack );
		}
		1;' == 1
		or die my $e= $@;
}

sub default_filter_for {
	my ($class, $category)= @_;
	my @filter_stack= $class->_default_filter_stack;
	if (defined $category && length $category) {
		defined $_->{$category} && return $_->{$category}
			for @filter_stack;
	}
	defined $_->{''} && return $_->{''}
		for @filter_stack;
}

sub set_default_filter_for {
	my ($class, $category, $value)= @_;
	$class->_coerce_filter_level($value); # just testing for validity
	$category= '' unless defined $category;
	no strict 'refs';
	defined *{ $class . '::_default_filter' } or $class->_init_default_filter_var;
	${ $class . '::_default_filter' }{ $category }= $value;
}


sub dumper {
	$_[0]{dumper}= $_[1] if @_ > 1;
	$_[0]{dumper} ||= $_[0]->default_dumper
}

sub default_dumper {
	return \&_default_dumper;
}

sub _default_dumper {
	my $val= shift;
	my $s= Data::Dumper->new([$val])->Indent(0)->Terse(1)->Useqq(1)->Quotekeys(0)
		->Maxdepth(Scalar::Util::blessed($val)? 2 : 4)->Sortkeys(1)->Dump;
	substr($s, 2000-3)= '...' if length $s > 2000;
	$s;
}

sub category { $_[0]{category} }


sub write_msg {
	my ($self, $level_name, $str)= @_;
	print STDERR "$level_name: $str\n";
}


sub init {
	my $self= shift;
	# Apply default dumper if not set
	$self->{dumper} ||= $self->default_dumper;
	# Apply default filter if not set
	defined $self->{filter}
		or $self->{filter}= $self->default_filter_for($self->{category});

	# Rebless to a "level filter" package, which is a subclass of this one
	# but with some methods replaced by empty subs.
	# If log level is less than the minimum value, we show all messages, so no need to rebless.
	(ref($self).'::Filter0')->can('info') or $self->_build_filtered_subclasses;
	my $filter_value= $self->_coerce_filter_level($self->filter);
	my $min_value= $self->_log_level_value('min');
	if ($filter_value >= $min_value) {
		my $max_value= $self->_log_level_value('max');
		$filter_value= $max_value if $filter_value > $max_value;
		my $pkg_suffix= $filter_value - $min_value;
		bless $self, ref($self)."::Filter$pkg_suffix"
	}

	return $self;
}



# Programmatically generate all the info, infof, is_info ... methods
sub _build_logging_methods {
	my $class= shift;
	$class= ref $class if Scalar::Util::blessed($class);
	my %seen;
	# We implement the stock methods, but also 'fatal' because in my mind, fatal is not
	# an alias for 'critical' and I want to see a prefix of "fatal" on messages.
	for my $method ( grep { !$seen{$_}++ } Log::Any->logging_methods(), 'fatal' ) {
		my ($impl, $printfn);
		if ($class->_log_level_value($method) >= $class->_log_level_value('info')) {
			# Standard logging.  Concatenate everything as a string.
			$impl= sub {
				(shift)->write_msg($method, join('', map { !defined $_? '' : $_ } @_));
			};
			# Formatted logging.  We dump data structures (because Log::Any says to)
			$printfn= sub {
				my $self= shift;
				$self->write_msg($method, sprintf((shift), map { !defined $_? '' : !ref $_? $_ : $self->dumper->($_) } @_));
			};
		} else {
			# Debug and trace logging.  For these, we trap exceptions and dump data structures
			$impl= sub {
				my $self= shift;
				local $@;
				eval { $self->write_msg($method, join('', map { !defined $_? '' : !ref $_? $_ : $self->dumper->($_) } @_)); 1 }
					or $self->warn("$@");
			};
			$printfn= sub {
				my $self= shift;
				local $@;
				eval { $self->write_msg($method, sprintf((shift), map { !defined $_? '' : !ref $_? $_ : $self->dumper->($_) } @_)); 1; }
					or $self->warn("$@");
			};
		}

		# Install methods in base package
		no strict 'refs';
		*{"${class}::$method"}= $impl;
		*{"${class}::${method}f"}= $printfn;
		*{"${class}::is_$method"}= sub { 1 };
	}
	# Now create any alias that isn't handled
	my %aliases= Log::Any->log_level_aliases;
	for my $method (grep { !$seen{$_}++ } keys %aliases) {
		no strict 'refs';
		*{"${class}::$method"}=    *{"${class}::$aliases{$method}"};
		*{"${class}::${method}f"}= *{"${class}::$aliases{$method}f"};
		*{"${class}::is_$method"}= *{"${class}::is_$aliases{$method}"};
	}
}

# Create per-filter-level packages
# This is an optimization for minimizing overhead when using disabled levels
sub _build_filtered_subclasses {
	my $class= shift;
	$class= ref $class if Scalar::Util::blessed($class);
	my $min_level= $class->_log_level_value('min');
	my $max_level= $class->_log_level_value('max');
	my $pkg_suffix_ofs= 0 - $min_level;

	# Create packages, inheriting from $class
	for ($min_level .. $max_level) {
		my $suffix= $_ - $min_level;
		no strict 'refs';
		push @{"${class}::Filter${suffix}::ISA"}, $class;
	}
	# For each method, mask it in any package of a higher filtering level
	for my $method (keys %level_map) {
		my $level= $class->_log_level_value($method);
		# Suppress methods in all higher filtering level packages
		for ($level .. $max_level) {
			my $suffix= $_ - $min_level;
			no strict 'refs';
			*{"${class}::Filter${suffix}::$method"}= sub {};
			*{"${class}::Filter${suffix}::${method}f"}= sub {};
			*{"${class}::Filter${suffix}::is_$method"}= sub { 0 }
		}
	}
}

BEGIN {
	__PACKAGE__->_build_logging_methods;
}

1;

__END__