File Coverage

blib/lib/Mojo/Log/Che.pm

Criterion	Covered	Total	%
statement	69	73	94.5
branch	30	40	75.0
condition	12	22	54.5
subroutine	13	13	100.0
pod	4	4	100.0
total	128	152	84.2

package Mojo::Log::Che;
use Mojo::Base 'Mojo::Log';

use Carp 'croak';
use Fcntl ':flock';
use Mojo::File;
#~ use Debug::LTrace qw/Mojo::Log::_log/;;
#~ use Carp::Trace;
#~ use Encode qw(decode_utf8);
use Mojo::Util 'encode';
#~ binmode STDERR, ":utf8";

has paths => sub { {} };
has handlers => sub { {} };
has trace => 4;
#~ has parent => undef, weak => 1;

# Standard log levels
my %LEVEL = (debug => 1, info => 2, warn => 3, error => 4, fatal => 5);

sub new {
  my $self = shift->SUPER::new(format => \&_format, @_);
  $self->unsubscribe('message');
  $self->on(message => \&_message);
  return $self;
}

sub context {# override
  my ($self, @context) = @_;
  #~ push @{ $self->{context} ||= [] }, @context;
  $self->{context} = \@context
    if @context;
  return $self;
  #~ return $self->new(parent => $self->parent || $self, context => \@context, level => $self->level);
}

sub handler {
  my ($self, $level) = @_;

  my $handler = $self->handlers->{$level};
  return $handler
    if $handler;

  my $path = shift->path;
  my $path_level = $self->paths->{$level};
  my $is_dir = -d -w $path
    if $path;

  my $file;
  if ($is_dir) {# DIR
    # relative path for level
    chop($path)
      if $path =~ /\/$/;

    $file = sprintf "%s/%s", $path, $path_level ||"$level.log";
  }
  elsif ($path_level) {# absolute FILE for level
    $file = $path_level;
  }
  else {
    #~ warn "Cant create log handler for level=[$level] and path=[$path] (also check filesystem permissions)";
    return; # Parent way to handle
  }

  $handler = Mojo::File->new($file)->open('>>')#:encoding(UTF-8)
    or croak "Cant create log handler for [$file]";

  $self->handlers->{$level} = $handler;

  return $handler;
};

sub append {
  my ($self, $msg, $handle) = @_;

  return unless $handle ||= $self->handle;
  flock $handle, LOCK_EX;
  $handle->print(encode('UTF-8', $msg))#
    or croak "Can't write to log: $!";
  flock $handle, LOCK_UN;
}

my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
#~ my @wday = qw(Sn Mn Ts Wn Th Fr St);
sub _format {
  my ($time, $level) = (shift, shift);
  $level = '['.($LEVEL{$level} ? ($level =~ /^(\w)/)[0] : $level) . '] ' #"[$level] "
    if $level //= '';

  my ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);
  $time = sprintf "%s %s %s:%s:%s", $mday, map(length == 1 ? "0$_" : $_, $mon[$mon], $hour, $min, $sec);#$wday[$wday],

  return "$time $level" . join "\n", @_, '';
}

sub _trace {
  my $start = shift // 1;
  my @call = caller($start);
  return \@call
    if @call;
  #~ my @frames;
  $start = 1;
  #~ while (my @trace = caller($start++)) { push @call, \@trace }
  #~ return pop @call;
  while (@call = caller($start++)) { 1; }
  #~ return $frames[4];
  return \@call;
}



sub _message {
  my ($self, $level) = (shift, shift);

  #~ warn @{$self->{context}} if $self->{context};

  return unless !$LEVEL{$level} || $self->is_level($level);

  my $max     = $self->max_history_size;
  my $history = $self->history;
  my $time = time;
  my $trace = _trace($self->trace)
    if $self->trace;

  splice(@_,0, scalar @{$self->{context}},)
    and $_[0]= join(' ', @{$self->{context}}, $_[0])
    if $self->{context};

  unshift @_, "$$〉". join(":", @$trace[$$trace[0] eq 'main' ? (1,2) : (0,2)]). ' ' . shift
    if $trace && @$trace;
  push @$history, my $msg = [$time, $level, @_];
  shift @$history while @$history > $max;

  if (my $handle = $self->handler($level)) {
    return $self->append($self->format->($time, '', @_), $handle);
  }

  # as parent
  return $self->append($self->format->(@$msg));

}

sub AUTOLOAD {
  my $self = shift;

  my ($package, $method) = our $AUTOLOAD =~ /^(.+)::(.+)$/;
  Carp::croak "Undefined log level(subroutine) &${package}::$method called"
    unless Scalar::Util::blessed $self && $self->isa(__PACKAGE__);

  return $self->_log(@_, $method);

}

