File Coverage

blib/lib/Log/Any/Simple.pm

Criterion	Covered	Total	%
statement	223	231	96.5
branch	72	86	83.7
condition	22	30	73.3
subroutine	74	74	100.0
pod	0	35	0.0
total	391	456	85.7

package Log::Any::Simple;

use strict;
use warnings;
use utf8;

use Carp qw(croak cluck shortmess longmess);
use Data::Dumper;
use Log::Any;
use Log::Any::Adapter::Util 'numeric_level';
use Log::Any::Adapter;
use Readonly;
use Sub::Util 'set_subname';

our $VERSION = '0.06';

Readonly::Scalar my $DIE_AT_DEFAULT => numeric_level('fatal');
Readonly::Scalar my $DIE_AT_KEY => 'Log::Any::Simple/die_at';
Readonly::Scalar my $CATEGORY_KEY => 'Log::Any::Simple/category';
Readonly::Scalar my $PREFIX_KEY => 'Log::Any::Simple/prefix';
Readonly::Scalar my $DUMP_KEY => 'Log::Any::Simple/dump';
Readonly::Scalar my $DIE_REPEATS_MSG_KEY => 'Log::Any::Simple/die_repeats_msg';

Readonly::Array my @ALL_LOG_METHODS =>
    (Log::Any::Adapter::Util::logging_methods(), Log::Any::Adapter::Util::logging_aliases);
Readonly::Hash my %ALL_LOG_METHODS => map { $_ => 1 } @ALL_LOG_METHODS;

Readonly::Array my @DEFAULT_LOG_METHODS => qw(trace debug info warning error fatal);

# The index of the %^H hash in the list returned by "caller".
Readonly::Scalar my $HINT_HASH => 10;

# All our methods that can be imported, other than the logging methods
# themselves.
Readonly::Array my @EXPORT_OK => qw(die_with_stack_trace get_logger);
Readonly::Hash my %EXPORT_OK => map { $_ => 1 } @EXPORT_OK;

sub import {  ## no critic (RequireArgUnpacking, ProhibitExcessComplexity)
  my (undef) = shift @_;  # This is the package being imported, so our self.

  my $calling_pkg_name = caller(0);
  my %to_export;

  while (defined (my $arg = shift)) {
    if ($arg eq ':default') {  ## no critic (ProhibitCascadingIfElse)
      $to_export{$_} = 1 for @DEFAULT_LOG_METHODS;
    } elsif ($arg eq ':all') {
      $to_export{$_} = 1 for @ALL_LOG_METHODS;
    } elsif (exists $ALL_LOG_METHODS{$arg}) {
      $to_export{$arg} = 1;
    } elsif ($arg eq ':die_at') {
      my $level = shift;
      if ($level eq 'none') {
        $^H{$DIE_AT_KEY} = numeric_level('emergency') - 1;
      } else {
        my $die_at = numeric_level($level);
        croak 'Invalid :die_at level' unless defined $die_at;
        $^H{$DIE_AT_KEY} = $die_at;
      }
    } elsif ($arg eq ':die_repeats_msg') {
      $^H{$DIE_REPEATS_MSG_KEY} = 1;
    } elsif ($arg eq ':die_silence_msg') {
      $^H{$DIE_REPEATS_MSG_KEY} = 0;
    } elsif ($arg eq ':category') {
      my $category = shift;
      croak 'Invalid :category name' unless $category;
      $^H{$CATEGORY_KEY} = $category;
    } elsif ($arg eq ':prefix') {
      my $prefix = shift;
      croak 'Invalid :prefix value' unless $prefix;
      $^H{$PREFIX_KEY} = $prefix;
    } elsif ($arg eq ':dump_long') {
      $^H{$DUMP_KEY} = 'long';
    } elsif ($arg eq ':dump_short') {
      $^H{$DUMP_KEY} = 'short';
    } elsif (exists $EXPORT_OK{$arg}) {
      _export_module_method($arg, $calling_pkg_name);
    } elsif ($arg eq ':to_stderr') {
      _activate_logging($arg, \*STDERR, shift);
    } elsif ($arg eq ':to_stdout') {
      _activate_logging($arg, \*STDOUT, shift);
    } elsif ($arg eq ':from_argv') {
      _parse_argv();
    } else {
      croak "Unknown parameter: $arg";
    }
  }

  # We export all the methods at the end, so that all the modifications to the
  # %^H hash are already done and can be used by the _export method.
  _export_logger($calling_pkg_name, \%^H) if %to_export;
  _export_logging_method($_, $calling_pkg_name, \%^H) for keys %to_export;

  @_ = 'Log::Any';
  goto &Log::Any::import;
}

# Unimport is not documented at all, and only here to facilitate testing.
sub unimport {  ## no critic (RequireArgUnpacking)
  my (undef) = shift @_;  # This is the package being imported, so our self.

  while (defined (my $arg = shift)) {
    if ($arg eq ':logging') {
      _deactivate_logging();
    } else {
      croak "Unknown parameter: $arg";
    }
  }

  return;
}

