File Coverage

blib/lib/Log/Dispatch/Config.pm

Criterion	Covered	Total	%
statement	104	108	96.3
branch	26	34	76.4
condition	6	12	50.0
subroutine	20	20	100.0
pod	0	9	0.0
total	156	183	85.2

package Log::Dispatch::Config;

use strict;
use vars qw($VERSION);
$VERSION = 0.11_02;

use Log::Dispatch;
use base qw(Log::Dispatch);
use fields qw(config);

# caller depth: can be changed from outside
$Log::Dispatch::Config::CallerDepth = 0;

# accessor for symblic reference
sub __instance {
    my $class = shift;
    no strict 'refs';
    my $instance = "$class\::_instance";
    $$instance = shift if @_;
    return $$instance;
}

sub configure {
    my($class, $config) = @_;
    die "no config file or configurator supplied" unless $config;

    # default configurator: AppConfig
    unless (UNIVERSAL::isa($config, 'Log::Dispatch::Configurator')) {
	require Log::Dispatch::Configurator::AppConfig;
	$config = Log::Dispatch::Configurator::AppConfig->new($config);
    }

    # records conf time
    $config->conf_time(time);
    $class->__instance($config);
}

sub configure_and_watch {
    my($class, $config) = @_;
    $class->configure($config);

    # hack: __instance should return conf
    $config = $class->__instance;

    # tells conf to watch config file
    $config->should_watch(1);
}

# backward compatibility
sub Log::Dispatch::instance {
    __PACKAGE__->instance;
}

sub instance {
    my $class = shift;

    my $instance = $class->__instance;
    unless (defined $instance) {
	require Carp;
	Carp::croak("Log::Dispatch::Config->configure not yet called.");
    }

    if (UNIVERSAL::isa($instance, 'Log::Dispatch::Config')) {
        # reload singleton on the fly
	if ($instance->needs_reload) {
	    $class->reload;
	}
    }
    else {
        # first time call: $_instance is L::D::Configurator::*
	$class->__instance($class->create_instance($instance));
    }
    return $class->__instance;
}

sub needs_reload {
    my $self = shift;
    return $self->{config}->should_watch && $self->{config}->needs_reload;
}

sub reload {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $instance = $class->__instance;

    # reconfigure, and returns instance
    my $meth = $instance->{config}->should_watch
	? \&configure_and_watch : \&configure;
    $class->$meth($instance->{config});
    $class->__instance($class->instance);
}

sub create_instance {
    my($class, $config) = @_;
    $config->parse;

    my $global = $config->get_attrs_global;
    my $callback = $class->format_to_cb($global->{format}, 0);
    my %dispatchers;
    foreach my $disp (@{$global->{dispatchers}}) {
        $dispatchers{$disp} = $class->config_dispatcher(
	    $disp, $config->get_attrs($disp),
	);
    }
    my %args;
    $args{callbacks} = $callback if defined $callback;
    my $instance = $class->new(%args);

    for my $dispname (keys %dispatchers) {
	my $logclass = delete $dispatchers{$dispname}->{class};
	$instance->add(
	    $logclass->new(
		name => $dispname,
		%{$dispatchers{$dispname}},
	    ),
	);
    }

    # config info
    $instance->{config} = $config;

    return $instance;
}

sub config_dispatcher {
    my($class, $disp, $var) = @_;

    my $dispclass = $var->{class}
        or die "class param missing for $disp";

    eval qq{require $dispclass};
    die $@ if $@ && $@ !~ /locate/;

    if (exists $var->{format}) {
        $var->{callbacks} = $class->format_to_cb(delete $var->{format}, 2);
    }
    return $var;
}

sub format_to_cb {
    my($class, $format, $stack) = @_;
    return undef unless defined $format;

    # caller() called only when necessary
    my $needs_caller = $format =~ /%[FLP]/;
    return sub {
	my %p = @_;
	$p{p} = delete $p{level};
	$p{m} = delete $p{message};
	$p{n} = "\n";
	$p{'%'} = '%';

 	if ($needs_caller) {
	    my $depth = 0;
	    $depth++ while caller($depth) =~ /^Log::Dispatch/;
 	    $depth += $Log::Dispatch::Config::CallerDepth;
 	    @p{qw(P F L)} = caller($depth);
 	}

	my $log = $format;
	$log =~ s{
	    (%d(?:{(.*?)})?)|	# $1: datetime $2: datetime fmt
	    (?:%([%pmFLPn]))	# $3: others
	}{
	    if ($1 && $2) {
		_strftime($2);
	    }
	    elsif ($1) {
		scalar localtime;
	    }
	    elsif ($3) {
		$p{$3};
	    }
	}egx;
	return $log;
    };
}

{
    use vars qw($HasTimePiece);
    BEGIN { eval { require Time::Piece; $HasTimePiece = 1 }; }

    sub _strftime {
	my $fmt = shift;
	if ($HasTimePiece) {
	    return Time::Piece->new->strftime($fmt);
	} else {
	    require POSIX;
	    return POSIX::strftime($fmt, localtime);
	}
    }
}

1;
__END__