File Coverage

lib/Log/Localized.pm

Criterion	Covered	Total	%
statement	219	221	99.1
branch	80	88	90.9
condition	12	16	75.0
subroutine	34	34	100.0
pod	1	1	100.0
total	346	360	96.1

#################################################################
#
#   Log::Localized - Dispatch log messages depending on local verbosity
#
#   $Id: Localized.pm,v 1.13 2006/05/23 14:03:18 erwan Exp $
#
#   050909 erwan Created
#   060523 erwan Adapt to api change in File::HomeDir
#

package Log::Localized;

use 5.006;
use strict;
use warnings;
use Data::Dumper;
use Carp qw(confess carp);
use Config::Tiny;
use Log::Dispatch;
use Log::Dispatch::Config;
use Log::Dispatch::Screen;
use File::Spec;
use File::HomeDir;

# TODO: load all Dispatcher plugins? is it necessary?

our $VERSION = '0.05';

#----------------------------------------------------------------
#
#   configuration parameters. see BEGIN for default values.
#   may be replaced by the Log::Localized::* rules of the rules file.
#
#----------------------------------------------------------------

my @SEARCH_PATH;        # an array of paths at which to search for verbosity or dispatcher file
my $FILE_RULES;         # name of file containing verbosity rules
my $FILE_DISPATCHERS;   # name of file containing dispatcher config
my $ENV_VERBOSITY;      # name of the environment variable containing the global verbosity
my $PROGRAM;            # name of currently executing program
my $LOG_FORMAT;         # macro for preformatting log messages before dispatching them
my $LLOG_EXPORT_NAME;   # name under which llog should be exported

#----------------------------------------------------------------
#
#   other parameters
#
#----------------------------------------------------------------

# is logging on?
my $LOGGING_ON;

# local verbosity level
use vars qw($VERBOSITY);

# last message level
use vars qw($LEVEL);

# verbosity per namespace and function
my %VERBOSITY_RULES;

# the Log::Dispatch handling all logging
my $DISPATCHER;

#----------------------------------------------------------------
#
#   import - disable or export 'llog' function, eventually under a different name
#

sub import {
    shift;
    my %args = @_;
    my $pkg = caller(0);

    # switch logging on or off
    if (defined $args{log}) {
	if ($args{log} =~ /^[01]$/) {
	    $LOGGING_ON = $args{log};
	} else {
	    confess "ERROR: log => ".$args{log}." is not a valid value. use 0 or 1.\n";
	}
    }

    # load rules file via 'use'
    if (defined $args{rules}) {
	# merge import rules with those from file (if any)
	my $config = Config::Tiny->read_string($args{rules});
	_load_verbosity_rules($config);
	_init_dispatchers();
    }

    # rename
    my $export = $LLOG_EXPORT_NAME;
    if (exists $args{rename}) {
	$export = $args{rename};
    }

    # check ENV_VERBOSITY here too. people may use Log::Localized, then call import alone again later...
    if (exists $ENV{$ENV_VERBOSITY}) {
        $LOGGING_ON = 1;
    }

    # is logging turned on?
    if ($LOGGING_ON) {
	# export log function to calling module
	no strict 'refs';
	*{"${pkg}::$export"} = \&llog;

    } else {
	# disable logging in calling module
	no strict 'refs';
	*{"${pkg}::$export"} = sub {};
    }
}

#################################################################
#
#
#   TEST UTILITIES - functions for testing purpose only
#
#
#################################################################

sub _test_verbosity_rules { return %VERBOSITY_RULES; };
sub _test_program { return $PROGRAM; };

#################################################################
#
#
#   RULES FILE PARSING AND INITIALISATION
#
#
#################################################################

#----------------------------------------------------------------
#
#   _get_rules - try to find a rules file in the search path
#

sub _get_rules {
    foreach my $path (@SEARCH_PATH) {
	my $file = File::Spec->catfile($path,$FILE_RULES);
	if (-f $file) {
	    my $config = Config::Tiny->read($file);
	    llog(1,"loaded verbosity rules from file [$file]");
	    return $config;
        }
    }
    llog(1,"found no verbosity rules file in search path [".join(",",@SEARCH_PATH)."]");
    return undef;
}

#----------------------------------------------------------------
#
#   _load_verbosity_rules - parse Log::Localized rules and configuration
#

sub _load_verbosity_rules {
    my $config = shift;

    if (defined $config) {

	# found rules file => logging is on
	$LOGGING_ON = 1;

	my $reload = 0;

	# be sure to load default rules first
	if (exists $config->{'_'}) {
	    $reload = _load_config_block($config->{'_'});
	}

	# then, rules specific to the running program, if any
	if (exists $config->{$PROGRAM}) {
	    $reload = _load_config_block($config->{$PROGRAM});
	}

        # reload rules if a Log::Localized::use_rules was set
        if ($reload) {
	    llog(1,"reloading rules");
	    %VERBOSITY_RULES = ();
	    _load_verbosity_rules(_get_rules());
        }
    }

    # is global logging on? (may have been redefined by rules options)
    if (defined $ENV{$ENV_VERBOSITY}) {
        $LOGGING_ON = 1;
    }
}