# This is slightly ugly but the intent is that the user of a module using this
# module will set this variable to 1 to get full backtrace.
my $die_with_stack_trace;
my %die_with_stack_trace;

sub die_with_stack_trace {  ## no critic (RequireArgUnpacking)
  my ($category, $mode);
  if (@_ == 1) {
    ($mode) = @_;
  } elsif (@_ == 2) {
    ($category, $mode) = @_;
  } else {
    croak 'Invalid number of arguments for die_with_stack_trace(). Expecting 1 or 2, got '
        .(scalar(@_));
  }
  my @valid = qw(no none short small long full);
  my $valid_re = join('|', @valid);
  croak "Invalid mode passed to die_with_stack_trace: ${mode}"
      if defined $mode && $mode !~ m/^(?:${valid_re})$/;
  if (defined $category) {
    $die_with_stack_trace{$category} = $mode;
  } else {
    $die_with_stack_trace = $mode;
  }
  return;
}

sub _export_logger {
  my ($pkg_name, $hint_hash) = @_;
  my $category = _get_category($pkg_name, $hint_hash);
  my $logger = _get_logger($category, $hint_hash);
  no strict 'refs';  ## no critic (ProhibitNoStrict)
  *{"${pkg_name}::__log_any_simple_logger"} = \$logger;
  return;
}

# Export one of the methods of this module to our caller. Should only be called
# on methods from the @EXPORT_OK array.
sub _export_module_method {
  my ($method, $pkg_name) = @_;
  no strict 'refs';  ## no critic (ProhibitNoStrict)
  *{"${pkg_name}::${method}"} = \&{$method};
  return;
}

# Export one of the logging methods of Log::Any to our caller.
sub _export_logging_method {
  my ($method, $pkg_name, $hint_hash) = @_;

  my $log_method = $method.'f';
  my $sub;
  if (_should_die($method, $hint_hash)) {
    my $category = _get_category($pkg_name, $hint_hash);
    $sub = sub {
      no strict 'refs';  ## no critic (ProhibitNoStrict)
      my $logger = ${"${pkg_name}::__log_any_simple_logger"};
      _die($category, _get_die_msg($logger->$log_method(@_), $hint_hash));
    };
  } else {
    $sub = sub {
      no strict 'refs';  ## no critic (ProhibitNoStrict)
      my $logger = ${"${pkg_name}::__log_any_simple_logger"};
      $logger->$log_method(@_);
      return;
    };
  }
  no strict 'refs';  ## no critic (ProhibitNoStrict)
  *{"${pkg_name}::${method}"} = set_subname($method, $sub);
  return;
}

sub _get_category {
  my ($pkg_name, $hint_hash) = @_;
  return $hint_hash->{$CATEGORY_KEY} // $pkg_name;
}

