view release on metacpan or  search on metacpan

lib/Log/Dispatchouli/Proxy.pm  view on Meta::CPAN

use v5.20;
use warnings;
package Log::Dispatchouli::Proxy 3.011;
# ABSTRACT: a simple wrapper around Log::Dispatch

# Not dangerous.  Accepted without change.
use experimental 'postderef', 'signatures';

use Log::Fmt ();
use Params::Util qw(_ARRAY0 _HASH0);

#pod =head1 DESCRIPTION
#pod
#pod A Log::Dispatchouli::Proxy object is the child of a L<Log::Dispatchouli> logger
#pod (or another proxy) and relays log messages to its parent.  It behaves almost
#pod identically to a Log::Dispatchouli logger, and you should refer there for more
#pod of its documentation.
#pod
#pod Here are the differences:
#pod
#pod =begin :list
#pod
#pod * You can't create a proxy with C<< ->new >>, only by calling C<< ->proxy >> on an existing logger or proxy.
#pod
#pod * C<set_debug> will set a value for the proxy; if none is set, C<get_debug> will check the parent's setting; C<clear_debug> will clear any set value on this proxy
#pod
#pod * C<log_debug> messages will be redispatched to C<log> (to the 'debug' logging level) to prevent parent loggers from dropping them due to C<debug> setting differences
#pod
#pod =end :list
#pod
#pod =cut

sub _new ($class, $arg) {
  my $guts = {
    parent => $arg->{parent},
    logger => $arg->{logger},
    debug  => $arg->{debug},
    proxy_prefix => $arg->{proxy_prefix},
    proxy_ctx    => $arg->{proxy_ctx},
  };

  bless $guts => $class;
}

sub proxy ($self, $arg = undef) {
  $arg ||= {};

  my @proxy_ctx;

  if (my $ctx = $arg->{proxy_ctx}) {
    @proxy_ctx = _ARRAY0($ctx)
               ? (@proxy_ctx, @$ctx)
               : (@proxy_ctx, $ctx->%{ sort keys %$ctx });
  }

  my $prox = (ref $self)->_new({
    parent => $self,
    logger => $self->logger,
    debug  => $arg->{debug},
    muted  => $arg->{muted},
    proxy_prefix => $arg->{proxy_prefix},
    proxy_ctx    => \@proxy_ctx,
  });
}

sub parent ($self) { $self->{parent} }
sub logger ($self) { $self->{logger} }

sub ident     ($self) { $self->{logger}->ident }
sub config_id ($self) { $self->{logger}->config_id }

sub get_prefix   ($self)          { $self->{prefix} }
sub set_prefix   ($self, $prefix) { $self->{prefix} = $prefix }
sub clear_prefix ($self)          { undef $self->{prefix} }
sub unset_prefix ($self)          { $self->clear_prefix }

sub set_debug    ($self, $bool) { $self->{debug} = $bool ? 1 : 0 }
sub clear_debug  ($self)        { undef $self->{debug} }

sub get_debug ($self) {
  return $self->{debug} if defined $self->{debug};
  return $self->parent->get_debug;
}

sub is_debug ($self) { $self->get_debug }
sub is_info  ($) { 1 }
sub is_fatal ($) { 1 }

sub mute   ($self) { $self->{muted} = 1 }
sub unmute ($self) { $self->{muted} = 0 }

sub set_muted   ($self, $bool) { $self->{muted} = $bool ? 1 : 0 }
sub clear_muted ($self)        { undef $self->{muted} }

sub _get_local_muted ($self) { $self->{muted} }

sub get_muted ($self) {
  return $self->{muted} if defined $self->{muted};
  return $self->parent->get_muted;
}

sub _get_all_prefix ($self, $arg) {