File Coverage

blib/lib/Log/Agent/Tag/Callback.pm

Criterion	Covered	Total	%
statement	26	30	86.6
branch	4	8	50.0
condition	1	3	33.3
subroutine	5	5	100.0
pod	1	3	33.3
total	37	49	75.5

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

use strict;

########################################################################
package Log::Agent::Tag::Callback;

require Log::Agent::Tag;
use vars qw(@ISA);
@ISA = qw(Log::Agent::Tag);

#
# ->make
#
# Creation routine.
#
# Calling arguments: a hash table list.
#
# The keyed argument list may contain:
#	-POSTFIX	whether to postfix log message or prefix it.
#   -SEPARATOR  separator string to use between tag and message
#   -NAME       tag's name (optional)
#   -CALLBACK   Callback object
#
# Attributes:
#   callback    the Callback object
#
sub make {
	my $self = bless {}, shift;
	my (%args) = @_;
	my ($name, $postfix, $separator, $callback);

	my %set = (
		-name		=> \$name,
		-callback	=> \$callback,
		-postfix	=> \$postfix,
		-separator	=> \$separator,
	);

	while (my ($arg, $val) = each %args) {
		my $vset = $set{lc($arg)};
		next unless ref $vset;
		$$vset = $val;
	}

	unless (defined $callback) {
		require Carp;
		Carp::croak("Argument -callback is mandatory");
	}

	unless (ref $callback && $callback->isa("Callback")) {
		require Carp;
		Carp::croak("Argument -callback needs a Callback object");
	}

	$self->_init($name, $postfix, $separator);
	$self->{callback} = $callback;

	return $self;
}

#
# Attribute access
#

sub callback	{ $_[0]->{callback} }

#
# Defined routines
#

#
# ->string			-- defined
#
# Build tag string by invoking callback.
#
sub string {
	my $self = shift;

	#
	# Avoid recursion, which could happen if another logxxx() call is made
	# whilst within the callback.
	#
	# Assumes mono-threaded application.
	#

	return sprintf 'callback "%s" busy', $self->name if $self->{busy};

	$self->{busy} = 1;
	my $string = $self->callback->call();
	$self->{busy} = 0;

	return $string;
}

1;			# for "require"
__END__