File Coverage

blib/lib/Log/Agent/Logger.pm
Criterion Covered Total %
statement 132 163 80.9
branch 39 68 57.3
condition 4 9 44.4
subroutine 17 25 68.0
pod 11 12 91.6
total 203 277 73.2


line stmt bran cond sub pod time code
1             #!./perl
2             ###########################################################################
3             #
4             # Logger.pm
5             #
6             # Copyright (C) 1999-2000 Raphael Manfredi.
7             # Copyright (C) 2015 Mark Rogaski, mrogaski@cpan.org;
8             # all rights reserved.
9             #
10             # See the README file included with the
11             # distribution for license information.
12             #
13             ##########################################################################
14              
15 4     4   24359 use strict;
  4         11  
  4         141  
16              
17             ########################################################################
18             package Log::Agent::Logger;
19              
20 4     4   18 use vars qw($VERSION);
  4         8  
  4         232  
21              
22             our $VERSION = '0.201';
23             $VERSION = eval $VERSION;
24              
25 4     4   1770 use Log::Agent;
  4         24772  
  4         373  
26 4     4   32 use Log::Agent::Formatting qw(tag_format_args);
  4         9  
  4         135  
27 4     4   21 use Log::Agent::Priorities qw(:LEVELS level_from_prio prio_from_level);
  4         7  
  4         575  
28 4     4   2001 use Getargs::Long qw(ignorecase);
  4         37367  
  4         36  