#----------------------------------------------------------------
#
#   _load_config_block - load rules from a block in the Tiny::Config object
#

sub _load_config_block {
    my $block = shift;

    # true if need to reload rules, ie if 'use_rules' option used
    my $reload = 0;

    # define how to parse Log::Localized options
    my $OPTIONS = {
	# option_name => closure loading option
	search_path      => sub { @SEARCH_PATH = _get_search_path($_[0]); },
	use_rules        => sub { $reload = 1; $FILE_RULES = shift; },
	rename           => sub { $LLOG_EXPORT_NAME = shift; },
	dispatchers      => sub { $FILE_DISPATCHERS = shift; },
	format           => sub { $LOG_FORMAT = shift; },
        global_verbosity => sub { $ENV_VERBOSITY = shift; },
    };

    if (ref $block eq 'HASH') {
	foreach my $path (keys %$block) {
	    my $value = $block->{$path};

	    # Log::Localized's own configuration
	    if ($path =~ /^log::localized::(.+)$/i) {
		my $option = $1;
		$option = lc $option;

		# is this a known option? otherwise assume it's a verbosity rule
		if (exists $OPTIONS->{$option}) {
		    llog(1,"setting option [$option]");
		    my $fnc = $OPTIONS->{$option};
		    &$fnc($value);
		    next;
		}
	    }

	    # verbosity rules
	    if ($value !~ /^\d+$/) {
		carp "WARNING: invalid verbosity rules for [$path]. [$value] should be an integer. Ignoring it.";
	    } else {
		if ($path !~ /::/) {
		    # assuming it's a function name in main::
		    $VERBOSITY_RULES{"main::${path}"} = $value;
                    llog(1,"loading rule [main::${path} = $value]");
		} else {
		    # rem: implies that 'A::B' will be mistaken for a method called 'B' in module 'A'
		    # while 'A::B::' will be rightly understood as *all methods* in A::B
		    $VERBOSITY_RULES{$path} = $value;
                    llog(1,"loading rule [${path} = $value]");
		}
	    }
	}
    }

    return $reload;
}

#----------------------------------------------------------------
#
#   _init_dispatchers - create Log::Dispatch dispatchers for Log::Localized
#

sub _init_dispatchers {

    if (defined $FILE_DISPATCHERS) {
	foreach my $path (@SEARCH_PATH) {
	    my $file = File::Spec->catfile($path,$FILE_DISPATCHERS);
	    if (-f $file) {
		# TODO: eventually use configure_and_watch here...
		Log::Dispatch::Config->configure($file);
		$DISPATCHER = Log::Dispatch::Config->instance;
		llog(1,"loaded dispatchers from file [$file]");
	        return;
	    }
	}
	carp "WARNING: no dispatcher definition file [$FILE_DISPATCHERS] found in [".join(",",@SEARCH_PATH)."]. using defaults.";
    }

    # by default, dispatch to stdout and add a newline
    $DISPATCHER = Log::Dispatch->new;
    $DISPATCHER->add(Log::Dispatch::Screen->new(name => 'screen',
						min_level => 'debug',
						stderr => 1,
						callbacks => sub {
						    my %hash = @_;
						    return $hash{message}."\n";
						},
						));
    llog(1,"using default dispatcher to stdout");
}

#----------------------------------------------------------------
#
#   _get_search_path - do keyword substitutiob in search path
#

sub _get_search_path {
    my $strpath = shift; # path in usual unix style path1:path2:...
    my $home = home() or confess "ERROR: your system does not seem to support home directories";
    my @search_path = ();
    foreach my $path (split(":",$strpath)) {
	$path =~ s/\~/$home/g;

	# look for environment variables
	my %pathenv;
	while ($path =~ /\$([^\/\:]+)/gm) {
	    $pathenv{$1} = 1;
	}

	# and substitute them
	foreach my $env (keys %pathenv) {
	    if (exists $ENV{$env}) {
		my $value = $ENV{$env};
		$path =~ s/\$$env/$ENV{$env}/g;
	    }
	}

	push @search_path, $path;

    }

    return @search_path;
}

#################################################################
#
#
#   LOGGING FUNCTIONS
#
#
#################################################################

#----------------------------------------------------------------
#
#   _get_local_verbosity - find out the local verbosity in the code currently executed
#

