File Coverage

blib/lib/Log/Contextual/WarnLogger/Fancy.pm

Criterion	Covered	Total	%
statement	86	107	80.3
branch	42	66	63.6
condition	12	24	50.0
subroutine	23	24	95.8
pod	0	14	0.0
total	163	235	69.3

use 5.006;    # our
use strict;
use warnings;

package Log::Contextual::WarnLogger::Fancy;

our $VERSION = '0.002000';

use Carp qw( croak );
use Term::ANSIColor qw( colored );

delete $Log::Contextual::WarnLogger::Fancy::{$_}
  for qw( croak colored );    # namespace clean

delete $Log::Contextual::WarnLogger::Fancy::{$_}
  for qw( _gen_level_sub _gen_is_level_sub _name_sub _can_name_sub _elipsis )
  ;                           # not for external use cleaning

BEGIN {
    # Lazily find the best XS Sub naming implementation possible.
    # Preferring an already loaded implementation where possible.
    #<<< Tidy Guard
    my $impl = ( $INC{'Sub/Util.pm'}           and defined &Sub::Util::set_subname )  ? 'SU'
             : ( $INC{'Sub/Name.pm'}           and defined &Sub::Name::subname     )  ? 'SN'
             : ( eval { require Sub::Util; 1 } and defined &Sub::Util::set_subname )  ? 'SU'
             : ( eval { require Sub::Name; 1 } and defined &Sub::Name::subname     )  ? 'SN'
             :                                                                          '';
    *_name_sub = $impl eq 'SU'   ? \&Sub::Util::set_subname
               : $impl eq 'SN'   ? \&Sub::Name::subname
               :                   sub { $_[1] };
    #>>>
    *_can_name_sub = $impl ? sub() { 1 } : sub () { 0 };
}

_gen_level($_) for (qw( trace debug info warn error fatal ));

# Hack Notes: Custom levels are not currently recommended, but doing the following *should* work:
#
# Log::Contextual::WarnLogger::Fancy::_gen_level('custom');
# $logger->{levels} = [ @{ $logger->{levels}, 'custom' ];
# $logger->{level_nums}->{ 'custom' } = 1;
# $logger->{level_labels}->{ 'custom' } = 'custo';

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

    my $args = ( @args == 1 && ref $args[0] ? { %{ $args[0] } } : {@args} );

    my $self = bless {}, $class;

    $self->{env_prefix} = $args->{env_prefix}
      or croak 'no env_prefix passed to ' . __PACKAGE__ . '->new';

    for my $field (qw( group_env_prefix default_upto label label_length )) {
        $self->{$field} = $args->{$field} if exists $args->{$field};
    }
    if ( defined $self->{label} and length $self->{label} ) {
        $self->{label_length} = 16 unless exists $args->{label_length};
        $self->{effective_label} =
          _elipsis( $self->{label}, $self->{label_length} );
    }
    my @levels       = qw( trace debug info warn error fatal );
    my %level_colors = (
        trace => [],
        debug => ['blue'],
        info  => ['white'],
        warn  => ['yellow'],
        error => ['magenta'],
        fatal => ['red'],
    );

    $self->{levels} = [@levels];
    @{ $self->{level_nums} }{@levels} = ( 0 .. $#levels );
    for my $level (@levels) {
        $self->{level_labels}->{$level} = sprintf "%-5s", $level;
        if ( @{ $level_colors{$level} || [] } ) {
            $self->{level_labels}->{$level} =
              colored( $level_colors{$level}, $self->{level_labels}->{$level} );
        }
    }

    unless ( exists $self->{default_upto} ) {
        $self->{default_upto} = 'warn';
    }
    return $self;
}

# TODO: Work out how to savely use Unicode \x{2026}, and then elipsis_width
# becomes 1. Otherwise utf8::encode() here after computing width might have to do.
my $elipsis_char  = chr(166);               #"\x{183}";
my $elipsis_width = length $elipsis_char;