29              
30             BEGIN {
31 4     4   5826 no strict 'refs';
  4         9  
  4         470  
32 4     4   14 my %fn;
33 4 50       47 %fn = (
34             'emerg' => q/['emerg', EMERG]/,
35             'emergency' => q/['emerg', EMERG]/,
36             'alert' => q/['alert', ALERT]/,
37             'crit' => q/['crit', CRIT]/,
38             'critical' => q/['crit', CRIT]/,
39             'err' => q/['err', ERROR]/,
40             'error' => q/['err', ERROR]/,
41             'warning', => q/['warning', WARN]/,
42             'warn', => q/['warning', WARN]/,
43             'notice' => q/['notice', NOTICE]/,
44             'info' => q/['info', INFO]/,
45             'debug' => q/['debug', DEBUG]/,
46             ) unless defined &emergency;
47 4         31 for my $sub (keys %fn) {
48 48         98 my $prilvl = $fn{$sub};
49 48 50   5   4698 *$sub = eval qq{
  5 50       122  
  5 50       30  
  0 0       0  
  5 50       25  
  5 0       21  
  1 100       18  
  1 50       3  
  0 50       0  
  1 50       3  
  1 50       4  
  1 50       3  
  1         4  
  0         0  
  1         5  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         17  
  1         4  
  0         0  
  1         4  
  1         3  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  8         954  
  8         24  
  3         10  
  5         17  
  8         23  
  2         53  
  2         9  
  0         0  
  2         10  
  2         9  
  1         21  
  1         3  
  0         0  
  1         4  
  1         4  
  1         26  
  1         5  
  1         7  
  0         0  
  1         4  
  1         17  
  1         4  
  0         0  
  1         3  
  1         3  
  2         41  
  2         8  
  0         0  
  2         10  
  2         8  
50             sub {
51             my \$self = shift;
52             if (ref \$_[0] eq 'CODE') {
53             \$self->_log_fn($prilvl, \\\@_);
54             } else {
55             \$self->_log($prilvl, \\\@_);
56             }
57             return;
58             }
59             };
60             }
61             }
62              
63             #
64             # ->make
65             #
66             # Creation routine.
67             #
68             # Attributes (and switches that set them):
69             #
70             # -channel logging channel
71             # -max_prio maximum priority logged (included)
72             # -min_prio minimum priority logged (included)
73             # -caller customizes the caller information to be inserted
74             # -priority customizes the priority information to be inserted
75             # -tags list of user-defined tags to add to messages
76             #
77             sub make {
78 4     4 0 2434 my $self = bless {}, shift;
79 4         10 my ($caller, $priority, $tags);
80              
81             (
82             $self->{channel}, $self->{max_prio}, $self->{min_prio},
83 4         52 $caller, $priority, $tags
84             ) = xgetargs(@_,
85             -channel => 'Log::Agent::Channel',
86             -max_prio => ['s', DEBUG],
87             -min_prio => ['s', EMERG],
88             -caller => ['ARRAY'],
89             -priority => ['ARRAY'],
90             -tags => ['ARRAY'],
91             );
92              
93             #
94             # Always use numeric priorities internally
95             #
96              
97             $self->{max_prio} = level_from_prio($self->{max_prio})
98 4 50       2076 if $self->{max_prio} =~ /^\D+$/;
99              
100             $self->{min_prio} = level_from_prio($self->{min_prio})
101 4 50       62 if $self->{min_prio} =~ /^\D+$/;
102              
103 4 100       16 $self->set_priority_info(@$priority) if defined $priority;
104 4 100       17 $self->set_caller_info(@$caller) if defined $caller;
105              
106             #
107             # Handle -tags => [ ]
108             #
109              
110 4 100       15 if (defined $tags) {
111 1         2 my $type = "Log::Agent::Tag";
112 1 50 33     3 if (grep { !ref $_ || !$_->isa($type) } @$tags) {
  1         15  
113 0         0 require Carp;
114 0         0 Carp::croak("Argument -tags must supply list of $type objects");
115             }
116 1 50       3 if (@$tags) {
117 1         464 require Log::Agent::Tag_List;
118 1         1892 $self->{tags} = Log::Agent::Tag_List->make(@$tags);
119             }
120             }
121              
122 4         34 return $self;
123             }
124              
125             #
126             # Attribute access
127             #
128              
129 0     0 1 0 sub channel { $_[0]->{channel} }
130 0     0 1 0 sub max_prio { $_[0]->{max_prio} }
131 0     0 1 0 sub min_prio { $_[0]->{min_prio} }
132 1 50   1 1 12 sub tags { $_[0]->{tags} || $_[0]->_init_tags }
133              
134 0     0 1 0 sub max_prio_str { prio_from_level $_[0]->{max_prio} }
135 0     0 1 0 sub min_prio_str { prio_from_level $_[0]->{min_prio} }
136              
137             sub set_max_prio
138 0 0   0 1 0 { $_[0]->{max_prio} = $_[1] =~ /^\D+$/ ? level_from_prio($_[1]) : $_[1] }
139             sub set_min_prio
140 0 0   0 1 0 { $_[0]->{min_prio} = $_[1] =~ /^\D+$/ ? level_from_prio($_[1]) : $_[1] }
141              
142             #
143             # ->close
144             #
145             # Close underlying channel, and detach from it.
146             #
147             sub close {
148 3     3 1 341 my $self = shift;
149 3         6 my $channel = $self->{channel};
150 3 50       11 return unless defined $channel; # Already closed
151 3         7 $self->{channel} = undef;
152 3         13 $channel->close;
153             }
154              
155             #
156             # ->set_caller_info
157             #
158             # Change settings of caller tag information.
159             # Giving an empty list removes caller tagging.
160             #
161             sub set_caller_info {
162 3     3 1 11 my $self = shift;
163              
164 3 100       7 unless (@_) {
165 1         4 delete $self->{caller};
166 1         3 return;
167             }
168              
169 2         583 require Log::Agent::Tag::Caller;
170 2         1676 $self->{caller} = Log::Agent::Tag::Caller->make(-offset => 4, @_);
171 2         205 return;
172             }
173              
174             #
175             # ->set_priority_info
176             #
177             # Change settings of caller tag information.
178             # Giving an empty list removes priority tagging.
179             #
180             sub set_priority_info {
181 3     3 1 12 my $self = shift;
182 3         5 my @info = @_;
183              
184 3 100       9 unless (@info) {
185 1         3 delete $self->{priority};
186 1         3 return;
187             }
188              
189 2         5 $self->{priority} = \@info; # For objects created in _prio_tag()
190              
191             #
192             # When settings are changes, we need to clear the cache of priority
193             # tags generated by _prio_tag().
194             #
195              
196 2         12 $self->{prio_cache} = {}; # Internal for ->_prio_tag()
197 2         5 return;
198             }
199              
200              
201             #
202             # ->_log
203             #
204             # Emit log at given priority, if within priority bounds.
205             #
206             sub _log {
207 19     19   49 my ($self, $prilvl) = splice(@_, 0, 2);
208 19         37 my $channel = $self->{channel};
209 19 100       56 return unless defined $channel; # Closed
210              
211             #
212             # Prune call if we're not within bounds.
213             # $prilvl is seomthing like ["error", ERROR].
214             #
215              
216 18         29 my $lvl = $prilvl->[1];
217 18 100 66     90 return if $lvl > $self->{max_prio} || $lvl < $self->{min_prio};
218              
219             #
220             # Issue logging.
221             #
222              
223 17 100       44 my $priority = $self->_prio_tag(@$prilvl) if defined $self->{priority};
224              
225             $channel->write($prilvl->[0],
226 17         86 tag_format_args($self->{caller}, $priority, $self->{tags}, @_));
227              
228 17         9683 return;
229             }
230              
231             #
232             # ->_log_fn
233             #
234             # Emit log at given priority, if within priority bounds.
235             # The logged string needs to be computed by calling back a routine.
236             #
237             sub _log_fn {
238 4     4   11 my ($self, $prilvl) = splice(@_, 0, 2);
239 4         7 my $channel = $self->{channel};
240 4 50       9 return unless defined $channel; # Closed
241              
242             #
243             # Prune call if we're not within bounds.
244             # $prilvl is seomthing like ["error", ERROR].
245             #
246              
247 4         7 my $lvl = $prilvl->[1];
248 4 50 33     20 return if $lvl > $self->{max_prio} || $lvl < $self->{min_prio};
249              
250             #
251             # Issue logging.
252             #
253              
254 4         6 my $fn = shift @{$_[0]};
  4         6  
255 4         7 my $msg = &$fn(@{$_[0]});
  4         11  
256 4 50       20 return unless length $msg; # Null messsage, don't log
257              
258 4 50       10 my $priority = $self->_prio_tag(@$prilvl) if defined $self->{priority};
259              
260             $channel->write($prilvl->[0],
261 4         30 tag_format_args($self->{caller}, $priority, $self->{tags}, [$msg]));
262              
263 4         665 return;
264             }
265              
266             #
267             # _prio_tag
268             #
269             # Returns Log::Agent::Tag::Priority message that is suitable for tagging
270             # at this priority/level, if configured to log priorities.
271             #
272             # Objects are cached into `prio_cache'.
273             #
274             sub _prio_tag {
275 4     4   5 my $self = shift;
276 4         7 my ($prio, $level) = @_;
277 4         13 my $ptag = $self->{prio_cache}->{$prio, $level};
278 4 50       7 return $ptag if defined $ptag;
279              
280 4         590 require Log::Agent::Tag::Priority;
281              
282             #
283             # Common attributes (formatting, postfixing, etc...) are held in
284             # the `priorities' attribute. We add the priority/level here.
285             #
286              
287             $ptag = Log::Agent::Tag::Priority->make(
288             -priority => $prio,
289             -level => $level,
290 4         1798 @{$self->{priority}}
  4         28  
291             );
292              
293 4         857 return $self->{prio_cache}->{$prio, $level} = $ptag;
294             }
295              
296             #
297             # ->_init_tags
298             #
299             # Initialize the `tags' attribute the first time it is requested
300             # Returns its value.
301             #
302             sub _init_tags {
303 0     0     my $self = shift;
304 0           require Log::Agent::Tag_List;
305 0           return $self->{tags} = Log::Agent::Tag_List->make();
306             }
307              
308             1; # for require
309             __END__