File Coverage

blib/lib/Log/Any/Proxy.pm

Criterion	Covered	Total	%
statement	72	78	92.3
branch	38	44	86.3
condition	18	23	78.2
subroutine	16	16	100.0
pod	0	3	0.0
total	144	164	87.8

use 5.008001;
use strict;
use warnings;

package Log::Any::Proxy;

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

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 $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;
    };
    for my $f ( '', 'f' ) {
        *{"$name$f"} = sub {
            my ( $self, @parts ) = @_;
            my $adapter = $self->{adapter};
            return if !$adapter->$is_realname && !defined wantarray;

            if ($f eq 'f') {
                my $message =
                  $self->{formatter}->( $self->{category}, $numeric, @parts );
                return unless defined $message and length $message;
                @parts = ( $message );
            }

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

            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};
                $adapter->$structured_logging( $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};
                    $adapter->$realname($message);
                }
            }
            return $message if defined wantarray;
        };
    }
}

1;


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

__END__