File Coverage

blib/lib/Log/Dispatch/Config.pm

Criterion	Covered	Total	%
statement	99	103	96.1
branch	25	32	78.1
condition	7	12	58.3
subroutine	20	21	95.2
pod	0	9	0.0
total	151	177	85.3

package Log::Dispatch::Config;

use strict;
use vars qw($VERSION);
$VERSION = "1.04";

use Log::Dispatch 2.00;
use base qw(Log::Dispatch);

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

sub _croak { require Carp; Carp::croak(@_); }

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

sub _configurator_for {
    my($class, $stuff) = @_;
    return $stuff if UNIVERSAL::isa($stuff, 'Log::Dispatch::Configurator');
    require Log::Dispatch::Configurator::AppConfig;
    return Log::Dispatch::Configurator::AppConfig->new($stuff);
}

sub configure {
    my($class, $stuff) = @_;
    _croak "no config file or configurator supplied" unless $stuff;
    my $config = $class->_configurator_for($stuff);
    $config->myinit;
    $class->__instance($config);
}

sub configure_and_watch {
    my $class = shift;
    $class->configure(@_);
    $class->__instance->should_watch(1); # tells conf to watch config file
}

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

sub instance {
    my $class = shift;

    my $instance = $class->__instance or _croak "configure not yet called.";
    if ($instance->isa('Log::Dispatch::Config')) {
        # reload singleton on the fly
	$class->reload if $instance->needs_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;
    $instance->{config}->reload;
    $class->__instance($class->create_instance($instance->{config}));
}

sub create_instance {
    my($class, $config) = @_;
    $config->{LDC_ctime} = time;	# creation time

    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}},
	    ),
	);
    }

    $instance->{config} = $config;
    return $instance;
}

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

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

    eval qq{require $dispclass};
    _croak $@ 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__