File Coverage

blib/lib/Log/Any/Proxy.pm

Criterion	Covered	Total	%
statement	72	78	92.3
branch	36	44	81.8
condition	18	26	69.2
subroutine	17	17	100.0
pod	0	3	0.0
total	143	168	85.1

use 5.008001;
use strict;
use warnings;

package Log::Any::Proxy;

# ABSTRACT: Log::Any generator proxy object
our $VERSION = '1.717';

use Log::Any::Adapter::Util ();
use overload;

sub _stringify_params {
    my @params = @_;

    return map {
        !defined($_)
          ? ''
          : ref($_) ? (
            overload::OverloadedStringify($_)
            ? "$_"
            : Log::Any::Adapter::Util::dump_one_line($_)
          )
          : $_
    } @params;
}

sub _default_formatter {
    my ( $cat, $lvl, $format, @params ) = @_;
    return $format->() if ref($format) eq 'CODE';

    my @new_params = _stringify_params(@params);

    # Perl 5.22 adds a 'redundant' warning if the number parameters exceeds
    # the number of sprintf placeholders.  If a user does this, the warning
    # is issued from here, which isn't very helpful.  Doing something
    # clever would be expensive, so instead we just disable warnings for
    # the final line of this subroutine.
    no warnings;
    return sprintf( $format, @new_params );
}

sub new {
    my $class = shift;
    my $self = { formatter => \&_default_formatter, @_ };
    unless ( $self->{adapter} ) {
        require Carp;
        Carp::croak("$class requires an 'adapter' parameter");
    }
    unless ( defined $self->{category} ) {
        require Carp;
        Carp::croak("$class requires a 'category' parameter");
    }
    unless ( $self->{context} ) {
        require Carp;
        Carp::croak("$class requires a 'context' parameter");
    }
    bless $self, $class;
    $self->init(@_);
    return $self;
}

sub clone {
    my $self = shift;
    return (ref $self)->new( %{ $self }, @_ );
}

sub init { }

for my $attr (qw/adapter category filter formatter prefix context/) {
    no strict 'refs';
    *{$attr} = sub { return $_[0]->{$attr} };
}

my %aliases = Log::Any::Adapter::Util::log_level_aliases();

# Set up methods/aliases and detection methods/aliases
foreach my $name ( Log::Any::Adapter::Util::logging_methods(), keys(%aliases) )
{
    my $realname    = $aliases{$name} || $name;
    my $namef       = $name . "f";
    my $is_name     = "is_$name";
    my $is_realname = "is_$realname";
    my $numeric     = Log::Any::Adapter::Util::numeric_level($realname);
    no strict 'refs';
    *{$is_name} = sub {
        my ($self) = @_;
        return $self->{adapter}->$is_realname;
    };
    *{$name} = sub {
        my ( $self, @parts ) = @_;
        return if !$self->{adapter}->$is_realname && !defined wantarray;

        my $structured_logging =
            $self->{adapter}->can('structured') && !$self->{filter};

        my $data_from_parts = pop @parts
            if ( @parts && ( ( ref $parts[-1] || '' ) eq ref {} ) );
        my $data_from_context = $self->{context};
        my $data =
            { map {%$_} grep {$_ && %$_} $data_from_context, $data_from_parts };

        if ($structured_logging) {
            unshift @parts, $self->{prefix} if $self->{prefix};
            $self->{adapter}
              ->structured( $realname, $self->{category}, @parts, grep {%$_} $data );
            return unless defined wantarray;
        }

        @parts = grep { defined($_) && length($_) } @parts;
        push @parts, _stringify_params($data) if %$data;

        my $message = join( " ", @parts );
        if ( length $message && !$structured_logging ) {
            $message =
              $self->{filter}->( $self->{category}, $numeric, $message )
              if defined $self->{filter};
            if ( defined $message and length $message ) {
                $message = "$self->{prefix}$message"
                  if defined $self->{prefix} && length $self->{prefix};
                $self->{adapter}->$realname($message);
            }
        }
        return $message if defined wantarray;
    };
    *{$namef} = sub {
        my ( $self, @args ) = @_;
        return if !$self->{adapter}->$is_realname && !defined wantarray;
        my $message =
          $self->{formatter}->( $self->{category}, $numeric, @args );
        return unless defined $message and length $message;
        return $self->$name($message);
    };
}

1;


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

__END__