File Coverage

blib/lib/Log/Agent/Prefixer.pm

Criterion	Covered	Total	%
statement	15	22	68.1
branch	11	14	78.5
condition	1	3	33.3
subroutine	3	9	33.3
pod	0	8	0.0
total	30	56	53.5

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

use strict;

########################################################################
package Log::Agent::Prefixer;

#
# Ancestor for logging channels wishing to implement native prefixing
#

#
# Attribute access: those attributes must be filled by our heirs
#

sub prefix			{ $_[0]->{'prefix'} }
sub stampfmt		{ $_[0]->{'stampfmt'} }
sub showpid			{ $_[0]->{'showpid'} }
sub no_ucfirst		{ $_[0]->{'no_ucfirst'} }
sub no_prefixing	{ $_[0]->{'no_prefixing'} }
sub no_newline		{ $_[0]->{'no_newline'} }
sub crlf			{ $_[0]->{'crlf'} }

#
# ->prefixing_string
#
# Compute prefixing string: stamping and "prefix: " to be emitted before
# the logged string.
#
# Usage:
#
#   $str = $self->prefixing_string();    # no ucfirst support possible
#   $str = $self->prefixing_string(\$log_message);
#
# Leading char of to-be-logged string is upper-cased in-place if
# neither prefix nor pid are present, and behaviour was not disabled
# via a -no_ucfirst, and the second call form with a scalar ref is used.
#
sub prefixing_string {
	my $self = shift;

	#
	# This routine is called often...
	# Bypass the attribute access routines.
	#

	my $prefix = $self->{prefix};
	$prefix = '' unless defined $prefix;
	if ($self->{showpid}) {
		if ($prefix eq '') {
			$prefix = $$;
		} else {
			$prefix .= "[$$]";
		}
	} elsif ($prefix eq '') {
		my $rstr = $_[0];
		$$rstr =~ s/^(.)/\u$1/ if ref $rstr && !$self->{no_ucfirst};
	}
	my $stamp = &{$self->{stampfmt}};
	return
		($stamp eq '' ? '' : "$stamp ") .
		($prefix eq '' ? '' : "$prefix: ");
}

1;	# for require