sub _get_local_verbosity {
    my $pkg = (caller(1))[0];
    my $fnc = (caller(2))[3] || "";

    # _get_local_verbosity logs itself. $log is required to avoid infinite recursion,
    my $log = 1;
    $log = 0 if ($fnc eq "Log::Localized::_get_local_verbosity");

    llog(5,"the function calling llog() is [$fnc] in package [$pkg]") if $log;

    #--------------------------------------------------------------
    #
    #   1. check ENV_LOG_VERBOSITY
    #

    if (defined $ENV{$ENV_VERBOSITY}) {
	my $v = $ENV{$ENV_VERBOSITY};
	if ($v !~ /^\d+$/) {
	    carp "WARNING: environment variable $ENV_VERBOSITY must be an integer. ignoring it.";
	} else {
	    llog(5,"local verbosity is [$v]. (set by $ENV_VERBOSITY)") if $log;
	    return $v;
	}
    }

    #--------------------------------------------------------------
    #
    #   2. check verbosity rules
    #

    my $v;
    if (exists $VERBOSITY_RULES{$fnc}) {
	$v = $VERBOSITY_RULES{$fnc};
	llog(5,"local verbosity is [$v]. (set by verbosity rule file, rule [$fnc])") if $log;
    } elsif (exists $VERBOSITY_RULES{$pkg."::*"}) {
	$v = $VERBOSITY_RULES{$pkg."::*"};
	llog(5,"local verbosity is [$v]. (set by verbosity rule file, rule [$pkg\::*])") if $log;
    } else {
	# lookup parent packages to see if any in rules file
	my @names = split(/::/, $pkg);
	while (@names) {
	    my $subpkg = join("::",@names)."::";
	    if (exists $VERBOSITY_RULES{$subpkg}) {
		$v = $VERBOSITY_RULES{$subpkg};
		llog(5,"local verbosity is [$v]. (set by verbosity rule file, rule [".$subpkg."])") if $log;
		last;
	    }
	    pop @names;
	}
    }

    if (defined $v) {
	return $v;
    }

    #--------------------------------------------------------------
    #
    #   3. check local $VERBOSITY
    #

    if (defined $VERBOSITY) {
	if ($VERBOSITY !~ /^\d+$/) {
	    confess "BUG: some code has set VERBOSITY to a non integer value [$VERBOSITY].\n";
	}
	llog(5,"local verbosity is [$VERBOSITY]. (set locally in calling code)") if $log;
	return $VERBOSITY;
    }

    # do not log anything by default
    return -1;
}

#----------------------------------------------------------------
#
#   llog - display a debug message if local verbosity is high enough
#

# a buffer in which llog stores messages until dispatchers are defined
my @LOG_QUEUE;

sub llog {
    my($level,$msg) = @_;

    # check out arguments
    confess "BUG: llog() expects 2 arguments, but got [".Dumper(@_)."]"
	unless (@_ == 2);

    confess "BUG: llog() expects either a string or a code reference as second argument, but got [".ref($msg)."] [".Dumper($msg)."]"
	unless (defined $msg && (ref($msg) eq "" || ref($msg) eq "CODE"));

    # if dispatchers not yet available
    if (!defined $DISPATCHER) {
	push @LOG_QUEUE,$level,$msg;
	return;
    }

    # now dispatchers are defined. before proceeding, can we empty the queue?
    if (scalar @LOG_QUEUE && (caller(1))[3] ne 'llog') {
	while (scalar(@LOG_QUEUE)) {
	    my $lvl = shift @LOG_QUEUE;
	    my $msg = shift @LOG_QUEUE;
	    llog($lvl,$msg);
	}
    }

    # should we log this message according to current verbosity?
    if ($level <= _get_local_verbosity()) {

	$LEVEL = $level ;

	# did we get a message, or a reference to some code generating this message?
	if (ref($msg) eq "CODE") {
	    # TODO: run $msg() in eval and die if crashed
	    my $txt = &$msg($level);
	    confess "BUG: llog() was passed a function reference that did not return a valid string [".Dumper($txt)."]"
		unless (defined $txt && ref($txt) eq "");
	    $msg = "$txt";
	}

	# format message to display
	my($pkg,$line) = (caller(0))[0,2];
	my $fnc = (caller(1))[3] || "main";
	$fnc =~ s/.+:://g;

	my $txt = $LOG_FORMAT;
	$txt =~ s/\%PKG/$pkg/g;
	$txt =~ s/\%FNC/$fnc/g;
	$txt =~ s/\%LIN/$line/g;
	$txt =~ s/\%LVL/$level/g;
	$txt =~ s/\%MSG/$msg/g;

	$DISPATCHER->log(level => 'info', message => $txt);
    }
}

#################################################################
#
#
#   BEGIN TIME
#
#
#################################################################

# This BEGIN block executes before import().
# Many globals have to be initialized here...

BEGIN {

    # default settings
    @SEARCH_PATH      = _get_search_path(".:~:/");
    $FILE_RULES       = 'verbosity.conf';
    $LOG_FORMAT       = '# [%PKG::%FNC() l.%LIN] [LEVEL %LVL]: %MSG';
    $LLOG_EXPORT_NAME = "llog";
    $VERBOSITY        = 0;
    $ENV_VERBOSITY    = 'LOG_LOCALIZED_VERBOSITY';

    # figure out running program's name
    $PROGRAM = $0;
    $PROGRAM =~ s/(.*\/)//g;

    if (!defined $PROGRAM) {
	confess "ERROR: failed to parse name of running program out of [$0]";
    }

    llog(2,"running program is [$PROGRAM]");

    # set up everything
    _load_verbosity_rules(_get_rules());
    _init_dispatchers();
}

1;

__END__