File Coverage

blib/lib/Log/Any/Adapter/Util.pm

Criterion	Covered	Total	%
statement	58	61	95.0
branch	6	8	75.0
condition	1	3	33.3
subroutine	20	22	90.9
pod	11	11	100.0
total	96	105	91.4

use 5.008001;
use strict;
use warnings;

package Log::Any::Adapter::Util;

# ABSTRACT: Common utility functions for Log::Any
our $VERSION = '1.716';

use Exporter;
our @ISA = qw/Exporter/;

my %LOG_LEVELS;
BEGIN {
    %LOG_LEVELS = (
        EMERGENCY => 0,
        ALERT     => 1,
        CRITICAL  => 2,
        ERROR     => 3,
        WARNING   => 4,
        NOTICE    => 5,
        INFO      => 6,
        DEBUG     => 7,
        TRACE     => 8,
    );
}

use constant \%LOG_LEVELS;

our @EXPORT_OK = qw(
  cmp_deeply
  detection_aliases
  detection_methods
  dump_one_line
  log_level_aliases
  logging_aliases
  logging_and_detection_methods
  logging_methods
  make_method
  numeric_level
  read_file
  require_dynamic
);

push @EXPORT_OK, keys %LOG_LEVELS;

our %EXPORT_TAGS = ( 'levels' => [ keys %LOG_LEVELS ] );

my ( %LOG_LEVEL_ALIASES, @logging_methods, @logging_aliases, @detection_methods,
    @detection_aliases, @logging_and_detection_methods );

BEGIN {
    %LOG_LEVEL_ALIASES = (
        inform => 'info',
        warn   => 'warning',
        err    => 'error',
        crit   => 'critical',
        fatal  => 'critical'
    );
    @logging_methods =
      qw(trace debug info notice warning error critical alert emergency);
    @logging_aliases               = keys(%LOG_LEVEL_ALIASES);
    @detection_methods             = map { "is_$_" } @logging_methods;
    @detection_aliases             = map { "is_$_" } @logging_aliases;
    @logging_and_detection_methods = ( @logging_methods, @detection_methods );
}

#pod =sub logging_methods
#pod
#pod Returns a list of all logging method. E.g. "trace", "info", etc.
#pod
#pod =cut

sub logging_methods               { @logging_methods }

#pod =sub detection_methods
#pod
#pod Returns a list of detection methods.  E.g. "is_trace", "is_info", etc.
#pod
#pod =cut

sub detection_methods             { @detection_methods }

#pod =sub logging_and_detection_methods
#pod
#pod Returns a list of logging and detection methods (but not aliases).
#pod
#pod =cut

sub logging_and_detection_methods { @logging_and_detection_methods }

#pod =sub log_level_aliases
#pod
#pod Returns key/value pairs mapping aliases to "official" names.  E.g. "err" maps
#pod to "error".
#pod
#pod =cut

sub log_level_aliases             { %LOG_LEVEL_ALIASES }

#pod =sub logging_aliases
#pod
#pod Returns a list of logging alias names.  These are the keys from
#pod L.
#pod
#pod =cut

sub logging_aliases               { @logging_aliases }

#pod =sub detection_aliases
#pod
#pod Returns a list of detection aliases.  E.g. "is_err", "is_fatal", etc.
#pod
#pod =cut

sub detection_aliases             { @detection_aliases }

#pod =sub numeric_level
#pod
#pod Given a level name (or alias), returns the numeric value described above under
#pod log level constants.  E.g. "err" would return 3.
#pod
#pod =cut

sub numeric_level {
    my ($level) = @_;
    my $canonical =
      exists $LOG_LEVEL_ALIASES{ lc $level } ? $LOG_LEVEL_ALIASES{ lc $level } : $level;
    return $LOG_LEVELS{ uc($canonical) };
}

#pod =sub dump_one_line
#pod
#pod Given a reference, returns a one-line L dump with keys sorted.
#pod
#pod =cut

# lazy trampoline to load Data::Dumper only on demand but then not try to
# require it pointlessly each time
*dump_one_line = sub {
    require Data::Dumper;

    my $dumper = sub {
        my ($value) = @_;

        return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0)
        ->Terse(1)->Useqq(1)->Dump();
    };

    my $string = $dumper->(@_);
    no warnings 'redefine';
    *dump_one_line = $dumper;
    return $string;
};

#pod =sub make_method
#pod
#pod Given a method name, a code reference and a package name, installs the code
#pod reference as a method in the package.
#pod
#pod =cut

sub make_method {
    my ( $method, $code, $pkg ) = @_;

    $pkg ||= caller();
    no strict 'refs';
    *{ $pkg . "::$method" } = $code;
}

#pod =sub require_dynamic (DEPRECATED)
#pod
#pod Given a class name, attempts to load it via require unless the class
#pod already has a constructor available.  Throws an error on failure. Used
#pod internally and may become private in the future.
#pod
#pod =cut

sub require_dynamic {
    my ($class) = @_;

    return 1 if $class->can('new'); # duck-type that class is loaded

    unless ( defined( eval "require $class; 1" ) )
    {    ## no critic (ProhibitStringyEval)
        die $@;
    }
}

#pod =sub read_file (DEPRECATED)
#pod
#pod Slurp a file.  Does *not* apply any layers.  Used for testing and may
#pod become private in the future.
#pod
#pod =cut

sub read_file {
    my ($file) = @_;

    local $/ = undef;
    open( my $fh, '<:utf8', $file ) ## no critic
      or die "cannot open '$file': $!";
    my $contents = <$fh>;
    return $contents;
}

#pod =sub cmp_deeply (DEPRECATED)
#pod
#pod Compares L results for two references.  Also takes a test
#pod label as a third argument.  Used for testing and may become private in the
#pod future.
#pod
#pod =cut

sub cmp_deeply {
    my ( $ref1, $ref2, $name ) = @_;

    my $tb = Test::Builder->new();
    $tb->is_eq( dump_one_line($ref1), dump_one_line($ref2), $name );
}

# 0.XX version loaded Log::Any and some adapters relied on this happening
# behind the scenes.  Since Log::Any now uses this module, we load Log::Any
# via require after compilation to mitigate circularity.
require Log::Any;

1;


# vim: ts=4 sts=4 sw=4 et tw=75:

__END__