File Coverage

blib/lib/Log/Emitter.pm

Criterion	Covered	Total	%
statement	52	53	98.1
branch	7	10	70.0
condition	4	9	44.4
subroutine	23	24	95.8
pod	11	12	91.6
total	97	108	89.8

package Log::Emitter;

use Class::Method::Modifiers ();
use Carp 'croak';
use Fcntl ':flock';
use Encode 'find_encoding';
use IO::Handle ();

use Class::Tiny::Chained {
  format => sub { \&_format },
  handle => sub {

    # STDERR
    return \*STDERR unless my $path = shift->path;

    # File
    croak qq{Can't open log file "$path": $!} unless open my $file, '>>', $path;
    return $file;
  },
  history => sub { [] },
  level => 'debug',
  max_history_size => 10,
}, 'path';

Class::Method::Modifiers::before 'path' => sub { delete $_[0]{handle} if @_ > 1 };

use Role::Tiny::With;
with 'Role::EventEmitter';

our $VERSION = '0.004';

# Supported log levels
my $LEVEL = {debug => 1, info => 2, warn => 3, error => 4, fatal => 5};

# Encoding cache
my $CACHE;

sub BUILD { shift->on(message => \&_message) }

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

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

sub debug { shift->_log(debug => @_) }
sub error { shift->_log(error => @_) }
sub fatal { shift->_log(fatal => @_) }
sub info  { shift->_log(info  => @_) }

sub is_debug { shift->_now('debug') }
sub is_error { shift->_now('error') }
# For Log::Contextual compatiblity
sub is_fatal { 1 }
sub is_info  { shift->_now('info') }
sub is_warn  { shift->_now('warn') }

sub warn { shift->_log(warn => @_) }

sub _encoding {
  $CACHE ||= find_encoding('UTF-8') || croak "Unknown encoding 'UTF-8'";
}

sub _format {
  '[' . localtime(shift) . '] [' . shift() . '] ' . join "\n", @_, '';
}

sub _log { shift->emit('message', shift, @_) }

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

  return unless $self->_now($level);

  my $max     = $self->max_history_size;
  my $history = $self->history;
  push @$history, my $msg = [time, $level, @_];
  shift @$history while @$history > $max;

  $self->append($self->format->(@$msg));
}

sub _now { $LEVEL->{pop()} >= $LEVEL->{$ENV{LOG_EMITTER_LEVEL} || shift->level} }

1;

=encoding utf8

=head1 NAME

Log::Emitter - Simple logger

=head1 SYNOPSIS

  use Log::Emitter;

  # Log to STDERR
  my $log = Log::Emitter->new;

  # Customize log file location and minimum log level
  my $log = Log::Emitter->new(path => '/var/log/emitter.log', level => 'warn');

  # Log messages
  $log->debug('Not sure what is happening here');
  $log->info('FYI: it happened again');
  $log->warn('This might be a problem');
  $log->error('Garden variety error');
  $log->fatal('Boom');

=head1 DESCRIPTION

L is a simple logger based on L.

L is compatible with L for global logging.

  use Log::Emitter;
  use Log::Contextual ':log', 'set_logger', -levels => [qw(debug info warn error fatal)];
  set_logger(Log::Emitter->new);

  log_info { "Here's some info" };
  log_error { "Uh-oh, error occured" };

=head1 EVENTS

L composes all events from L in addition to
emitting the following.

=head2 message

  $log->on(message => sub {
    my ($log, $level, @lines) = @_;
    ...
  });

Emitted when a new message gets logged.

  $log->unsubscribe('message');
  $log->on(message => sub {
    my ($log, $level, @lines) = @_;
    say "$level: ", @lines;
  });

=head1 ATTRIBUTES

L implements the following attributes.

=head2 format

  my $cb = $log->format;
  $log   = $log->format(sub {...});

A callback for formatting log messages.

  $log->format(sub {
    my ($time, $level, @lines) = @_;
    return "[Thu May 15 17:47:04 2014] [info] I ♥ Logging\n";
  });

=head2 handle

  my $handle = $log->handle;
  $log       = $log->handle(IO::Handle->new);

Log filehandle used by default L event, defaults to opening
L or C. Reset when L is set.

=head2 history

  my $history = $log->history;
  $log        = $log->history([[time, 'debug', 'That went wrong']]);

The last few logged messages.

=head2 level

  my $level = $log->level;
  $log      = $log->level('debug');

Active log level, defaults to C. Available log levels are C,
C, C, C and C, in that order. Note that the
C environment variable can override this value.

=head2 max_history_size

  my $size = $log->max_history_size;
  $log     = $log->max_history_size(5);

Maximum number of logged messages to store in L, defaults to C<10>.

=head2 path

  my $path = $log->path
  $log     = $log->path('/var/log/emitter.log');

Log file path used by L. Setting this attribute will reset
L.

=head1 METHODS

L composes all methods from L in addition to
the following.

=head2 new

  my $log = Log::Emitter->new;

Construct a new L object and subscribe to L event
with default logger.

=head2 append

  $log->append("[Thu May 15 17:47:04 2014] [info] I ♥ Logging\n");

Append message to L.

=head2 debug

  $log = $log->debug('You screwed up, but that is ok');
  $log = $log->debug('All', 'cool');

Emit L event and log debug message.

=head2 error

  $log = $log->error('You really screwed up this time');
  $log = $log->error('Wow', 'seriously');

Emit L event and log error message.

=head2 fatal

  $log = $log->fatal('Its over...');
  $log = $log->fatal('Bye', 'bye');

Emit L event and log fatal message.

=head2 info

  $log = $log->info('You are bad, but you prolly know already');
  $log = $log->info('Ok', 'then');

Emit L event and log info message.

=head2 is_debug

  my $bool = $log->is_debug;

Check for debug log level.

=head2 is_error

  my $bool = $log->is_error;

Check for error log level.

=head2 is_fatal

  my $bool = $log->is_fatal;

Always true.

=head2 is_info

  my $bool = $log->is_info;

Check for info log level.

=head2 is_warn

  my $bool = $log->is_warn;

Check for warn log level.

=head2 warn

  $log = $log->warn('Dont do that Dave...');
  $log = $log->warn('No', 'really');

Emit L event and log warn message.

=head1 BUGS

Report any issues on the public bugtracker.

=head1 AUTHOR

Dan Book

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2015 by Dan Book.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=head1 SEE ALSO

L, L

=for Pod::Coverage BUILD