File Coverage

blib/lib/Log/ger/Layout/Pattern.pm

Criterion	Covered	Total	%
statement	44	45	97.7
branch	8	10	80.0
condition	12	15	80.0
subroutine	10	10	100.0
pod	0	2	0.0
total	74	82	90.2

package Log::ger::Layout::Pattern;

use 5.010001;
use strict;
use warnings;

use Devel::Caller::Util;
use Log::ger ();
use Time::HiRes qw(time);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-01-22'; # DATE
our $DIST = 'Log-ger-Layout-Pattern'; # DIST
our $VERSION = '0.009'; # VERSION

our $time_start = time();
our $time_now   = $time_start;
our $time_last  = $time_start;

my %per_message_data;
my %cache;

our %format_for = (
    'c' => sub { $_[1]{category} },
    'C' => sub { $per_message_data{caller0}[0] },
    'd' => sub {
        my @t = localtime($time_now);
        sprintf(
            "%04d-%02d-%02dT%02d:%02d:%02d",
            $t[5]+1900, $t[4]+1, $t[3],
            $t[2], $t[1], $t[0],
        );
    },
    'D' => sub {
        my @t = gmtime($time_now);
        sprintf(
            "%04d-%02d-%02dT%02d:%02d:%02d",
            $t[5]+1900, $t[4]+1, $t[3],
            $t[2], $t[1], $t[0],
        );
    },
    'F' => sub { $per_message_data{caller0}[1] },
    'H' => sub {
        require Sys::Hostname;
        Sys::Hostname::hostname();
    },
    'l' => sub {
        sprintf(
            "%s%s(%s:%d)",
            $per_message_data{caller1}[3],
            $per_message_data{caller1}[3] ? ' ' : '',
            $per_message_data{caller0}[1],
            $per_message_data{caller0}[2],
        );
    },
    'L' => sub { $per_message_data{caller0}[2] },
    'm' => sub { $_[0] },
    'M' => sub {
        $per_message_data{caller1}[3] // '';
    },
    'n' => sub { "\n" },
    'p' => sub { $_[3] },
    'P' => sub { $$ },
    'r' => sub { sprintf("%.3f", $time_now - $time_start) },
    'R' => sub { sprintf("%.3f", $time_now - $time_last ) },
    'T' => sub {
        join(", ", map { "$_->[3] called at $_->[1] line $_->[2]" }
                 @{ $per_message_data{callers} });
    },
    '_{vmsize}' => sub {
        unless ($cache{pid_stat_time} &&
                $cache{pid_stat_time} >= $time_now-1) {
            open my $fh, "<", "/proc/$$/stat" or die;
            $cache{pid_stat} = [split /\s+/, scalar(<$fh>)];
            $cache{pid_stat_time} = $time_now;
            close $fh;
        }
        sprintf("%d", $cache{pid_stat}[22]/1024);
    },

    # test
    #'z' => sub { use DD; my $i = 0; while (my @c = caller($i++)) { dd \@c } },
    '%' => sub { '%' },
);

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

my $re = qr/%(_\{\w+\}|[A-Za-z%])/;
sub _layout {
    my $format = shift;
    my $packages_to_ignore = shift;
    my $subroutines_to_ignore = shift;

    ($time_last, $time_now) = ($time_now, time());
    %per_message_data = ();

    my %mentioned_formats;
    while ($format =~ m/$re/g) {
        if (exists $format_for{$1}) {
            $mentioned_formats{$1} = 1;
        } else {
            die "Unknown format '%$1'";
        }
    }

    if ($mentioned_formats{C} ||
            $mentioned_formats{F} ||
            $mentioned_formats{L} ||
            $mentioned_formats{l}
        ) {
        $per_message_data{caller0}  =
            [Devel::Caller::Util::caller (0, 0, $packages_to_ignore, $subroutines_to_ignore)];
    }
    if ($mentioned_formats{l} ||
            $mentioned_formats{M}
        ) {
        $per_message_data{caller1}  =
            [Devel::Caller::Util::caller (1, 0, $packages_to_ignore, $subroutines_to_ignore)];
    }
    if ($mentioned_formats{T}) {
        $per_message_data{callers} =
            [Devel::Caller::Util::callers(0, 0, $packages_to_ignore, $subroutines_to_ignore)];
    }

    $format =~ s#$re#$format_for{$1}->(@_)#eg;
    $format;
}

sub get_hooks {
    my %plugin_conf = @_;

    $plugin_conf{format} or die "Please specify format";
    $plugin_conf{packages_to_ignore} //= qr/\A(?:Try::Tiny|Log::ger(?:::.+)?)\z/;

    return {
        create_layouter => [
            __PACKAGE__, # key
            50,          # priority
            sub {        # hook
                my %hook_args = @_; # see Log::ger::Manual::Internals/"Arguments passed to hook"
                my $layouter = sub {
                    _layout($plugin_conf{format}, $plugin_conf{packages_to_ignore}, $plugin_conf{subroutines_to_ignore}, @_);
                };
                [$layouter];
            }],
    };
}

1;
# ABSTRACT: Pattern layout

__END__