File Coverage

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

Criterion	Covered	Total	%
statement	202	233	86.7
branch	105	152	69.0
condition	40	82	48.7
subroutine	36	41	87.8
pod	17	20	85.0
total	400	528	75.7

package Log::Any::Adapter::Daemontools::Config;
use strict;
use warnings;

# ABSTRACT: Dynamic configuration settings used by Daemontools logging adapters
our $VERSION = '0.102'; # VERSION


use Log::Any::Adapter::Util 'numeric_level', ':levels';

# At top of file where lexical scope is the cleanest
sub _build_writer_eval_in_clean_scope {
	# Args: $self, $code, \$err
	local $@;
	my $output= $_[0]->output; # Needs to be in scope
	my $format= $_[0]->format; # of the eval
	my $coderef= eval $_[1];
	${ $_[2] }= $@ if defined $_[0]; # Save error because $@ is localized
	return $coderef;
}

use Scalar::Util 'weaken', 'refaddr';

# Lazy-load carp, and also remove any Log::Any infrastructure from the trace
our @CARP_NOT= qw( Log::Any::Adapter::Base Log::Any::Adapter Log::Any::Proxy Log::Any );
sub _carp_exclude {
	my $i= 1;
	++$i while caller($i) =~ /^Log::Any/;
	return $i;
}
sub carp  { require Carp; local $Carp::CarpLevel= _carp_exclude; &Carp::carp; }
sub croak { require Carp; local $Carp::CarpLevel= _carp_exclude; &Carp::croak; }


my (%log_level_name, %log_level_num);
BEGIN {
	%log_level_num= (
		none => EMERGENCY-1,
		emergency => EMERGENCY,
		alert => ALERT,
		critical => CRITICAL,
		error => ERROR,
		warning => WARNING,
		notice => NOTICE,
		info => INFO,
		debug => DEBUG,
		trace => TRACE,
		all => TRACE
	);
	%log_level_name= reverse %log_level_num;

	# Add the aliases to the name-to-value mapping
	my %aliases= Log::Any::Adapter::Util::log_level_aliases();
	for (keys %aliases) {
		$log_level_num{$_}= $log_level_num{ $aliases{$_} };
	}
}

sub _parse_log_level {
	my ($spec, $base, $min, $max)= @_;
	my $lev= $spec =~ /^-?\d+$/? $spec  # plain level
		: $spec =~ /^([-+])= (-?\d+)$/? $base + "${1}1" * $2 # += notation
		: $log_level_num{$spec}; # else a level name
	defined $lev or croak "Invalid log level '$spec'";
	$min= EMERGENCY-1 unless defined $min;
	$lev= $min unless $lev >= $min;
	$max= TRACE unless defined $max;
	$lev= $max unless $lev <= $max;
	return $lev;
}

sub log_level {
	my $self= shift;
	if (@_) {
		croak "extra arguments" if @_ > 1;
		my $l= _parse_log_level($_[0], $self->{log_level_num}, $self->{log_level_min_num}, $self->{log_level_max_num});

		# If log level changes, reset the cache
		if ($l != $self->{log_level_num}) {
			$self->{log_level_num}= $l;
			$self->_reset_cached_adapters;
		}
	}
	$log_level_name{ $self->{log_level_num} };
}

sub log_level_min {
	my $self= shift;
	if (@_) {
		croak "extra arguments" if @_ > 1;

		# If log level changes as a result, reset the cache
		$self->{log_level_min_num}= _parse_log_level($_[0], $self->{log_level_min_num}, EMERGENCY-1, $self->{log_level_max_num});
		if ($self->{log_level_min_num} > $self->{log_level_num}) {
			$self->{log_level_num}= $self->{log_level_min_num};
			$self->_reset_cached_adapters;
		}
	}
	$log_level_name{ $self->{log_level_min_num} };
}

sub log_level_max {
	my $self= shift;
	if (@_) {
		croak "extra arguments" if @_ > 1;
		$self->{log_level_max_num}= _parse_log_level($_[0], $self->{log_level_max_num}, $self->{log_level_min_num}, TRACE);

		# If log level changes as a result, reset the cache
		if ($self->{log_level_max_num} < $self->{log_level_num}) {
			$self->{log_level_num}= $self->{log_level_max_num};
			$self->_reset_cached_adapters;
		}
	}
	$log_level_name{ $self->{log_level_max_num} };
}


