File Coverage

blib/lib/Log/Agent/Logger.pm

Criterion	Covered	Total	%
statement	132	163	80.9
branch	39	68	57.3
condition	4	9	44.4
subroutine	17	25	68.0
pod	11	12	91.6
total	203	277	73.2

#!./perl
###########################################################################
#
#   Logger.pm
#
#   Copyright (C) 1999-2000 Raphael Manfredi.
#   Copyright (C) 2015 Mark Rogaski, [e-mail];
#   all rights reserved.
#
#   See the README file included with the
#   distribution for license information.
#
##########################################################################

use strict;

########################################################################
package Log::Agent::Logger;

use vars qw($VERSION);

our $VERSION = '0.200';
$VERSION = eval $VERSION;

use Log::Agent;
use Log::Agent::Formatting qw(tag_format_args);
use Log::Agent::Priorities qw(:LEVELS level_from_prio prio_from_level);
use Getargs::Long qw(ignorecase);

BEGIN {
	no strict 'refs';
	my %fn;
	%fn = (
		'emerg'		=> q/['emerg',   EMERG]/,
		'emergency'	=> q/['emerg',   EMERG]/,
		'alert'		=> q/['alert',   ALERT]/,
		'crit'		=> q/['crit',    CRIT]/,
		'critical'	=> q/['crit',    CRIT]/,
		'err'		=> q/['err',     ERROR]/,
		'error'		=> q/['err',     ERROR]/,
		'warning',	=> q/['warning', WARN]/,
		'warn',		=> q/['warning', WARN]/,
		'notice'	=> q/['notice',  NOTICE]/,
		'info'		=> q/['info',    INFO]/,
		'debug'		=> q/['debug',   DEBUG]/,
	) unless defined &emergency;
	for my $sub (keys %fn) {
		my $prilvl = $fn{$sub};
		*$sub = eval qq{
			sub {
				my \$self = shift;
				if (ref \$_[0] eq 'CODE') {
					\$self->_log_fn($prilvl, \\\@_);
				} else {
					\$self->_log($prilvl, \\\@_);
				}
				return;
			}
		};
	}
}

#
# ->make
#
# Creation routine.
#
# Attributes (and switches that set them):
#
#   -channel	logging channel
#   -max_prio	maximum priority logged (included)
#   -min_prio	minimum priority logged (included)
#   -caller     customizes the caller information to be inserted
#   -priority   customizes the priority information to be inserted
#   -tags   	list of user-defined tags to add to messages
#
sub make {
	my $self = bless {}, shift;
	my ($caller, $priority, $tags);

	(
		$self->{channel}, $self->{max_prio}, $self->{min_prio},
		$caller, $priority, $tags
	) = xgetargs(@_,
		-channel	=> 'Log::Agent::Channel',
		-max_prio	=> ['s', DEBUG],
		-min_prio	=> ['s', EMERG],
		-caller		=> ['ARRAY'],
		-priority	=> ['ARRAY'],
		-tags		=> ['ARRAY'],
	);

	#
	# Always use numeric priorities internally
	#

	$self->{max_prio} = level_from_prio($self->{max_prio})
		if $self->{max_prio} =~ /^\D+$/;

	$self->{min_prio} = level_from_prio($self->{min_prio})
		if $self->{min_prio} =~ /^\D+$/;

	$self->set_priority_info(@$priority) if defined $priority;
	$self->set_caller_info(@$caller) if defined $caller;

	#
	# Handle -tags => [  ]
	#

	if (defined $tags) {
		my $type = "Log::Agent::Tag";
		if (grep { !ref $_ || !$_->isa($type) } @$tags) {
			require Carp;
			Carp::croak("Argument -tags must supply list of $type objects");
		}
		if (@$tags) {
			require Log::Agent::Tag_List;
			$self->{tags} = Log::Agent::Tag_List->make(@$tags);
		}
	}

	return $self;
}

#
# Attribute access
#

sub channel			{ $_[0]->{channel} }
sub max_prio		{ $_[0]->{max_prio} }
sub min_prio		{ $_[0]->{min_prio} }
sub tags			{ $_[0]->{tags} || $_[0]->_init_tags }

sub max_prio_str	{ prio_from_level $_[0]->{max_prio} }
sub min_prio_str	{ prio_from_level $_[0]->{min_prio} }

