File Coverage

blib/lib/Log/Pony.pm

Criterion	Covered	Total	%
statement	101	102	99.0
branch	10	12	83.3
condition	4	5	80.0
subroutine	28	28	100.0
pod	13	15	86.6
total	156	162	96.3

package Log::Pony;
use strict;
use warnings;
use utf8;
use 5.008005;
our $VERSION = '1.0.1';
use Carp ();
use Term::ANSIColor ();
use Class::Accessor::Lite (
    ro => [qw/color log_level/],
);

our $TRACE_LEVEL = 0;

__PACKAGE__->set_levels(qw( debug           info     warn               critical        error));
__PACKAGE__->set_colors(   'red on_white', 'green', 'black on_yellow', 'black on_red', 'red on_black');

sub new {
    my $class = shift;
    my %args = @_ == 1 ? %{$_[0]} : @_;
    my $log_level = delete $args{log_level}
            or Carp::croak("Missing mandatory parameter: log_level");
       $log_level = uc($log_level);
    my $color     = delete $args{color} || 0;
    my $self = bless {
        log_level   => $log_level,
        log_level_n => $class->level_to_number($log_level),
        color       => $color,
    }, $class;
    $self->init(%args);
    return $self;
}

sub init { }

sub set_colors {
    my ($class, @colors) = @_;
    no strict 'refs';
    *{"${class}::colors"} = sub { @colors };
}

sub colorize {
    my ($self, $level, $message) = @_;
    my $n = $self->level_to_number($level);
    my @colors = $self->colors();
    my $color = $colors[$n] || $colors[-1];
    return Term::ANSIColor::colored([$color], $message);
}

sub log {
    my ($self, $level, $format, @args) = @_;
    return if $self->level_to_number($level) < $self->{log_level_n};
    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
    $self->process($level, $self->sanitize(sprintf($format, @args)));
}

sub trace_info {
    my $self = shift;
    my @caller  = caller($TRACE_LEVEL+1);
    return "at $caller[1] line $caller[2]";
}

sub sanitize {
    my ($self, $message) = @_;
    $message =~ s/\x0a\z//g;
    $message =~ s/\x0d/\\r/g;
    $message =~ s/\x0a/\\n/g;
    $message =~ s/\x09/\\t/g;
    return $message;
}

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

sub process {
    my ($self, $level, $message) = @_;
    my $time = $self->time();
    my $trace = $self->trace_info();
    if ($self->color) {
        $message = $self->colorize($level, $message);
    }
    print STDERR "$time [$level] $message $trace\n";
}

sub info {
    my $self = shift;
    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
    $self->log(INFO => @_);
}

sub warn {
    my $self = shift;
    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
    $self->log(WARN => @_);
}

sub critical {
    my $self = shift;
    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
    $self->log(CRITICAL => @_);
}

sub debug {
    my $self = shift;
    local $TRACE_LEVEL = $TRACE_LEVEL + 1;
    $self->log(DEBUG => @_);
}

sub set_levels {
    my ($class, @levels) = @_;
    my $i = 1;
    my %levels = map { uc($_) => $i++ } @levels;
    for my $level (@levels) {
        unless ($class->can($level)) {
            $class->mk_level_accessor($level);
        }
    }
    no strict 'refs';
    *{"${class}::level_to_number"} = sub {
        my ($class, $level) = @_;
        my $number = $levels{uc $level}
            or Carp::croak("Unknown logging level: $level");
        return $number;
    };
}

sub mk_level_accessor {
    my ($class, $level) = @_;
    my $LEVEL = uc($level);
       $level = lc($level);
    no strict 'refs';
    *{"${class}::${level}"} = sub {
        my $self = shift;
        local $TRACE_LEVEL = $TRACE_LEVEL + 1;
        $self->log($LEVEL => @_);
    };
}

1;
__END__