File Coverage

blib/lib/Log/ger/Output/Screen.pm

Criterion	Covered	Total	%
statement	48	77	62.3
branch	26	48	54.1
condition	0	9	0.0
subroutine	9	9	100.0
pod	0	4	0.0
total	83	147	56.4

package Log::ger::Output::Screen;

use strict;
use warnings;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-01-16'; # DATE
our $DIST = 'Log-ger-Output-Screen'; # DIST
our $VERSION = '0.019'; # VERSION

if ($^O eq 'MSWin32') {
    eval { require Win32::Console::ANSI };
}

use Log::ger::Util;

our %colors_16 = (
    10 => "\e[31m"  , # fatal  , red
    20 => "\e[35m"  , # error  , magenta
    30 => "\e[1;34m", # warning, light blue
    40 => "\e[32m"  , # info   , green
    50 => "",         # debug  , no color
    60 => "\e[33m"  , # trace  , orange
);

our %colors_256 = (
    # pastel'ish, all brighter and avoid pure red/blue which is hard to see on
    # laptop screen in a bright environment

    10 => "\e[1;38;5;160m", # fatal  , bright red3
    20 => "\e[1;38;5;163m", # error  , bright magenta3
    30 => "\e[1;38;5;69m" , # warning, bright cornflowerblue
    40 => "\e[1;38;5;113m", # info   , bright darkolivegreen3
    50 => ""              , # debug  , no color
    60 => "\e[1;38;5;130m", # trace  , bright darkorange3
);

our %level_map;

sub meta { +{
    v => 2,
} }

sub _pick_color {
    my ($level, $color_depth) = @_;
    my $colors = $color_depth >= 256 ? \%colors_256 : \%colors_16;
    if (defined(my $c = $colors->{$level})) {
        return $c;
    }
    if (defined(my $clevel = $level_map{$level})) {
        return $colors->{$clevel};
    }

    # find the nearest
    my ($dist, $clevel);
    for my $k (keys %$colors) {
        my $d = abs($k - $level);
        if (!defined($dist) || $dist > $d) {
            $dist = $d;
            $clevel = $k;
        }
    }
    $level_map{$level} = $clevel;
    return $colors->{$clevel};
}

sub hook_before_log {
    my ($ctx, $msg) = @_;
}

sub hook_after_log {
    my ($ctx, $msg) = @_;
    print { $ctx->{_fh} } "\n" unless $msg =~ /\R\z/;
}

sub get_hooks {
    my %plugin_conf = @_;

    my $stderr = $plugin_conf{stderr};
    $stderr = 1 unless defined $stderr;
    my $handle = $stderr ? \*STDERR : \*STDOUT;
    my $use_color = do {
        if (defined $plugin_conf{use_color}) {
            $plugin_conf{use_color};
        } elsif (exists $ENV{NO_COLOR}) {
            0;
        } elsif (defined $ENV{COLOR}) {
            $ENV{COLOR};
        } else {
            $stderr ? (-t STDERR) : (-t STDOUT); ## no critic: InputOutput::ProhibitInteractiveTest
        }
    };
    my $color_depth = do {
        if (defined $plugin_conf{color_depth}) {
            $plugin_conf{color_depth};
        } elsif (defined $ENV{COLOR_DEPTH}) {
            $ENV{COLOR_DEPTH};
        } elsif (!$use_color) {
            0;
        } elsif (defined $ENV{COLORTERM} && $ENV{COLORTERM} eq 'truecolor') {
            16777216;
        } elsif (defined $ENV{TERM} && $ENV{TERM} =~ /256color/) {
            256;
        } else {
            16;
        }
    };
    my $formatter = $plugin_conf{formatter};

    if ($plugin_conf{colorize_tags}) {
        require Color::ANSI::Util;
        require Color::RGB::Util;
    }

    return {
        create_outputter => [
            __PACKAGE__, # key
            50,          # priority
            sub {        # hook
                my %hook_args = @_; # see Log::ger::Manual::Internals/"Arguments passed to hook"
                my $outputter = sub {
                    my ($per_target_conf, $msg, $per_msg_conf) = @_;
                    my $level; $level = $per_msg_conf->{level} if $per_msg_conf; $level = $hook_args{level} unless defined $level;
                    if ($formatter) {
                        $msg = $formatter->($msg);
                    }
                    hook_before_log({ _fh=>$handle }, $msg);
                    if ($use_color) {
                        my $line_color = _pick_color($level, $color_depth);

                        if ($plugin_conf{colorize_tags}) {
                            my $prog_prefix;
                            if ($msg =~ s/\A([\w-]+:?\s*)//) {
                                $prog_prefix = $1;
                            }
                            my (@tags, @seps);
                            while ($msg =~ s/\A\[([^\]]+)\](\s*)//g) {
                                push @tags, $1;
                                push @seps, $2;
                            }
                            #use DD; dd {msg=>$msg, tags=>\@tags, prog_prefix=>$prog_prefix};
                            print $handle $line_color, $prog_prefix, "\e[0m" if defined $prog_prefix;
                            for my $i (0 .. $#tags) {
                                # XXX force ansifg() to use the same color depth as us
                                print $handle (
                                    $line_color, "[", "\e[0m",
                                    Color::ANSI::Util::ansifg( Color::RGB::Util::assign_rgb_light_color($tags[$i]) ), $tags[$i], "\e[0m",
                                    $line_color, "]", $seps[$i], "\e[0m",
                                );
                            }
                        }

                        print $handle $line_color, $msg, "\e[0m";

                    } else {
                        print $handle $msg;
                    }
                    hook_after_log({ _fh=>$handle }, $msg);
                };
                [$outputter];
            }],
    };
}

1;
# ABSTRACT: Output log to screen

__END__