File Coverage

blib/lib/MooX/Role/Chatty.pm

Criterion	Covered	Total	%
statement	67	68	98.5
branch	21	24	87.5
condition	7	12	58.3
subroutine	13	13	100.0
pod	2	2	100.0
total	110	119	92.4

#!perl
#

use 5.010;
use strict;
use warnings;

package MooX::Role::Chatty;

our ($VERSION) = '1.01';

use Scalar::Util;
use Type::Tiny::Duck;

use Moo::Role 2;

sub _prefix_message {
    my ( $category, $level, $message ) = @_;
    my ( $sec, $min, $hr, $mday, $mon, $yr ) = localtime;
    state $months = [qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec )];
    $yr += 1900;
    $mon = $months->[$mon];
    $message = '' unless defined $message;
    my @lines = split /\n/, $message;

    return join(
        "\n",
        map {
            sprintf '%04d-% 3s-%02d %02d:%02d:%02d :: %s',
              $yr, $mon, $mday, $hr, $min, $sec, $_
        } @lines
    );
}

has 'verbose' => (
    is      => 'rw',
    isa     => sub { shift =~ /^\d+$/; },
    default => 0,
    trigger => 1
);

sub _verbose_to_log_level {
    my $self    = shift;
    my $verbose = $self->verbose;

    return 0 unless $verbose;

    require Log::Any::Adapter::Util;
    state $base_level = Log::Any::Adapter::Util::numeric_level('notice');

    return $verbose + $base_level - !!( $verbose > 0 );
}

sub _trigger_verbose {
    my $self = shift;
    return unless $self->_internal_logger;
    my $category = Scalar::Util::blessed($self) || $self;
    my $my_adapter = $self->_internal_logger->adapter ==
      Log::Any->get_logger( category => $category )->adapter;
    Log::Any::Adapter->remove( $self->_internal_logger->adapter );

    # If the current adapter is the one we installed, replace it.
    # If the user installed their own, don't get in its way.
    # Unfortunately, Log::Any doesn't provide a way to install our own
    # fallback logger behind the user's
    if ($my_adapter) {
        Log::Any::Adapter->set(
            { category => $category }, 'Carp',
            no_trace  => 1,
            log_level => $self->_verbose_to_log_level
        );
    }
}

has '_internal_logger' => ( is => 'rw', init_arg => undef, default => 0 );

has 'logger' => (
    is      => 'rw',
    lazy    => 1,
    isa     => Type::Tiny::Duck->new( methods => [qw/info warn/] ),
    builder => '_build_logger',
    clearer => 'clear_logger',
    trigger => 1
);

sub _build_logger {
    my $self = shift;
    my $category = Scalar::Util::blessed($self) || $self;
    require Log::Any;
    require Log::Any::Adapter;
    Log::Any::Adapter->set(
        { category => $category }, 'Carp',
        no_trace  => 1,
        log_level => $self->_verbose_to_log_level
    );
    $self->_internal_logger(
        Log::Any->get_logger(
            category => $category,
            filter   => \&_prefix_message
        )
    );
}

sub _trigger_logger {
    my $self = shift;
    if ( $self->_internal_logger ) {
        Log::Any::Adapter->remove( $self->_internal_logger->adapter );
        $self->_internal_logger(0);
    }
}

before 'clear_logger' => sub {
    my $self = shift;
    if ( $self->_internal_logger ) {
        Log::Any::Adapter->remove( $self->_internal_logger );
        $self->_internal_logger(0);
    }
};

# Alias to mimic Log::Any API
sub get_logger { shift->logger(@_); }

sub remark {
    my ( $self, $msg ) = @_;

    return unless $self->verbose;

    my $logger = $self->logger;

    if ( ( Scalar::Util::reftype($msg) || '' ) eq 'HASH' ) {
        return if $self->verbose < ( $msg->{level} // -5 );
        $msg = $msg->{message};
    }

    # Log::Log4perl doesn't support 'notice', and Log::Dispatch
    # supports 'notice' but not 'noticef', so do crude duck typing and
    # go through some contortions for compatibility
    if ( ( Scalar::Util::reftype($msg) || '' ) eq 'ARRAY' ) {
        if ( $logger->can('noticef') ) { $logger->noticef(@$msg); }
        else {
            my $formatted = sprintf $msg->[0], @$msg[ 1 .. $#{$msg} ];
            if   ( $logger->can('notice') ) { $logger->notice($formatted) }
            else                            { $logger->info($formatted) }
        }
    }
    else {
        if   ( $logger->can('notice') ) { $logger->notice($msg); }
        else                            { $logger->info($msg); }
    }
}

1;

__END__