sub output {
	my $self= shift;
	if (@_) {
		croak "extra arguments" if @_ > 1;
		defined $_[0] && (ref $_[0] eq 'GLOB' || ref $_[0] eq 'CODE' || ref($_[0])->can('print'))
			or croak "Argument must be file handle or coderef";
		$self->{output}= $_[0];
		delete $self->{_writer_cache};
		$self->_reset_cached_adapters unless $self->{writer};
	}
	return defined $self->{output}? $self->{output} : \*STDOUT;
}


sub format {
	my $self= shift;
	if (@_) {
		@_ == 1 && defined $_[0] && (!ref $_[0] or ref $_[0] eq 'CODE')
			or croak "Expected string or coderef";
		if (!ref $_[0]) {
			# Test their supplied code right away, so the error happens in a
			# place where its easy to fix
			my $x= $self->_build_writer_eval_in_clean_scope(
				"sub { "
				.' my ($category, $level, $level_prefix, $file, $file_brief, $line, $package);'
				." $_[0]; "
				."}",
				\my $err
			);
			defined $x && ref $x eq 'CODE'
				or croak "Invalid format (make sure you wrote *code* that returns a string): $err";
		}
		$self->{format}= $_[0];
		delete $self->{_writer_cache};
		$self->_reset_cached_adapters unless $self->{writer};
	}
	defined $self->{format}? $self->{format} : '"$level_prefix$_\n"';
}


sub writer {
	my $self= shift;
	if (@_) {
		@_ == 1 && (!defined $_[0] || ref $_[0] eq 'CODE')
			or croak "Expected coderef or undef";
		$self->{writer}= $_[0];
		$self->_reset_cached_adapters;
	}
}


# Yes, I should use Moo, but in the spirit of Log::Any having no non-core deps,
# I decided to do the same.
sub new {
	my $class= shift;
	my $self= bless {
		log_level_num => INFO,
		log_level_min_num => EMERGENCY-1,
		log_level_max_num => TRACE,
	}, $class;

	# Convert hashref to plain key/value list
	unshift @_, %{ shift @_ }
		if @_ == 1 && ref $_[0] eq 'HASH';

	# Iterate key/value pairs and call the accessor method for each
	while (@_) {
		my ($k, $v)= (shift, shift);
		$self->$k($v);
	}
	$self;
}


our (%env_profile, %argv_profile);
BEGIN {
	$env_profile{1}= { debug => 'DEBUG' };
	$argv_profile{1}= {
		bundle  => 1,
		verbose => qr/^(--verbose|-v)$/,
		quiet   => qr/^(--quiet|-q)$/,
		stop    => '--'
	};
	$argv_profile{consume}= {
		bundle  => 1,
		verbose => qr/^(--verbose|-v)$/,
		quiet   => qr/^(--quiet|-q)$/,
		stop    => '--',
		remove  => 1,
	};
}

my %_init_args= map { $_ => 1 } qw(
	level log_level min level_min log_level_min max level_max log_level_max
	env argv signals handle_signals install_signal_handlers format out output writer
);
sub init {
	my $self= shift;
	my $cfg= (@_ == 1 and ref $_[0] eq 'HASH')? $_[0] : { @_ };
	# Warn on unknown arguments
	my @unknown= grep { !$_init_args{$_} } keys %$cfg;
	carp "Invalid arguments: ".join(', ', @unknown) if @unknown;

	defined $cfg->{$_} and $self->log_level($cfg->{$_})
		for qw: level log_level :;

	defined $cfg->{$_} and $self->log_level_min($cfg->{$_})
		for qw: min level_min log_level_min :;

	defined $cfg->{$_} and $self->log_level_max($cfg->{$_})
		for qw: max level_max log_level_max :;

	# Optional ENV processing
	defined $cfg->{$_} and do {
		my $v= $cfg->{$_};
		$self->process_env( %{
			ref $v eq 'HASH'? $v : $env_profile{$v} || croak "Unknown \"$_\" value $v"
		} );
	} for qw: env process_env :;

	# Optional ARGV parsing
	defined $cfg->{$_} and do {
		my $v= $cfg->{$_};
		$self->process_argv( %{
			ref $v eq 'HASH'? $v : $argv_profile{$v} || croak "Unknown \"$_\" value $v"
		} );
	} for qw: argv process_argv :;

	# Optional installation of signal handlers
	defined $cfg->{$_} and do {
		my $rt= ref($cfg->{$_}) || '';
		$self->install_signal_handlers( %{
			$rt eq 'HASH'? $cfg->{$_}
			: $rt eq 'ARRAY'? { verbose => $cfg->{$_}[0], quiet => $cfg->{$_}[1] }
			: croak "Unknown \"$_\" value $cfg->{$_}"
		} );
	} for qw: signals handle_signals install_signal_handlers :;

	$self->format($cfg->{format})
		if defined $cfg->{format};

	defined $cfg->{$_} and $self->output($cfg->{$_})
		for qw: out output :;

	$self->writer($cfg->{writer})
		if defined $cfg->{writer};

	$self;
}


