File Coverage

blib/lib/Net/CLI/Interact/Logger.pm
Criterion Covered Total %
statement 36 56 64.2
branch 7 22 31.8
condition 1 3 33.3
subroutine 12 13 92.3
pod 2 3 66.6
total 58 97 59.7


line stmt bran cond sub pod time code
1             package Net::CLI::Interact::Logger;
2             { $Net::CLI::Interact::Logger::VERSION = '2.400000' }
3              
4 1     1   17 use Moo;
  1         2  
  1         7  
5 1     1   388 use Sub::Quote;
  1         2  
  1         69  
6 1     1   6 use MooX::Types::MooseLike::Base qw(HashRef Bool ArrayRef Any);
  1         2  
  1         73  
7              
8 1     1   579 use Class::Mix qw(genpkg);
  1         6838  
  1         65  
9 1     1   17 use Time::HiRes qw(gettimeofday tv_interval);
  1         2  
  1         15  
10 1     1   751 use Log::Dispatch::Config; # loads Log::Dispatch
  1         263650  
  1         48  
11 1     1   555 use Log::Dispatch::Configurator::Any;
  1         12229  
  1         215  
12              
13             sub BUILDARGS {
14 2     2 0 3618 my ($class, @args) = @_;
15              
16             # accept single hash ref or naked hash
17 2 50       11 my $params = (ref {} eq ref $args[0] ? $args[0] : {@args});
18              
19             # back-compat for old attr name
20 2 50       11 $params->{log_stamp} = $params->{log_stamps} if exists $params->{log_stamps};
21              
22 2         35 return $params;
23             }
24              
25             has log_config => (
26             is => 'rw',
27             isa => HashRef,
28             builder => 1,
29             trigger => quote_sub(q{ $_[0]->_clear_logger }),
30             );
31              
32             sub _build_log_config {
33             return {
34 2     2   175 dispatchers => ['screen'],
35             screen => {
36             class => 'Log::Dispatch::Screen',
37             min_level => 'debug',
38             },
39             };
40             }
41              
42             has _logger => (
43             is => 'ro',
44             isa => quote_sub(q{ $_[0]->isa('Log::Dispatch::Config') }),
45             builder => 1,
46             lazy => 1,
47             clearer => 1,
48             );
49              
50             # this allows each instance of this module to have its own
51             # wrapped logger with different configuration.
52             sub _build__logger {
53 0     0   0 my $self = shift;
54              
55 0         0 my $anon_logger = genpkg();
56             {
57 1     1   9 no strict 'refs';
  1         3  
  1         716  
  0         0  
58 0         0 @{"$anon_logger\::ISA"} = 'Log::Dispatch::Config';
  0         0  
59             }
60              
61 0         0 my $config = Log::Dispatch::Configurator::Any->new($self->log_config);
62 0         0 $anon_logger->configure($config);
63              
64 0         0 return $anon_logger->instance;
65             }
66              
67             has 'log_stamp' => (
68             is => 'rw',
69             isa => Bool,
70             default => quote_sub('1'),
71             );
72              
73             has 'log_category' => (
74             is => 'rw',
75             isa => Bool,
76             default => quote_sub('1'),
77             );
78              
79             has 'log_start' => (
80             is => 'ro',
81             isa => ArrayRef,
82             default => sub{ [gettimeofday] },
83             );
84              
85             has 'log_flags' => (
86             is => 'rw',
87             isa => Any, # FIXME 'ArrayRef|HashRef[Str]',
88             default => sub { {} },
89             );
90              
91             my %code_for = (
92             debug => 0,
93             info => 1,
94             notice => 2,
95             warning => 3,
96             error => 4,
97             critical => 5,
98             alert => 6,
99             emergency => 7,
100             );
101              
102             sub would_log {
103 2     2 1 6 my ($self, $category, $level) = @_;
104 2 50 33     12 return 0 if !defined $category or !defined $level;
105              
106             my $flags = (ref $self->log_flags eq ref []
107 2 50       37 ? { map {$_ => 'error'} @{$self->log_flags} }
  0         0  
  0         0  
108             : $self->log_flags
109             );
110              
111 2 50       63 return 0 if !exists $code_for{$level};
112 2 50       15 return 0 if !exists $flags->{$category};
113 0         0 return ($code_for{$level} >= $code_for{ $flags->{$category} });
114             }
115              
116             sub log {
117 2     2 1 40 my ($self, $category, $level, @msgs) = @_;
118 2 50       8 return unless $self->would_log($category, $level);
119 0           @msgs = grep {defined} @msgs;
  0            
120 0 0         return unless scalar @msgs;
121              
122 0           my $prefix = '';
123 0 0         $prefix .= sprintf "[%11s] ", sprintf "%.6f", (tv_interval $self->log_start, [gettimeofday])
124             if $self->log_stamp;
125 0 0         $prefix .= (substr $category, 0, 2)
126             if $self->log_category;
127              
128 0           my $suffix = '';
129 0 0         $suffix = "\n" if $msgs[-1] !~ m/\n$/;
130              
131 0           $self->_logger->$level($prefix . (' ' x (2 - $code_for{$level})), (join ' ', @msgs) . $suffix);
132             }
133              
134             1;
135              
136             =pod
137              
138             =head1 NAME
139              
140             Net::CLI::Interact::Logger - Per-instance multi-target logging, with categories
141              
142             =head1 SYNOPSIS
143              
144             $logger->log($category, $level, @message);
145              
146             =head1 DESCRIPTION
147              
148             This module implements a generic logging service, based on L<Log::Dispatch>
149             but with additional options and configuration. Log messages coming from your
150             application are categorized, and each category can be enabled/disabled
151             separately and have its own log level (i.e. C<emergency> .. C<debug>). High
152             resolution timestamps can be added to log messages.
153              
154             =head1 DEFAULT CONFIGURATION
155              
156             Being based on L<Log::Dispatch::Config>, this logger can have multiple
157             targets, each configured for independent level thresholds. The overall default
158             configuration is to print log messages to the screen (console), with a minimum
159             level of C<debug>. Each category (see below) has its own log level as well.
160              
161             Note that categories, as discussed below, are arbitrary so if a category is
162             not explicitly enabled or disabled, it is assumed to be B<disabled>. If you
163             wish to invent a new category for your application, simply think of the name
164             and begin to use it, with a C<$level> and C<@message> as above in the
165             SYNOPSIS.
166              
167             =head1 INTERFACE
168              
169             =head2 log( $category, $level, @message )
170              
171             The combination of category and level determine whether the the log messages
172             are emitted to any of the log destinations. Destinations are set using the
173             C<log_config> method, and categories are configured using the C<log_flags>
174             method.
175              
176             The C<@message> list will be joined by a space character, and a newline
177             appended if the last message doesn't contain one itself. Messages are
178             prepended with the first character of their C<$category>, and then indented
179             proportionally to their C<$level>.
180              
181             =head2 log_config( \%config )
182              
183             A C<Log::Dispatch::Config> configuration (hash ref), meaning multiple log
184             targets may be specified with different minimum level thresholds. There is a
185             default configuration which emits messages to your screen (console) with no
186             minimum threshold:
187              
188             {
189             dispatchers => ['screen'],
190             screen => {
191             class => 'Log::Dispatch::Screen',
192             min_level => 'debug',
193             },
194             };
195              
196             =head2 log_flags( \@categories | \%category_level_map )
197              
198             The user is expected to specify which log categories they are interested in,
199             and at what levels. If a category is used in the application for logging but
200             not specified, then it is deemed B<disabled>. Hence, even though the default
201             destination log level is C<debug>, no messages are emitted until a category is
202             enabled.
203              
204             In the array reference form, the list should contain category names, and they
205             will all be mapped to the C<error> level:
206              
207             $logger->log_flags([qw/
208             network
209             disk
210             io
211             cpu
212             /]);
213              
214             In the hash reference form, the keys should be category names and the values
215             log levels from the list below (ordered such that each level "includes" the
216             levels I<above>):
217              
218             emergency
219             alert
220             critical
221             error
222             warning
223             notice
224             info
225             debug
226              
227             For example:
228              
229             $logger->log_flags({
230             network => 'info',
231             disk => 'debug',
232             io => 'critical',
233             cpu => 'debug',
234             });
235              
236             Messages at or above the specified level will be passed on to the
237             C<Log::Dispatch> target, which may then specify an overriding threshold.
238              
239             =head2 C< Net::CLI::Interact->default_log_categories() >>
240              
241             Not a part of this class, but the only way to retrieve a list of the current
242             log categories used in the L<Net::CLI::Interact> distribution source. Does not
243             take into account any log categories added by the user.
244              
245             =head2 log_stamp( $boolean )
246              
247             Enable (the default) or disable the display of high resolution interval
248             timestamps with each log message.
249              
250             =head2 log_category( $boolean )
251              
252             Enable (the default) or disable the display of the first letters of the
253             category name with each log message.
254              
255             =head2 log_start( [$seconds, $microseconds] )
256              
257             Time of the start for generating a time interval when logging stamps. Defaults
258             to the result of C<Time::HiRes::gettimeofday> at the point the module is
259             loaded, in list context.
260              
261             =head2 would_log( $category, $level )
262              
263             Returns True if, according to the current C<log_flags>, the given C<$category>
264             is enabled at or above the threshold of C<$level>, otherwise returns False.
265             Note that the C<Log::Dispatch> targets maintain their own thresholds as well.
266              
267             =cut
268