sub _get_formatter {
  my ($hint_hash) = @_;
  my $dump = ($hint_hash->{$DUMP_KEY} // 'short') eq 'short' ? \&_dump_short : \&_dump_long;
  return sub {
    my (undef, undef, $format, @args) = @_;  # First two args are the category and the numeric level.
    for (@args) {
      $_ = $_->() if ref eq 'CODE';
      $_ = '' unless defined;
      next unless ref;
      $_ = $dump->($_);
    }
    return sprintf($format, @args);
  };
}

sub _get_logger {
  my ($category, $hint_hash) = @_;
  my @args = (category => $category);
  push @args, prefix => $hint_hash->{$PREFIX_KEY} if exists $hint_hash->{$PREFIX_KEY};
  push @args, formatter => _get_formatter($hint_hash);
  return Log::Any->get_logger(@args);
}

sub _should_die {
  my ($level, $hint_hash) = @_;
  return numeric_level($level) <= ($hint_hash->{$DIE_AT_KEY} // $DIE_AT_DEFAULT);
}

sub _get_die_msg {
  my ($msg, $hint_hash) = @_;
  if ($hint_hash->{$DIE_REPEATS_MSG_KEY} // 1) {
    return $msg;
  } else {
    return 'Fatal error, see the logs for more details';
  }
}

# This method is meant to be called only at logging time (and not at import time
# like the methods above)
sub _die {
  my ($category, $msg) = @_;
  my $trace = $die_with_stack_trace{$category} // $die_with_stack_trace // 'short';
  if ($trace eq 'long' || $trace eq 'full') {
    $msg = longmess($msg);
  } elsif ($trace eq 'short' || $trace eq 'small') {
    $msg = shortmess($msg);
  } elsif ($trace eq 'none' || $trace eq 'no') {
    $msg .= "\n";
  } else {
    cluck 'Invalid $die_with_stack_trace mode. Should not happen';  # The mode is validated.
  }
  # The message returned by shortmess and longmess always end with a new line,
  # so it’s fine to use die here.
  die $msg;  ## no critic (ErrorHandling::RequireCarping)
}

sub _dump_short {
  my ($ref) = @_;  # Can be called on anything but intended to be called on ref.
  local $Data::Dumper::Indent = 0;
  local $Data::Dumper::Pad = '';  ## no critic (ProhibitEmptyQuotes)
  local $Data::Dumper::Terse = 1;
  local $Data::Dumper::Sortkeys = 1;
  local $Data::Dumper::Sparseseen = 1;
  local $Data::Dumper::Quotekeys = 0;
  # Consider Useqq = 1
  return Dumper($ref);
}

sub _dump_long {
  my ($ref) = @_;  # Can be called on anything but intended to be called on ref.
  local $Data::Dumper::Indent = 2;
  local $Data::Dumper::Pad = ' ' x 4;  ## no critic (ProhibitEmptyQuotes, ProhibitMagicNumbers)
  local $Data::Dumper::Terse = 1;
  local $Data::Dumper::Sortkeys = 1;
  local $Data::Dumper::Sparseseen = 1;
  local $Data::Dumper::Quotekeys = 0;
  # Consider Useqq = 1
  chop(my $s = Dumper($ref));  # guaranteed to end in a newline, and does not depend on $/
  return $s;
}

sub _get_singleton_logger {
  my ($pkg_name, $hint_hash) = @_;
  my $logger;
  {
    no strict 'refs';  ## no critic (ProhibitNoStrict)
    $logger = ${"${pkg_name}::__log_any_simple_logger"};
  }
  return $logger if defined $logger;
  my $category = _get_category($pkg_name, $hint_hash);
  $logger = _get_logger($category, $hint_hash);
  {
    no strict 'refs';  ## no critic (ProhibitNoStrict)
    *{"${pkg_name}::__log_any_simple_logger"} = \$logger;
  }
  return $logger;
}

# Public alias for _get_singleton_logger
sub get_logger {
  my @caller = caller(0);
  return _get_singleton_logger($caller[0], $caller[$HINT_HASH]);
}

# This blocks generates in the Log::Any::Simple namespace logging methods
# that can be called directly by the user (although the standard approach would
# be to import them in the caller’s namespace). These methods are slower because
# They need to retrieve a logger each time.
for my $name (@ALL_LOG_METHODS) {
  no strict 'refs';  ## no critic (ProhibitNoStrict)
  *{$name} = set_subname(
    $name,
    sub {
      my @caller = caller(0);
      my $hint_hash = $caller[$HINT_HASH];
      my $logger = _get_singleton_logger($caller[0], $hint_hash);
      my $method = $name.'f';
      my $msg = _get_die_msg($logger->$method(@_), $hint_hash);
      _die(_get_category($caller[0], $hint_hash), $msg) if _should_die($name, $hint_hash);
    });
}

# The list of all Log::Any::Adapter objects set by this module.
my @set_adapters;

# Creates a Log::Any::Adapter that logs to the given file descriptor ($fh)
# starting at the given $level_str. $cmd_arg_name is used only for debugging and
# is the name of the "use" statement option that triggered this call.
sub _activate_logging {
  my ($cmd_arg_name, $fh, $level_str) = @_;
  my $log_from = numeric_level($level_str);
  my $numeric_debug = numeric_level('debug');
  croak "Invalid ${cmd_arg_name} level" unless defined $log_from;
  my $adapter = Log::Any::Adapter->set(
    'Capture',
    format => 'messages',
    to => sub {
      my ($level, $category, $text) = @_;
      my $num_level = numeric_level($level);
      return if $num_level > $log_from;
      if ($num_level >= $numeric_debug) {
        chomp($text);
        printf $fh "%s(%s) - %s\n", (uc $level), $category, $text;
      } else {
        chomp($text);
        printf $fh "%s - %s\n", (uc $level), $text;
      }
    });
  push @set_adapters, $adapter;
  return;
}

# Removes all the Log::Any::Adapter objects set by _activate_logging
sub _deactivate_logging {
  Log::Any::Adapter->remove($_) for splice @set_adapters;
  return;
}

# Parses @ARGV and activate logging if there is a --log argument in it.
sub _parse_argv {
  for my $i (0 .. $#ARGV) {
    last if $ARGV[$i] eq '--';
    next unless $ARGV[$i] =~ m/^--?log(?:=(.*))?$/;
    last if $i == $#ARGV && !defined $1;
    my $cmd;
    if (defined $1) {
      $cmd = $1;
      splice @ARGV, $i, 1;
    } else {
      $cmd = $ARGV[$i + 1];
      splice @ARGV, $i, 2;
    }
    _activate_logging(':from_argv', \*STDERR, $cmd);
    last;
  }
  return;
}

1;

__END__