sub _elipsis {
    my ( $text, $length ) = @_;
    return sprintf "%" . $length . "s", $text if ( length $text ) <= $length;

 # Because the elipsis doesn't count for our calculations because its logically
 # "in the middle". Subsequent math should be done assuming there is no elipsis.
    my $pad_space = $length - $elipsis_width;
    return '' if $pad_space <= 0;

    # Doing it this way handles a not entirely balanced case automatically.
    #   trimming   asdfghij to length 6 with a 1 character elipis
    #   ->  "....._"
    #   ->  ".._..."
    # so left gets a few less than the right here to have room for elipsis.
    #
    # When pad_space is even, it all works out in the end due to int truncation.
    my $lw = int( $pad_space / 2 );
    my $rw = $pad_space - $lw;

    return sprintf "%s%s%s", ( substr $text, 0, $lw ), $elipsis_char,
      ( substr $text, -$rw, $rw );
}

sub _log {
    my $self    = shift;
    my $level   = shift;
    my $message = join( "\n", @_ );
    $message .= qq[\n] unless $message =~ /\n\z/;
    my $label = $self->{level_labels}->{$level};

    $label .= ' ' . $self->{effective_label} if $self->{effective_label};
    warn "[${label}] $message";
}

sub _gen_level_sub {
    my ( $level, $is_name ) = @_;
    return sub {
        my $self = shift;
        return unless $self->$is_name;
        $self->_log( $level, @_ );
    };
}

sub _gen_is_level_sub {
    my ($level) = @_;
    my $ulevel = '_' . uc $level;

    return sub {
        my $self = shift;

        # All ENV vars are just treated as an ordered list.
        #
        # "env_prefix" comes first, then group_env_prefix comes second as a
        # fallback.
        # group_env_prefix can be an arrayref itself ordered by
        # narrowest-to-broadest.

        my (@prefixes) = ( $self->{env_prefix} );
        if ( defined $self->{group_env_prefix} ) {
            if ( ref $self->{group_env_prefix} ) {
                push @prefixes, @{ $self->{group_env_prefix} };
            }
            else {
                push @prefixes, $self->{group_env_prefix};
            }
        }

        # If Any of ${PREFIX}_${LEVEL} is explicitly defined in ENV, it takes
        # precendence over anythingthing else, returning true/false based on
        # whether or not those values are true or false

        for my $env_var ( map { $_ . $ulevel } @prefixes ) {
            return !!$ENV{$env_var} if defined $ENV{$env_var};
        }

        # If Any of ${PREFIX}_UPTO is explicitly defined in ENV,
        # it falls back from ${PREFIX_LEVEL} but again, the "narrowest"
        # scope wins.

        my $upto;
        for my $env_var ( map { $_ . '_UPTO' } @prefixes ) {
            if ( defined $ENV{$env_var} ) {
                $upto = lc $ENV{$env_var};
                croak "Unrecognized log level '$upto' in \$ENV{$env_var}"
                  if not defined $self->{level_nums}->{$upto};
                last;
            }
        }

        # If there is no UPTO in env and there's no default, then we can't be
        # considered.
        return 0 if not defined $upto and not defined $self->{default_upto};

        # Defaults however are considered where possible.
        $upto = $self->{default_upto} if not defined $upto;

        return $self->{level_nums}->{$level} >= $self->{level_nums}->{$upto};
    };
}

sub _gen_level {
    my ($level) = @_;
    my $is_name = "is_$level";

    my $level_sub = _gen_level_sub( $level, $is_name );
    my $is_level_sub = _gen_is_level_sub($level);

    _can_name_sub and _name_sub( "$level",   $level_sub );
    _can_name_sub and _name_sub( "$is_name", $is_level_sub );

    no strict 'refs';
    *{$level}   = $level_sub;
    *{$is_name} = $is_level_sub;
}

1;

__END__