File Coverage

blib/lib/Log/ger.pm

Criterion	Covered	Total	%
statement	62	68	91.1
branch	39	52	75.0
condition	5	5	100.0
subroutine	7	9	77.7
pod	0	3	0.0
total	113	137	82.4

package Log::ger;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-01-31'; # DATE
our $DIST = 'Log-ger'; # DIST
our $VERSION = '0.038'; # VERSION

#IFUNBUILT
# use strict 'subs', 'vars';
# use warnings;
#END IFUNBUILT

our $re_addr = qr/\(0x([0-9a-f]+)/o;

our %Levels = (
    fatal   => 10,
    error   => 20,
    warn    => 30,
    info    => 40,
    debug   => 50,
    trace   => 60,
);

our %Level_Aliases = (
    off     => 0,
    warning => 30,
);

our $Current_Level = 30;

our $Caller_Depth_Offset = 0;

# a flag that can be used by null output to skip using formatter
our $_outputter_is_null;

our $_dumper;

our %Global_Hooks;

# in Log/ger/Heavy.pm
# our %Default_Hooks = (

our %Package_Targets; # key = package name, value = \%per_target_conf
our %Per_Package_Hooks; # key = package name, value = { phase => hooks, ... }

our %Hash_Targets; # key = hash address, value = [$hashref, \%per_target_conf]
our %Per_Hash_Hooks; # key = hash address, value = { phase => hooks, ... }

our %Object_Targets; # key = object address, value = [$obj, \%per_target_conf]
our %Per_Object_Hooks; # key = object address, value = { phase => hooks, ... }

my $sub0 = sub {0};
my $sub1 = sub {1};
my $default_null_routines;

sub install_routines {
    my ($target, $target_arg, $routines, $name_routines) = @_;

    if ($name_routines && !defined &subname) {
        if (eval { require Sub::Name; 1 }) {
            *subname = \&Sub::Name::subname;
        } else {
            *subname = sub {};
        }
    }

    if ($target eq 'package') {
#IFUNBUILT
#         no warnings 'redefine';
#END IFUNBUILT
        for my $r (@$routines) {
            my ($code, $name, $lnum, $type) = @$r;
            next unless $type =~ /_sub\z/;
            #print "D:installing $name to package $target_arg\n";
            *{"$target_arg\::$name"} = $code;
            subname("$target_arg\::$name", $code) if $name_routines;
        }
    } elsif ($target eq 'object') {
#IFUNBUILT
#         no warnings 'redefine';
#END IFUNBUILT
        my $pkg = ref $target_arg;
        for my $r (@$routines) {
            my ($code, $name, $lnum, $type) = @$r;
            next unless $type =~ /_method\z/;
            *{"$pkg\::$name"} = $code;
            subname("$pkg\::$name", $code) if $name_routines;
        }
    } elsif ($target eq 'hash') {
        for my $r (@$routines) {
            my ($code, $name, $lnum, $type) = @$r;
            next unless $type =~ /_sub\z/;
            $target_arg->{$name} = $code;
        }
    }
}

sub add_target {
    my ($target_type, $target_name, $per_target_conf, $replace) = @_;
    $replace = 1 unless defined $replace;

    if ($target_type eq 'package') {
        unless ($replace) { return if $Package_Targets{$target_name} }
        $Package_Targets{$target_name} = $per_target_conf;
    } elsif ($target_type eq 'object') {
        my ($addr) = "$target_name" =~ $re_addr;
        unless ($replace) { return if $Object_Targets{$addr} }
        $Object_Targets{$addr} = [$target_name, $per_target_conf];
    } elsif ($target_type eq 'hash') {
        my ($addr) = "$target_name" =~ $re_addr;
        unless ($replace) { return if $Hash_Targets{$addr} }
        $Hash_Targets{$addr} = [$target_name, $per_target_conf];
    }
}

sub _set_default_null_routines {
    $default_null_routines ||= [
        (map {(
            [$sub0, "log_$_", $Levels{$_}, 'logger_sub'],
            [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "log_is_$_", $Levels{$_}, 'level_checker_sub'],
            [$sub0, $_, $Levels{$_}, 'logger_method'],
            [$Levels{$_} > $Current_Level ? $sub0 : $sub1, "is_$_", $Levels{$_}, 'level_checker_method'],
        )} keys %Levels),
    ];
}

sub get_logger {
    my ($package, %per_target_conf) = @_;

    my $caller = caller(0);
    $per_target_conf{category} = $caller
        if !defined($per_target_conf{category});
    my $obj = []; $obj =~ $re_addr;
    my $pkg = "Log::ger::Obj$1"; bless $obj, $pkg;
    add_target(object => $obj, \%per_target_conf);
    if (keys %Global_Hooks) {
        require Log::ger::Heavy;
        init_target(object => $obj, \%per_target_conf);
    } else {
        # if we haven't added any hooks etc, skip init_target() process and use
        # this preconstructed routines as shortcut, to save startup overhead
        _set_default_null_routines();
        install_routines(object => $obj, $default_null_routines, 0);
    }
    $obj; # XXX add DESTROY to remove from list of targets
}

sub _import_to {
    my ($package, $target_pkg, %per_target_conf) = @_;

    $per_target_conf{category} = $target_pkg
        if !defined($per_target_conf{category});
    add_target(package => $target_pkg, \%per_target_conf);
    if (keys %Global_Hooks) {
        require Log::ger::Heavy;
        init_target(package => $target_pkg, \%per_target_conf);
    } else {
        # if we haven't added any hooks etc, skip init_target() process and use
        # this preconstructed routines as shortcut, to save startup overhead
        _set_default_null_routines();
        install_routines(package => $target_pkg, $default_null_routines, 0);
    }
}

sub import {
    my ($package, %per_target_conf) = @_;

    my $caller = caller(0);
    $package->_import_to($caller, %per_target_conf);
}

1;
# ABSTRACT: A lightweight, flexible logging framework

__END__