our $VERSION = '0.902';# as to Mojolicious version/10+

=encoding utf8

Доброго всем

=head1 Mojo::Log::Che

I<¡ ¡ ¡ ALL GLORY TO GLORIA ! ! !>

=head1 VERSION

0.902 (up to Mojolicious version/10+C)

=head1 NAME

Mojo::Log::Che - Little child of great parent Mojo::Log.

=head1 SYNOPSIS

Parent Mojo::Log behavior just works

  use Mojo::Log::Che;
  my $log = Mojo::Log::Log->new(path => '/var/log/mojo.log', level => 'warn');
  $log->debug(...);

=head2 EXTENDED THINGS

  # Set "path" to folder + have default "paths" for levels (be sure that mkdir /var/log/mojo)
  my $log = Mojo::Log::Log->new(path => '/var/log/mojo');
  $log->warn(...);# log to  /var/log/mojo/warn.log
  $log->error(...); # log to  /var/log/mojo/error.log
  $log->foo(...);# log to  /var/log/mojo/foo.log

  # set "path" to folder + set custom relative "paths" (be sure that mkdir /var/log/mojo)
  my $log = Mojo::Log::Log->new(path => '/var/log/mojo', paths=>{debug=>'dbg.log', foo=>'myfoo.log'});
  $log->debug(...); # log to  /var/log/mojo/dbg.log
  $log->warn(...);# log to /var/log/mojo/warn.log
  $log->foo(...);# log to  /var/log/mojo/myfoo.log

  # set "path" to file + have default "paths" for levels
  # this is standard Mojo::Log behavior + custom level/method also
  my $log = Mojo::Log::Log->new(path => '/var/log/mojo.log');
  $log->debug(...); # log to  /var/log/mojo.log
  $log->warn(...);# log to  /var/log/mojo.log
  $log->foo(...);# log to /var/log/mojo.log

  # set "path" to file + set custom absolute "paths"
  my $log = Mojo::Log::Log->new(path => '/var/log/mojo.log', paths => {error=>'/var/log/mojo.error.log'});
  $log->debug(...); # log to  /var/log/mojo.log
  $log->foo(...);# log to /var/log/mojo.log
  $log->error(...);  # log to /var/log/mojo.error.log

  # Log to STDERR + set custom absolute "paths"
  $log->path(undef); # none path
  $log->level('info');
  $log->paths->{'error'} = '/var/log/error.log'; # absolute file only for error level
  $log->error(...);  # log to /var/log/error.log
  $log->info(...); # log to STDERR
  $log->debug(...); # no log
  $log->foo(...); # anyway log to STDERR


=head1 DESCRIPTION

This B is a extended logger module for L projects.

=head1 EVENTS

B inherits all events from L and override following ones.

=head2 message

See also parent L. Extends parent module logics for switching handlers.

=head1 ATTRIBUTES

B inherits all attributes from L

=head2 handlers

Hashref of created file handlers for standard and custom levels. For standard parent L logic none handlers but L will be in the scene.

  $log->handlers->{'foo'} = IO::Handle->new();

=head2 path

See parent L. Can set to folder and file path.

=head2 paths

Hashref map level names to absolute or relative to L

  $log->path('/var/log'); # folder relative
  $log->paths->{'error'} = 'err.log';
  $log->error(...);#  /var/log/err.log
  $log->info(...); # log to filename as level name /var/log/info.log

  $log->path(undef); # none
  $log->paths->{'error'} = '/var/log/error.log'; # absolute path only error level
  $log->error(...); # log to /var/log/error.log
  $log->info(...); # log to STDERR

=head2 trace

An trace level, defaults to C<4>, C<0> value will disable trace log. This value pass to C.

=head1 METHODS

B inherits all methods from L and implements the
following new ones.

=head2 handler($level)

Return undef when L undefined or L is file or has not defined L for $level. In this case L will return default handler.

Return file handler overwise.

=head1 AUTOLOAD

Autoloads nonstandard/custom levels excepts already defined keywords of this and parent modules L, L, L:

  qw(message _message format _format handle handler handlers
  history level max_history_size  path paths append debug  error fatal info
  is_level  new warn  catch emit  has_subscribers on  once subscribers unsubscribe
  has  attr tap _monkey_patch import)

and maybe anymore!


  $log->foo('bar here');

That custom levels log always without reducing log output outside of level.

=head1 SEE ALSO

L, L, L, L.

=head1 AUTHOR

Михаил Че (Mikhail Che), C<<  >>

=head1 BUGS / CONTRIBUTING

Please report any bugs or feature requests at L. Pull requests also welcome.

=head1 COPYRIGHT

Copyright 2017 Mikhail Che.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut