File Coverage

blib/lib/Log/Fu.pm

Criterion	Covered	Total	%
statement	160	171	93.5
branch	42	62	67.7
condition	12	20	60.0
subroutine	29	30	96.6
pod	4	4	100.0
total	247	287	86.0

package Log::Fu;
use strict;
use warnings;
use base qw(Exporter);
use Log::Fu::Common qw(:levels %Config LEVELS fu_term_is_ansi);
use Log::Fu::Common;
use Log::Fu::Color;
use Log::Fu::Chomp;
use Carp qw(carp);
use Sys::Syslog;
use File::Basename qw(basename);

use Constant::Generate [ map {"FLD_$_"} (qw(FH LVL FMT COLOR ISATTY CODE))];
use Constant::Generate [qw(
	LOGFN_TYPE_LIST
	LOGFN_TYPE_SUB_PLAIN
	LOGFN_TYPE_SUB_FMT
)], -start_at => 1;

our @EXPORT = ( map { ("log_$_", "elog_$_" ) } (LEVELS) );
push @EXPORT, map "log_$_"."f", LEVELS;
push @EXPORT, map "elog_$_"."f", LEVELS;
our @EXPORT_OK = qw(set_log_level);

our $VERSION 		= '0.31';

our $SHUSH 			= 0;
our $LINE_PREFIX 	= "";
our $LINE_SUFFIX	= "";

our $TERM_ANSI      = fu_term_is_ansi();
our $TERM_CLEAR_LINE= $TERM_ANSI;

our $USE_WATCHDOG 	= $ENV{LOG_FU_WATCHDOG};
our $NO_STRIP		= $ENV{LOG_FU_NO_STRIP};

our $FORCE_COLOR	= $ENV{LOG_FU_FORCE_COLOR};

our $DISPLAY_SEVERITY = $ENV{LOG_FU_DISPLAY_SEVERITY};
$DISPLAY_SEVERITY ||= 0;

my $ENABLE_SYSLOG;
my $SYSLOG_FACILITY;
my $SYSLOG_STDERR_ECHO = 0;

my $CLEAR_LINE_ESC	= "\033[0J";
#From 0.20
sub Configure {
	my %options = @_;

	if($USE_WATCHDOG) {
		carp "Changing global logging options..";
	}

	foreach my $k (keys %Config) {
		if(exists $options{$k}) {
			$Config{$k} = delete $options{$k};
		}
	}
	if(%options) {
		die "Unknown options: " . join(",", keys %options);
	}
}

#From 0.20
*AddHandler = *Log::Fu::Chomp::AddHandler;
*DelHandler = *Log::Fu::Chomp::DelHandler;

my (%sources,$log_target);
$$log_target = *STDERR;
my $def_target_can_use_color = -t STDERR;

sub _set_source_level {
	my ($source,%params) = @_;
	my @datum;
	my $h = \%params;
	$params{level} = LOG_INFO unless defined $params{level};
	$params{target} = $log_target unless defined $params{target};
	@datum[FLD_LVL, FLD_FH] = @params{qw(level target)};
    if(ref $params{target} eq 'CODE') {
        $datum[FLD_CODE] = $params{target};
    } else {
	    $datum[FLD_COLOR] = -t $datum[FLD_FH];
	    $datum[FLD_ISATTY] = -t $datum[FLD_FH];
    }
	$sources{$source} = \@datum;
}

my $defpkg_key = '__LOG_FU_DEFAULTS__';

_set_source_level($defpkg_key);



sub import {
	my $h;
	#check if we're passed an option hashref
	foreach my $i (0..$#_) {
		if(ref($_[$i]) eq "HASH") {
			$h = delete $_[$i];
		}
	}
	#get the filename of the code that's using us.
	my $pkgname = caller();

	my($ulevel,$target,$subs,$prefix) =
		delete @{$h}{qw(level target subs function_prefix)};

	$prefix ||= "";
	$ulevel = "info" unless defined $ulevel;
	my $level = eval("LOG_".uc($ulevel));
	die "Unknown level $ulevel" unless defined $level;
	_set_source_level($pkgname, level => $level, target => $target);
	if($subs) {
		_gen_subsubs($pkgname, $prefix);
	} else {
		_gen_listsubs($pkgname, $prefix);
		_gen_subsubs($pkgname, $prefix."e");
	}
	return 1;
}

#Called to get stuff for per-package personalization
sub _get_pkg_params {
	#clandestinely does level checking
	my ($pkgname, $level) = @_;
    my $ret = $sources{$pkgname};
    $ret ||= $sources{$defpkg_key};
    if($level < $ret->[FLD_LVL]) {
        $ret = undef;
    }
    return $ret;
}


sub _logger {
	return if $SHUSH; #no logging wanted!
	my ($level_number, $level_name, $stack_offset, $type, @messages) = @_;

	my ($pkgname,$filename,$line) = caller(0+$stack_offset);
	my $pparams = _get_pkg_params($pkgname, $level_number);
	return if !defined $pparams;

	my (undef,undef,undef,$subroutine) = caller(1+$stack_offset);
	$subroutine ||= "-";
	my $outfile = $pparams->[FLD_FH];
	my $basename = basename($filename);
	my $level_str = "[$level_name] ";

	my $message;
	if($type == LOGFN_TYPE_LIST) {
		$message = join(" ", @messages);
	} else {
		my $sub = $messages[0]
			or die "Sub-style logging requested but no sub provided";
		@messages = $sub->();

		if($type == LOGFN_TYPE_SUB_PLAIN) {
			$message = join(" ", @messages);
		} elsif($type == LOGFN_TYPE_SUB_FMT) {
			my $fmt_str = $messages[0];
			$message = sprintf($fmt_str, @messages[1..$#messages]);
		} else {
			die("Unknown logging mode $type");
		}
	}

	#Color stuff...
	if( ($Log::Fu::Color::USE_COLOR && $pparams->[FLD_COLOR]) || $FORCE_COLOR) {
		$message = fu_colorize($level_number, $message);
		if($DISPLAY_SEVERITY <= 0) {
			$level_str = "";
		}
	} elsif($DISPLAY_SEVERITY == -1) {
		$level_str = "";
	}

	$subroutine = fu_chomp($subroutine);

	my $msg = "$level_str$basename:$line ($subroutine): $message\n";

	if ($LINE_PREFIX) {
		$msg =~ s/^(.)/$LINE_PREFIX$1/mg;
	}
	if($LINE_SUFFIX) {
		$msg =~ s/(.)$/$1$LINE_SUFFIX/mg;
	}
	if($pparams->[FLD_ISATTY] && $TERM_CLEAR_LINE) {
		$msg =~ s/^(.)/$CLEAR_LINE_ESC$1/mg
		#Clear the rest of the line, too:
	}
    if(ref $outfile eq 'CODE') {
        $outfile->($msg);
    } else {
	    print $outfile $msg;
    }

	if ($ENABLE_SYSLOG) {
		syslog(syslog_level($level_number), $msg);
	}
}

foreach my $level (LEVELS) {
	#Plain wrappers
	my $fn_name = "log_$level";
	no strict "refs";
	my $const = &{uc("LOG_" . $level)};
	#Offset wrappers
	*{ $fn_name . "_with_offset" } = sub {
		_logger($const, uc($level), 1 + shift, LOGFN_TYPE_LIST, @_);
	};
}

my %export_cache;

sub _gen_listsubs {
	my ($pkgname,$prefix) = @_;
	$prefix ||= "";
	foreach my $level (LEVELS) {
		my $fn_name = $pkgname .  "::$prefix" . "log_$level";
		next if exists $export_cache{$fn_name};
		$export_cache{$fn_name} = 1;
		no strict 'refs';
		my $const = &{uc("LOG_$level")};
		*{ $fn_name } = sub {
			@_ = ($const,uc($level),0,LOGFN_TYPE_LIST,@_);
			goto &_logger;
		};

		*{ $fn_name . "f" } = sub {
			@_ = ($const,uc($level),0,LOGFN_TYPE_LIST,
				  sprintf($_[0], @_[1..$#_]));
			goto &_logger;
		};
	}
}

sub _gen_subsubs {
	my ($pkgname,$prefix) = @_;
	$prefix ||= "";
	foreach my $level (LEVELS) {
		my $fn_name = $pkgname . "::$prefix" . "log_$level";
		next if exists $export_cache{$fn_name};
		$export_cache{$fn_name} = 1;

		no strict 'refs';
		my $const = &{uc("LOG_".$level)};

		*{$fn_name} = sub (&) {
			@_ = ($const,uc($level), 0, LOGFN_TYPE_SUB_PLAIN, $_[0]);
			goto &_logger;
		};

		*{$fn_name . "f"} = sub (&) {
			@_ = ($const, uc($level), 0, LOGFN_TYPE_SUB_FMT, $_[0]);
			goto &_logger;
		};
	}
}

_gen_subsubs(__PACKAGE__, "e");
_gen_listsubs(__PACKAGE__, "");

#From 0.03
sub set_log_level {
	my ($pkgname,$level) = @_;
	$level = eval("LOG_".uc($level));
	return if !defined $level;
	return if !exists $sources{$pkgname};
	$sources{$pkgname}->[FLD_LVL] = $level;
	return 1;
}

#From 0.04
sub start_syslog {
	#Take standard openlog options,
	my $ok = openlog(@_);
	$ENABLE_SYSLOG = 1 if $ok;
	return $ok;
}

sub stop_syslog {
	my $ok = closelog();
	$ENABLE_SYSLOG = 0 if $ok;
	return $ok;
}

1;

__END__