File Coverage

blib/lib/Log/Dispatchouli/Proxy.pm
Criterion Covered Total %
statement 47 61 77.0
branch 13 20 65.0
condition 5 8 62.5
subroutine 21 31 67.7
pod 0 23 0.0
total 86 143 60.1


line stmt bran cond sub pod time code
1 6     6   46 use strict;
  6         13  
  6         199  
2 6     6   28 use warnings;
  6         14  
  6         281  
3             package Log::Dispatchouli::Proxy;
4             # ABSTRACT: a simple wrapper around Log::Dispatch
5             $Log::Dispatchouli::Proxy::VERSION = '2.023';
6 6     6   33 use Params::Util qw(_ARRAY0 _HASH0);
  6         10  
  6         6276  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod A Log::Dispatchouli::Proxy object is the child of a L<Log::Dispatchouli> logger
11             #pod (or another proxy) and relays log messages to its parent. It behaves almost
12             #pod identically to a Log::Dispatchouli logger, and you should refer there for more
13             #pod of its documentation.
14             #pod
15             #pod Here are the differences:
16             #pod
17             #pod =begin :list
18             #pod
19             #pod * You can't create a proxy with C<< ->new >>, only by calling C<< ->proxy >> on an existing logger or proxy.
20             #pod
21             #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
22             #pod
23             #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
24             #pod
25             #pod =end :list
26             #pod
27             #pod =cut
28              
29             sub _new {
30 3     3   10 my ($class, $arg) = @_;
31              
32             my $guts = {
33             parent => $arg->{parent},
34             logger => $arg->{logger},
35             debug => $arg->{debug},
36             proxy_prefix => $arg->{proxy_prefix},
37 3         14 };
38              
39 3         28 bless $guts => $class;
40             }
41              
42             sub proxy {
43 1     1 0 3 my ($self, $arg) = @_;
44 1   50     3 $arg ||= {};
45              
46             (ref $self)->_new({
47             parent => $self,
48             logger => $self->logger,
49             debug => $arg->{debug},
50             muted => $arg->{muted},
51             proxy_prefix => $arg->{proxy_prefix},
52 1         5 });
53             }
54              
55 27     27 0 82 sub parent { $_[0]{parent} }
56 3     3 0 18 sub logger { $_[0]{logger} }
57              
58 1     1 0 34 sub ident { $_[0]{logger}->ident }
59 0     0 0 0 sub config_id { $_[0]{logger}->config_id }
60              
61 2     2 0 9 sub set_prefix { $_[0]{prefix} = $_[1] }
62 21     21 0 106 sub get_prefix { $_[0]{prefix} }
63 0     0 0 0 sub clear_prefix { undef $_[0]{prefix} }
64 0     0 0 0 sub unset_prefix { $_[0]->clear_prefix }
65              
66 2 100   2 0 1115 sub set_debug { $_[0]{debug} = $_[1] ? 1 : 0 }
67 0     0 0 0 sub clear_debug { undef $_[0]{debug} }
68              
69             sub get_debug {
70 8 100   8 0 22 return $_[0]{debug} if defined $_[0]{debug};
71 4         10 return $_[0]->parent->get_debug;
72             }
73              
74 3     3 0 14 sub mute { $_[0]{muted} = 1 }
75 1     1 0 5 sub unmute { $_[0]{muted} = 0 }
76              
77 0 0   0 0 0 sub set_muted { $_[0]{muted} = $_[1] ? 1 : 0 }
78 6     6 0 1640 sub clear_muted { undef $_[0]{muted} }
79              
80 26     26   109 sub _get_local_muted { $_[0]{muted} }
81              
82             sub get_muted {
83 0 0   0 0 0 return $_[0]{muted} if defined $_[0]{muted};
84 0         0 return $_[0]->parent->get_muted;
85             }
86              
87             sub _get_all_prefix {
88 21     21   40 my ($self, $arg) = @_;
89              
90             return [
91             $self->{proxy_prefix},
92             $self->get_prefix,
93 4         13 _ARRAY0($arg->{prefix}) ? @{ $arg->{prefix} } : $arg->{prefix}
94 21 100       47 ];
95             }
96              
97             sub log {
98 26     26 0 98 my ($self, @rest) = @_;
99 26 100       76 my $arg = _HASH0($rest[0]) ? shift(@rest) : {};
100              
101 26 100 66     64 return if $self->_get_local_muted and ! $arg->{fatal};
102              
103 21         44 local $arg->{prefix} = $self->_get_all_prefix($arg);
104              
105 21         54 $self->parent->log($arg, @rest);
106             }
107              
108             sub log_fatal {
109 0     0 0 0 my ($self, @rest) = @_;
110              
111 0 0       0 my $arg = _HASH0($rest[0]) ? shift(@rest) : {};
112 0         0 local $arg->{fatal} = 1;
113              
114 0         0 $self->log($arg, @rest);
115             }
116              
117             sub log_debug {
118 6     6 0 31 my ($self, @rest) = @_;
119              
120 6         14 my $debug = $self->get_debug;
121 6 100 66     38 return if defined $debug and ! $debug;
122              
123 3 50       12 my $arg = _HASH0($rest[0]) ? shift(@rest) : {};
124 3         10 local $arg->{level} = 'debug';
125              
126 3         8 $self->log($arg, @rest);
127             }
128              
129 0     0 0   sub info { shift()->log(@_); }
130 0     0 0   sub fatal { shift()->log_fatal(@_); }
131 0     0 0   sub debug { shift()->log_debug(@_); }
132              
133             use overload
134 1     1   3 '&{}' => sub { my ($self) = @_; sub { $self->log(@_) } },
  1         7  
  1         4  
135 6         57 fallback => 1,
136 6     6   82 ;
  6         17  
137              
138             1;
139              
140             __END__
141              
142             =pod
143              
144             =encoding UTF-8
145              
146             =head1 NAME
147              
148             Log::Dispatchouli::Proxy - a simple wrapper around Log::Dispatch
149              
150             =head1 VERSION
151              
152             version 2.023
153              
154             =head1 DESCRIPTION
155              
156             A Log::Dispatchouli::Proxy object is the child of a L<Log::Dispatchouli> logger
157             (or another proxy) and relays log messages to its parent. It behaves almost
158             identically to a Log::Dispatchouli logger, and you should refer there for more
159             of its documentation.
160              
161             Here are the differences:
162              
163             =over 4
164              
165             =item *
166              
167             You can't create a proxy with C<< ->new >>, only by calling C<< ->proxy >> on an existing logger or proxy.
168              
169             =item *
170              
171             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
172              
173             =item *
174              
175             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
176              
177             =back
178              
179             =head1 PERL VERSION SUPPORT
180              
181             This module has a long-term perl support period. That means it will not
182             require a version of perl released fewer than five years ago.
183              
184             Although it may work on older versions of perl, no guarantee is made that the
185             minimum required version will not be increased. The version may be increased
186             for any reason, and there is no promise that patches will be accepted to lower
187             the minimum required perl.
188              
189             =head1 AUTHOR
190              
191             Ricardo SIGNES <rjbs@semiotic.systems>
192              
193             =head1 COPYRIGHT AND LICENSE
194              
195             This software is copyright (c) 2021 by Ricardo SIGNES.
196              
197             This is free software; you can redistribute it and/or modify it under
198             the same terms as the Perl 5 programming language system itself.
199              
200             =cut