File Coverage

blib/lib/Net/CLI/Interact/Logger.pm

Criterion	Covered	Total	%
statement	36	56	64.2
branch	7	22	31.8
condition	1	3	33.3
subroutine	12	13	92.3
pod	2	3	66.6
total	58	97	59.7

package Net::CLI::Interact::Logger;
{ $Net::CLI::Interact::Logger::VERSION = '2.300005' }

use Moo;
use Sub::Quote;
use MooX::Types::MooseLike::Base qw(HashRef Bool ArrayRef Any);

use Class::Mix qw(genpkg);
use Time::HiRes qw(gettimeofday tv_interval);
use Log::Dispatch::Config; # loads Log::Dispatch
use Log::Dispatch::Configurator::Any;

sub BUILDARGS {
    my ($class, @args) = @_;

    # accept single hash ref or naked hash
    my $params = (ref {} eq ref $args[0] ? $args[0] : {@args});

    # back-compat for old attr name
    $params->{log_stamp} = $params->{log_stamps} if exists $params->{log_stamps};

    return $params;
}

has log_config => (
    is => 'rw',
    isa => HashRef,
    builder => 1,
    trigger => quote_sub(q{ $_[0]->_clear_logger }),
);

sub _build_log_config {
    return {
        dispatchers => ['screen'],
        screen => {
            class => 'Log::Dispatch::Screen',
            min_level => 'debug',
        },
    };
}

has _logger => (
    is => 'ro',
    isa => quote_sub(q{ $_[0]->isa('Log::Dispatch::Config') }),
    builder => 1,
    lazy => 1,
    clearer => 1,
);

# this allows each instance of this module to have its own
# wrapped logger with different configuration.
sub _build__logger {
    my $self = shift;

    my $anon_logger = genpkg();
    {
        no strict 'refs';
        @{"$anon_logger\::ISA"} = 'Log::Dispatch::Config';
    }

    my $config = Log::Dispatch::Configurator::Any->new($self->log_config);
    $anon_logger->configure($config);

    return $anon_logger->instance;
}

has 'log_stamp' => (
    is => 'rw',
    isa => Bool,
    default => quote_sub('1'),
);

has 'log_category' => (
    is => 'rw',
    isa => Bool,
    default => quote_sub('1'),
);

has 'log_start' => (
    is => 'ro',
    isa => ArrayRef,
    default => sub{ [gettimeofday] },
);

has 'log_flags' => (
    is => 'rw',
    isa => Any, # FIXME 'ArrayRef|HashRef[Str]',
    default => sub { {} },
);

my %code_for = (
    debug     => 0,
    info      => 1,
    notice    => 2,
    warning   => 3,
    error     => 4,
    critical  => 5,
    alert     => 6,
    emergency => 7,
);

sub would_log {
    my ($self, $category, $level) = @_;
    return 0 if !defined $category or !defined $level;

    my $flags = (ref $self->log_flags eq ref []
        ? { map {$_ => 'error'} @{$self->log_flags} }
        : $self->log_flags
    );

    return 0 if !exists $code_for{$level};
    return 0 if !exists $flags->{$category};
    return ($code_for{$level} >= $code_for{ $flags->{$category} });
}

sub log {
    my ($self, $category, $level, @msgs) = @_;
    return unless $self->would_log($category, $level);
    @msgs = grep {defined} @msgs;
    return unless scalar @msgs;

    my $prefix = '';
    $prefix .= sprintf "[%11s] ", sprintf "%.6f", (tv_interval $self->log_start, [gettimeofday])
        if $self->log_stamp;
    $prefix .= (substr $category, 0, 2)
        if $self->log_category;

    my $suffix = '';
    $suffix = "\n" if $msgs[-1] !~ m/\n$/;

    $self->_logger->$level($prefix . (' ' x (2 - $code_for{$level})), (join ' ', @msgs) . $suffix);
}

1;

=pod

=head1 NAME

Net::CLI::Interact::Logger - Per-instance multi-target logging, with categories

=head1 SYNOPSIS

 $logger->log($category, $level, @message);

=head1 DESCRIPTION

This module implements a generic logging service, based on L<Log::Dispatch>
but with additional options and configuration. Log messages coming from your
application are categorized, and each category can be enabled/disabled
separately and have its own log level (i.e. C<emergency> .. C<debug>). High
resolution timestamps can be added to log messages.

=head1 DEFAULT CONFIGURATION

Being based on L<Log::Dispatch::Config>, this logger can have multiple
targets, each configured for independent level thresholds. The overall default
configuration is to print log messages to the screen (console), with a minimum
level of C<debug>. Each category (see below) has its own log level as well.

Note that categories, as discussed below, are arbitrary so if a category is
not explicitly enabled or disabled, it is assumed to be B<disabled>. If you
wish to invent a new category for your application, simply think of the name
and begin to use it, with a C<$level> and C<@message> as above in the
SYNOPSIS.

=head1 INTERFACE

=head2 log( $category, $level, @message )

The combination of category and level determine whether the the log messages
are emitted to any of the log destinations. Destinations are set using the
C<log_config> method, and categories are configured using the C<log_flags>
method.

The C<@message> list will be joined by a space character, and a newline
appended if the last message doesn't contain one itself. Messages are
prepended with the first character of their C<$category>, and then indented
proportionally to their C<$level>.

=head2 log_config( \%config )

A C<Log::Dispatch::Config> configuration (hash ref), meaning multiple log
targets may be specified with different minimum level thresholds. There is a
default configuration which emits messages to your screen (console) with no
minimum threshold:

 {
     dispatchers => ['screen'],
     screen => {
         class => 'Log::Dispatch::Screen',
         min_level => 'debug',
     },
 };

=head2 log_flags( \@categories | \%category_level_map )

The user is expected to specify which log categories they are interested in,
and at what levels. If a category is used in the application for logging but
not specified, then it is deemed B<disabled>. Hence, even though the default
destination log level is C<debug>, no messages are emitted until a category is
enabled.

In the array reference form, the list should contain category names, and they
will all be mapped to the C<error> level:

 $logger->log_flags([qw/
     network
     disk
     io
     cpu
 /]);

In the hash reference form, the keys should be category names and the values
log levels from the list below (ordered such that each level "includes" the
levels I<above>):

 emergency
 alert
 critical
 error
 warning
 notice
 info
 debug

For example:

 $logger->log_flags({
     network => 'info',
     disk    => 'debug',
     io      => 'critical',
     cpu     => 'debug',
 });

Messages at or above the specified level will be passed on to the
C<Log::Dispatch> target, which may then specify an overriding threshold.

=head2 C< Net::CLI::Interact->default_log_categories() >>

Not a part of this class, but the only way to retrieve a list of the current
log categories used in the L<Net::CLI::Interact> distribution source. Does not
take into account any log categories added by the user.

=head2 log_stamp( $boolean )

Enable (the default) or disable the display of high resolution interval
timestamps with each log message.

=head2 log_category( $boolean )

Enable (the default) or disable the display of the first letters of the
category name with each log message.

=head2 log_start( [$seconds, $microseconds] )

Time of the start for generating a time interval when logging stamps. Defaults
to the result of C<Time::HiRes::gettimeofday> at the point the module is
loaded, in list context.

=head2 would_log( $category, $level )

Returns True if, according to the current C<log_flags>, the given C<$category>
is enabled at or above the threshold of C<$level>, otherwise returns False.
Note that the C<Log::Dispatch> targets maintain their own thresholds as well.

=cut