# We lied.  This is the actual attribute in the implementation
sub log_level_num     { shift->{log_level_num} }
sub log_level_min_num { shift->{log_level_min_num} }
sub log_level_max_num { shift->{log_level_max_num} }


sub log_level_adjust {
	my ($self, $offset)= @_;
	defined $offset && ($offset =~ /^-?\d+$/) && @_ == 2
		or die "Expected offset integer";
	$self->log_level( $self->log_level_num + $offset );
}


my %_process_env_args= ( debug => 1, log_level => 1 );
sub process_env {
	my ($self, %spec)= @_;
	# Warn on unknown arguments
	my @unknown= grep { !$_process_env_args{$_} } keys %spec;
	carp "Invalid arguments: ".join(', ', @unknown) if @unknown;

	if (defined $spec{log_level} && defined $ENV{$spec{log_level}}) {
		$self->log_level($ENV{$spec{log_level}});
	}
	if (defined $spec{debug} && defined $ENV{$spec{debug}}) {
		$self->log_level( $self->debug_level_to_log_level($ENV{$spec{debug}}) );
	}
}

sub debug_level_to_log_level {
	my ($class, $level)= @_;
	$level+= 6 if $level =~ /^-?\d+$/;
	$level;
}


my %_process_argv_args= ( bundle => 1, verbose => 1, quiet => 1, stop => 1, array => 1, remove => 1 );
sub process_argv {
	my $self= shift;
	my $ofs= $self->parse_log_level_opts(array => \@ARGV, @_);
	$self->log_level_adjust($ofs)
		if $ofs;
	1;
}


sub _make_regex_list {
	return () unless defined $_[0];
	return qr/^\Q$_[0]\E$/ unless ref $_[0];
	return map { _make_regex_list($_) } @{ $_[0] } if ref $_[0] eq 'ARRAY';
	return $_[0] if ref $_[0] eq 'Regexp';
	croak "Not a regular expression, string, or array: $_[0]"
}
sub _combine_regex {
	my @list= _make_regex_list(@_);
	return @list == 0? qr/\0^/  # a regex that doesn't match anything
		: @list == 1? $list[0]
		: qr/@{[ join '|', @list ]}/;
}
sub parse_log_level_opts {
	my ($class, %spec)= @_;
	# Warn on unknown arguments
	my @unknown= grep !$_process_argv_args{$_}, keys %spec;
	carp "Invalid arguments: ".join(', ', @unknown) if @unknown;

	defined $spec{array} or croak "Parameter 'array' is required";
	$spec{$_}= _combine_regex($spec{$_}) for qw( stop verbose quiet );
	return _parse_log_level_opts( $spec{array}, \%spec );
}
sub _parse_log_level_opts {
	my ($array, $spec)= @_;
	my $level_ofs= 0;
	for (my $i= 0; $i < @$array; $i++) {
		last if $array->[$i] =~ $spec->{stop};
		if ($array->[$i] =~ /^-[^-=][^-=]+$/ and $spec->{bundle}) {
			# Un-bundle the arguments
			my @un_bundled= map "-$_", split //, substr($array->[$i], 1);
			my $len= @un_bundled;
			# Then filter them as usual
			$level_ofs += _parse_log_level_opts(\@un_bundled, $spec);
			# Then re-bundle them, if altered
			if ($spec->{remove} && $len != @un_bundled) {
				if (@un_bundled) {
					$array->[$i]= '-' . join('', map substr($_,1), @un_bundled);
				} else {
					splice( @$array, $i--, 1 );
				}
			}
		}
		elsif ($array->[$i] =~ $spec->{verbose}) {
			$level_ofs++;
			splice( @$array, $i--, 1 ) if $spec->{remove};
		}
		elsif ($array->[$i] =~ $spec->{quiet}) {
			$level_ofs--;
			splice( @$array, $i--, 1 ) if $spec->{remove};
		}
	}
	return $level_ofs;
}