sub set_max_prio
	{ $_[0]->{max_prio} = $_[1] =~ /^\D+$/ ? level_from_prio($_[1]) : $_[1] }
sub set_min_prio
	{ $_[0]->{min_prio} = $_[1] =~ /^\D+$/ ? level_from_prio($_[1]) : $_[1] }

#
# ->close
#
# Close underlying channel, and detach from it.
#
sub close {
	my $self = shift;
	my $channel = $self->{channel};
	return unless defined $channel;		# Already closed
	$self->{channel} = undef;
	$channel->close;
}

#
# ->set_caller_info
#
# Change settings of caller tag information.
# Giving an empty list removes caller tagging.
#
sub set_caller_info {
	my $self = shift;

	unless (@_) {
		delete $self->{caller};
		return;
	}

	require Log::Agent::Tag::Caller;
	$self->{caller} = Log::Agent::Tag::Caller->make(-offset => 4, @_);
	return;
}

#
# ->set_priority_info
#
# Change settings of caller tag information.
# Giving an empty list removes priority tagging.
#
sub set_priority_info {
	my $self = shift;
	my @info = @_;

	unless (@info) {
		delete $self->{priority};
		return;
	}

	$self->{priority} = \@info;		# For objects created in _prio_tag()

	#
	# When settings are changes, we need to clear the cache of priority
	# tags generated by _prio_tag().
	#

	$self->{prio_cache} = {};		# Internal for ->_prio_tag()
	return;
}


#
# ->_log
#
# Emit log at given priority, if within priority bounds.
#
sub _log {
	my ($self, $prilvl) = splice(@_, 0, 2);
	my $channel = $self->{channel};
	return unless defined $channel;			# Closed

	#
	# Prune call if we're not within bounds.
	# $prilvl is seomthing like ["error", ERROR].
	#

	my $lvl = $prilvl->[1];
	return if $lvl > $self->{max_prio} || $lvl < $self->{min_prio};

	#
	# Issue logging.
	#

	my $priority = $self->_prio_tag(@$prilvl) if defined $self->{priority};

	$channel->write($prilvl->[0],
		tag_format_args($self->{caller}, $priority, $self->{tags}, @_));

	return;
}

#
# ->_log_fn
#
# Emit log at given priority, if within priority bounds.
# The logged string needs to be computed by calling back a routine.
#
sub _log_fn {
	my ($self, $prilvl) = splice(@_, 0, 2);
	my $channel = $self->{channel};
	return unless defined $channel;			# Closed

	#
	# Prune call if we're not within bounds.
	# $prilvl is seomthing like ["error", ERROR].
	#

	my $lvl = $prilvl->[1];
	return if $lvl > $self->{max_prio} || $lvl < $self->{min_prio};

	#
	# Issue logging.
	#

	my $fn = shift @{$_[0]};
	my $msg = &$fn(@{$_[0]});
	return unless length $msg;				# Null messsage, don't log

	my $priority = $self->_prio_tag(@$prilvl) if defined $self->{priority};

	$channel->write($prilvl->[0],
		tag_format_args($self->{caller}, $priority, $self->{tags}, [$msg]));

	return;
}

#
# _prio_tag
#
# Returns Log::Agent::Tag::Priority message that is suitable for tagging
# at this priority/level, if configured to log priorities.
#
# Objects are cached into `prio_cache'.
#
sub _prio_tag {
	my $self = shift;
	my ($prio, $level) = @_;
	my $ptag = $self->{prio_cache}->{$prio, $level};
	return $ptag if defined $ptag;

	require Log::Agent::Tag::Priority;

	#
	# Common attributes (formatting, postfixing, etc...) are held in
	# the `priorities' attribute.  We add the priority/level here.
	#

	$ptag = Log::Agent::Tag::Priority->make(
		-priority	=> $prio,
		-level		=> $level,
		@{$self->{priority}}
	);

	return $self->{prio_cache}->{$prio, $level} = $ptag;
}

#
# ->_init_tags
#
# Initialize the `tags' attribute the first time it is requested
# Returns its value.
#
sub _init_tags {
	my $self = shift;
	require Log::Agent::Tag_List;
	return $self->{tags} = Log::Agent::Tag_List->make();
}

1;	# for require
__END__