File Coverage

blib/lib/Log/Minimal.pm

Criterion	Covered	Total	%
statement	122	122	100.0
branch	36	40	90.0
condition	17	26	65.3
subroutine	28	28	100.0
pod	11	11	100.0
total	214	227	94.2

package Log::Minimal;

use strict;
use warnings;
use Term::ANSIColor qw//;

our $VERSION = '0.19';
our @EXPORT = map { ($_.'f', $_.'ff') } qw/crit warn info debug croak/;
push @EXPORT, 'ddf';

our $PRINT = sub {
    my ( $time, $type, $message, $trace, $raw_message) = @_;
    warn "$time [$type] $message at $trace\n";
};

our $DIE = sub {
    my ( $time, $type, $message, $trace, $raw_message) = @_;
    die "$time [$type] $message at $trace\n";
};

our $DEFAULT_COLOR = {
    info  => { text => 'green', },
    debug => {
        text       => 'red',
        background => 'white',
    },
    'warn' => {
        text       => 'black',
        background => 'yellow',
    },
    'critical' => {
        text       => 'black',
        background => 'red'
    },
    'error' => {
        text       => 'red',
        background => 'black'
    }
};

if ($ENV{LM_DEFAULT_COLOR}) {
    # LEVEL=FG;BG:LEVEL=FG;BG:...
    for my $level_color (split /:/, $ENV{LM_DEFAULT_COLOR}) {
        my($level, $color) = split /=/, $level_color, 2;
        my($fg, $bg)       = split /;/, $color, 2;
        $Log::Minimal::DEFAULT_COLOR->{$level} = {
            $fg ? (text       => $fg) : (),
            $bg ? (background => $bg) : (),
        };
    }
}

our $ENV_DEBUG = "LM_DEBUG";
our $AUTODUMP = 0;
our $LOG_LEVEL = 'DEBUG';
our $TRACE_LEVEL = 0;
our $COLOR = $ENV{LM_COLOR} || 0;
our $ESCAPE_WHITESPACE = 1;

my %log_level_map = (
    DEBUG    => 1,
    INFO     => 2,
    WARN     => 3,
    CRITICAL => 4,
    MUTE     => 0,
    ERROR    => 99,
);

sub import {
    my $class   = shift;
    my $package = caller(0);
    my @args = @_;

    my %want_export;
    my $env_debug;
    while ( my $arg = shift @args ) {
        if ( $arg eq 'env_debug' ) {
            $env_debug = shift @args;
        }
        else {
            $want_export{$arg} = 1;
        }
    }

    if ( ! keys %want_export ) {
        #all
        $want_export{$_} = 1 for @EXPORT;
    }

    no strict 'refs';
    for my $f (grep !/^debug/, @EXPORT) {
        if ( $want_export{$f} ) {
            *{"$package\::$f"} = \&$f;
        }
    }

    for my $f (map { ($_.'f', $_.'ff') } qw/debug/) {
        if ( $want_export{$f} ) {
            if ( $env_debug ) {
                *{"$package\::$f"} = sub {
                    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
                    local $ENV_DEBUG   = $env_debug;
                    $f->(@_);
                };
            }
            else {
                *{"$package\::$f"} = \&$f;
            }
        }
    }

}

sub critf {
    _log( "CRITICAL", 0, @_ );
}

sub warnf {
    _log( "WARN", 0, @_ );
}

sub infof {
    _log( "INFO", 0, @_ );
}

sub debugf {
    return if !$ENV{$ENV_DEBUG} || $log_level_map{DEBUG} < $log_level_map{uc $LOG_LEVEL};
    _log( "DEBUG", 0, @_ );
}

sub critff {
    _log( "CRITICAL", 1, @_ );
}

sub warnff {
    _log( "WARN", 1, @_ );
}

sub infoff {
    _log( "INFO", 1, @_ );
}

sub debugff {
    return if !$ENV{$ENV_DEBUG} || $log_level_map{DEBUG} < $log_level_map{uc $LOG_LEVEL};
    _log( "DEBUG", 1, @_ );
}

sub croakf {
    local $PRINT = $DIE;
    local $LOG_LEVEL = 'DEBUG';
    _log( "ERROR", 0, @_ );
}

sub croakff {
    local $PRINT = $DIE;
    local $LOG_LEVEL = 'DEBUG';
    _log( "ERROR", 1, @_ );
}

sub _log {
    my $tag = shift;
    my $full = shift;

    my $_log_level = $log_level_map{uc $LOG_LEVEL} || return;
    return unless $log_level_map{$tag} >= $_log_level;

    my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
      localtime(time);
    my $time    = sprintf(
        "%04d-%02d-%02dT%02d:%02d:%02d",
        $year + 1900,
        $mon + 1, $mday, $hour, $min, $sec
    );

    my $trace;
    if ( $full ) {
        my $i=$TRACE_LEVEL+1;
        my @stack;
        while ( my @caller = caller($i) ) {
            push @stack, "$caller[1] line $caller[2]";
            $i++;
        }
        $trace = join ", ", @stack
    }
    else {
        my @caller = caller($TRACE_LEVEL+1);
        $trace = "$caller[1] line $caller[2]";
    }

    my $messages = '';
    if ( @_ == 1 && defined $_[0]) {
        $messages = $AUTODUMP ? ''.Log::Minimal::Dumper->new($_[0]) : $_[0];
    }
    elsif ( @_ >= 2 )  {
        $messages = sprintf(shift, map { $AUTODUMP ? Log::Minimal::Dumper->new($_) : $_ } @_);
    }

    if ($ESCAPE_WHITESPACE) {
        $messages =~ s/\x0d/\\r/g;
        $messages =~ s/\x0a/\\n/g;
        $messages =~ s/\x09/\\t/g;
    }

    my $raw_message = $messages;
    if ( $COLOR ) {
        $messages = Term::ANSIColor::color($DEFAULT_COLOR->{lc($tag)}->{text})
            . $messages . Term::ANSIColor::color("reset")
                if $DEFAULT_COLOR->{lc($tag)}->{text};
        $messages = Term::ANSIColor::color("on_".$DEFAULT_COLOR->{lc($tag)}->{background})
            . $messages . Term::ANSIColor::color("reset")
                if $DEFAULT_COLOR->{lc($tag)}->{background};
    }

    $PRINT->(
        $time,
        $tag,
        $messages,
        $trace,
        $raw_message
    );
}

sub ddf {
    my $value = shift;
    Log::Minimal::Dumper::dumper($value);
}

1;

package
    Log::Minimal::Dumper;

use strict;
use warnings;
use base qw/Exporter/;
use Data::Dumper;
use Scalar::Util qw/blessed/;

use overload
    '""' => \&stringfy,
    '0+' => \&numeric,
    fallback => 1;

sub new {
    my ($class, $value) = @_;
    bless \$value, $class;
}

sub stringfy {
    my $self = shift;
    my $value = $$self;
    if ( blessed($value) && (my $stringify = overload::Method( $value, '""' ) || overload::Method( $value, '0+' )) ) {
        $value = $stringify->($value);
    }
    dumper($value);
}

sub numeric {
    my $self = shift;
    my $value = $$self;
    if ( blessed($value) && (my $numeric = overload::Method( $value, '0+' ) || overload::Method( $value, '""' )) ) {
        $value = $numeric->($value);
    }
    $value;
}

sub dumper {
    my $value = shift;
    if ( defined $value && ref($value) ) {
        local $Data::Dumper::Terse = 1;
        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Sortkeys = 1;
        $value = Data::Dumper::Dumper($value);
    }
    $value;
}


1;
__END__