my %_handle_signal_args= ( verbose => 1, quiet => 1 );
sub install_signal_handlers {
	my ($self, %spec)= @_;
	# Warn on unknown arguments
	my @unknown= grep { !$_handle_signal_args{$_} } keys %spec;
	carp "Invalid arguments: ".join(', ', @unknown) if @unknown;

	$SIG{ $spec{verbose} }= sub { $self->log_level_adjust(1); }
		if $spec{verbose};

	$SIG{ $spec{quiet}   }= sub { $self->log_level_adjust(-1); }
		if $spec{quiet};
}


sub compiled_writer {
	my $self= shift;
	$self->{writer} || ($self->{_writer_cache} ||= $self->_build_writer_cache)
}

# This method combines the output and format settings into a writer.
# It also ensures the output is using autoflush
sub _build_writer_cache {
	my $self= shift;
	my $code= "sub {  \n" . $self->_build_writer_code . "\n}";
	my $err;
	my $writer= $self->_build_writer_eval_in_clean_scope( $code, \$err )
		or croak "Compilation of log writer failed: $err\nSource code is: $code";
	$self->_enable_autoflush($self->output);
	return $writer;
}

# separate from _build_writer_cache so that test cases (and maybe subclasses)
# can inspect the generated code.
sub _build_writer_code {
	my $self= shift;
	my $format= $self->format;
	my $code= '  my ($adapter, $level, $message)= @_;'."\n"
			. '  $message =~ s/\n+$//;'."\n";

	if ($format =~ /\$\{?category(\W|$)/) {
		$code .= '  my $category= $adapter->category;'."\n";
	}
	if ($format =~ /\$\{?(package|file|line|file_brief)(\W|$)/) {
		$code .= '  my ($package,$file,$line);'."\n"
				.'  { my $i= 0; do { ($package, $file, $line)= caller(++$i) } while $package =~ /^Log::Any/; };'."\n";

		$code .= '  my $file_brief= $file;'."\n"
				.'  $file_brief =~ s|.*[\\/]lib[\\/]||;'."\n"
			if $format =~ /\$\{?file_brief(\W|$)/;
	}
	if ($format =~ /\$\{?level_prefix(\W|$)/) {
		$code .= '  my $level_prefix= ($level eq "info")? "" : "$level: ";'."\n";
	}
	my $output= $self->output;
	if (ref $output eq 'GLOB') {
		$code .= '  print $output (';
	} elsif (ref($output)->can('print')) {
		$code .= '  $output->print(';
	} elsif (ref $output eq 'CODE') {
		$code .= '  $output->(';
	} else {
		croak "Unhandled type of output: $output";
	}

	if (ref $format eq 'CODE') {
		# Closure over '$format', rather than deparsing the coderef
		$code .= ' map {; $format->($adapter, $level) } split /\n/, $message)';
	} else {
		$code .= ' map {; '.$format.' } split /\n/, $message)';
	}

	return $code;
}

sub _enable_autoflush {
	my ($self, $thing)= @_;
	# This module tries to be very backward-compatible, and not force people to use IO::Handle
	# if they didn't intend to...
	if (ref $thing eq 'GLOB') {
		my $prev= select($thing);
		$|= 1;
		select($prev);
		1;
	}
	elsif (ref($thing)->can('autoflush')) {
		$thing->autoflush(1);
		1;
	}
	else {
		0;
	}
}

# "Cached Adapters" is conceptually a field of the config object, but then
# it shows a giant mess if/when you Dump() the object, so I'm using this trick
# to keep the list attached to the package instead of the object.
# Object destructor cleans up the list.
our %_cached_adapters;

# Holds a list of weak references to Adapter instances which have cached values from this config
sub _cached_adapters {
	# Use refaddr in case someone subclasses and gets creative with re-blessing objects
	$_cached_adapters{refaddr $_[0]} ||= [];
}
sub DESTROY {
	delete $_cached_adapters{refaddr $_[0]};
}

# Called by an adapter after it caches things from this config to ask that it
# be notified about any changes.
sub _register_cached_adapter {
	my ($self, $adapter)= @_;
	my $cache= $self->_cached_adapters;
	push @$cache, $adapter;
	weaken( $cache->[-1] );
}

# Inform all the Adapters who have cached our settings that the cache is invalid.
sub _reset_cached_adapters {
	my $self= shift;
	my $cache= $self->_cached_adapters;
	$_->_uncache_config for grep { defined } @$cache;
	@$cache= ();
}

1;

__END__