File Coverage

blib/lib/Mojo/Log.pm
Criterion Covered Total %
statement 86 87 98.8
branch 20 24 83.3
condition 6 8 75.0
subroutine 31 32 96.8
pod 11 11 100.0
total 154 162 95.0


line stmt bran cond sub pod time code
1             package Mojo::Log;
2 51     51   1359 use Mojo::Base 'Mojo::EventEmitter';
  51         147  
  51         436  
3              
4 51     51   375 use Carp qw(croak);
  51         181  
  51         2616  
5 51     51   365 use Fcntl qw(:flock);
  51         123  
  51         6893  
6 51     51   383 use Mojo::File;
  51         146  
  51         2064  
7 51     51   345 use Mojo::Util qw(encode);
  51         142  
  51         2767  
8 51     51   33124 use Term::ANSIColor qw(colored);
  51         461481  
  51         46594  
9 51     51   496 use Time::HiRes qw(time);
  51         117  
  51         568  
10              
11             has color => sub { $ENV{MOJO_LOG_COLOR} };
12             has format => sub { $_[0]->short ? \&_short : $_[0]->color ? \&_color : \&_default };
13             has handle => sub {
14              
15             # STDERR
16             return \*STDERR unless my $path = shift->path;
17              
18             # File
19             return Mojo::File->new($path)->open('>>');
20             };
21             has history => sub { [] };
22             has level => 'trace';
23             has max_history_size => 10;
24             has 'path';
25             has short => sub { $ENV{MOJO_LOG_SHORT} };
26              
27             # Supported log levels
28             my %LEVEL = (trace => 1, debug => 2, info => 3, warn => 4, error => 5, fatal => 6);
29              
30             # Systemd magic numbers
31             my %MAGIC = (trace => 7, debug => 6, info => 5, warn => 4, error => 3, fatal => 2);
32              
33             # Colors
34             my %COLORS = (warn => ['yellow'], error => ['red'], fatal => ['white on_red']);
35              
36             sub append {
37 53     53 1 206 my ($self, $msg) = @_;
38              
39 53 100       178 return unless my $handle = $self->handle;
40 25         168 flock $handle, LOCK_EX;
41 25 50       115 $handle->print(encode('UTF-8', $msg)) or croak "Can't write to log: $!";
42 25         726 flock $handle, LOCK_UN;
43             }
44              
45             sub capture {
46 18     18 1 72 my ($self, $level) = @_;
47              
48 18 100       316 croak 'Log messages are already being captured' if $self->{capturing}++;
49              
50 17         57 my $original = $self->level;
51 17   66     100 $self->level($level || $original);
52 17         111 my $subscribers = $self->subscribers('message');
53 17         81 $self->unsubscribe('message');
54              
55             my $capture = Mojo::Log::_Capture->new(sub {
56 17     17   78 delete $self->level($original)->unsubscribe('message')->{capturing};
57 17         116 $self->on(message => $_) for @$subscribers;
58 17         179 });
59 17         364 my $messages = $capture->{messages};
60             $self->on(
61             message => sub {
62 56     56   100 my $self = shift;
63 56         270 push @$messages, $self->format->(time, @_);
64             }
65 17         119 );
66              
67 17         63 return $capture;
68             }
69              
70             sub context {
71 907     907 1 2813 my ($self, @context) = @_;
72 907         3127 return $self->new(parent => $self, context => \@context, level => $self->level);
73             }
74              
75 47 100   47 1 183 sub debug { 2 >= $LEVEL{$_[0]->level} ? _log(@_, 'debug') : $_[0] }
76              
77 64 100   64 1 318 sub error { 5 >= $LEVEL{$_[0]->level} ? _log(@_, 'error') : $_[0] }
78 9 50   9 1 49 sub fatal { 6 >= $LEVEL{$_[0]->level} ? _log(@_, 'fatal') : $_[0] }
79 4 50   4 1 19 sub info { 3 >= $LEVEL{$_[0]->level} ? _log(@_, 'info') : $_[0] }
80              
81 30     30 1 119 sub is_level { $LEVEL{pop()} >= $LEVEL{shift->level} }
82              
83             sub new {
84 993     993 1 49215 my $self = shift->SUPER::new(@_);
85 993         4629 $self->on(message => \&_message);
86 993         9882 return $self;
87             }
88              
89 3146 100   3146 1 8768 sub trace { 1 >= $LEVEL{$_[0]->level} ? _log(@_, 'trace') : $_[0] }
90 4 50   4 1 23 sub warn { 4 >= $LEVEL{$_[0]->level} ? _log(@_, 'warn') : $_[0] }
91              
92             sub _color {
93 6     6   16 my $msg = _default(shift, my $level = shift, @_);
94 6 100       50 return $COLORS{$level} ? colored($COLORS{$level}, $msg) : $msg;
95             }
96              
97             sub _default {
98 269     269   652 my ($time, $level) = (shift, shift);
99 269         6368 my ($s, $m, $h, $day, $month, $year) = localtime $time;
100 269   100     5261 $time = sprintf '%04d-%02d-%02d %02d:%02d:%08.5f', $year + 1900, $month + 1, $day, $h, $m,
101             "$s." . ((split /\./, $time)[1] // 0);
102 269         2280 return "[$time] [$$] [$level] " . join(' ', @_) . "\n";
103             }
104              
105             sub _log {
106 907     907   1953 my ($self, $level) = (shift, pop);
107 907 100       2881 my @msgs = ref $_[0] eq 'CODE' ? $_[0]() : @_;
108 907 100       2690 unshift @msgs, @{$self->{context}} if $self->{context};
  868         2440  
109 907   66     4129 ($self->{parent} || $self)->emit('message', $level, @msgs);
110             }
111              
112             sub _message {
113 53     53   143 my ($self, $level) = (shift, shift);
114              
115 53         138 my $max = $self->max_history_size;
116 53         173 my $history = $self->history;
117 53         310 push @$history, my $msg = [time, $level, @_];
118 53         1123 shift @$history while @$history > $max;
119              
120 53         189 $self->append($self->format->(@$msg));
121             }
122              
123             sub _short {
124 10     10   35 my ($time, $level) = (shift, shift);
125 10         37 my ($magic, $short) = ("<$MAGIC{$level}>", substr($level, 0, 1));
126 10         98 return "${magic}[$$] [$short] " . join(' ', @_) . "\n";
127             }
128              
129             package Mojo::Log::_Capture;
130 51     51   96178 use Mojo::Base -base;
  51         141  
  51         395  
131             use overload
132 0     0   0 bool => sub {1},
133 7     7   816 '@{}' => sub { shift->{messages} },
134 23     23   7179 '""' => sub { join '', @{shift->{messages}} },
  23         279  
135 51     51   435 fallback => 1;
  51         137  
  51         732  
136              
137 51     51   6055 use Mojo::Util qw(scope_guard);
  51         143  
  51         9170  
138              
139             sub new {
140 17     17   54 my ($class, $cb) = @_;
141 17         74 return $class->SUPER::new(guard => scope_guard($cb), messages => []);
142             }
143              
144             1;
145              
146             =encoding utf8
147              
148             =head1 NAME
149              
150             Mojo::Log - Simple logger
151              
152             =head1 SYNOPSIS
153              
154             use Mojo::Log;
155              
156             # Log to STDERR
157             my $log = Mojo::Log->new;
158              
159             # Customize log file location and minimum log level
160             my $log = Mojo::Log->new(path => '/var/log/mojo.log', level => 'warn');
161              
162             # Log messages
163             $log->trace('Doing stuff');
164             $log->debug('Not sure what is happening here');
165             $log->info('FYI: it happened again');
166             $log->warn('This might be a problem');
167             $log->error('Garden variety error');
168             $log->fatal('Boom');
169              
170             =head1 DESCRIPTION
171              
172             L is a simple logger for L projects.
173              
174             =head1 EVENTS
175              
176             L inherits all events from L and can emit the following new ones.
177              
178             =head2 message
179              
180             $log->on(message => sub ($log, $level, @lines) {...});
181              
182             Emitted when a new message gets logged.
183              
184             $log->on(message => sub ($log, $level, @lines) { say "$level: ", @lines });
185              
186             =head1 ATTRIBUTES
187              
188             L implements the following attributes.
189              
190             =head2 color
191              
192             my $bool = $log->color;
193             $log = $log->color($bool);
194              
195             Colorize log messages with the levels C, C and C using L, defaults to the value of
196             the C environment variables. Note that this attribute is B and might change without
197             warning!
198              
199             =head2 format
200              
201             my $cb = $log->format;
202             $log = $log->format(sub {...});
203              
204             A callback for formatting log messages.
205              
206             $log->format(sub ($time, $level, @lines) { "[2018-11-08 14:20:13.77168] [28320] [info] I ♥ Mojolicious\n" });
207              
208             =head2 handle
209              
210             my $handle = $log->handle;
211             $log = $log->handle(IO::Handle->new);
212              
213             Log filehandle used by default L event, defaults to opening L or C.
214              
215             =head2 history
216              
217             my $history = $log->history;
218             $log = $log->history([[time, 'debug', 'That went wrong']]);
219              
220             The last few logged messages.
221              
222             =head2 level
223              
224             my $level = $log->level;
225             $log = $log->level('debug');
226              
227             Active log level, defaults to C. Available log levels are C, C, C, C, C and
228             C, in that order.
229              
230             =head2 max_history_size
231              
232             my $size = $log->max_history_size;
233             $log = $log->max_history_size(5);
234              
235             Maximum number of logged messages to store in L, defaults to C<10>.
236              
237             =head2 path
238              
239             my $path = $log->path
240             $log = $log->path('/var/log/mojo.log');
241              
242             Log file path used by L.
243              
244             =head2 short
245              
246             my $bool = $log->short;
247             $log = $log->short($bool);
248              
249             Generate short log messages without a timestamp but with journald log level prefix, suitable for systemd environments,
250             defaults to the value of the C environment variables.
251              
252             =head1 METHODS
253              
254             L inherits all methods from L and implements the following new ones.
255              
256             =head2 append
257              
258             $log->append("[2018-11-08 14:20:13.77168] [28320] [info] I ♥ Mojolicious\n");
259              
260             Append message to L.
261              
262             =head2 capture
263              
264             my $messages = $log->capture;
265             my $messages = $log->capture('debug');
266              
267             Capture log messages for as long as the returned object exists, useful for testing log messages.
268              
269             # Test your log messages
270             my $messages = $log->capture('trace');
271             $log->fatal('Something very bad happened');
272             $log->trace('Just some debug information');
273             like $messages, qr/Something very bad happened/, 'logs contain fatal message';
274             like $messages->[-1], qr/Just some debug information/, 'trace message was last';
275             undef $messages;
276              
277             =head2 context
278              
279             my $new = $log->context('[extra]', '[information]');
280              
281             Construct a new child L object that will include context information with every log message.
282              
283             # Log with context
284             my $log = Mojo::Log->new;
285             my $context = $log->context('[17a60115]');
286             $context->debug('This is a log message with context information');
287             $context->info('And another');
288              
289             =head2 debug
290              
291             $log = $log->debug('You screwed up, but that is ok');
292             $log = $log->debug('All', 'cool');
293             $log = $log->debug(sub {...});
294              
295             Emit L event and log C message.
296              
297             =head2 error
298              
299             $log = $log->error('You really screwed up this time');
300             $log = $log->error('Wow', 'seriously');
301             $log = $log->error(sub {...});
302              
303             Emit L event and log C message.
304              
305             =head2 fatal
306              
307             $log = $log->fatal('Its over...');
308             $log = $log->fatal('Bye', 'bye');
309             $log = $log->fatal(sub {...});
310              
311             Emit L event and log C message.
312              
313             =head2 info
314              
315             $log = $log->info('You are bad, but you prolly know already');
316             $log = $log->info('Ok', 'then');
317             $log = $log->info(sub {...});
318              
319             Emit L event and log C message.
320              
321             =head2 is_level
322              
323             my $bool = $log->is_level('debug');
324              
325             Check active log L.
326              
327             # True
328             $log->level('debug')->is_level('debug');
329             $log->level('debug')->is_level('info');
330              
331             # False
332             $log->level('info')->is_level('debug');
333             $log->level('fatal')->is_level('warn');
334              
335             =head2 new
336              
337             my $log = Mojo::Log->new;
338             my $log = Mojo::Log->new(level => 'warn');
339             my $log = Mojo::Log->new({level => 'warn'});
340              
341             Construct a new L object and subscribe to L event with default logger.
342              
343             =head2 trace
344              
345             $log = $log->trace('Whatever');
346             $log = $log->trace('Who', 'cares');
347             $log = $log->trace(sub {...});
348              
349             Emit L event and log C message.
350              
351             =head2 warn
352              
353             $log = $log->warn('Dont do that Dave...');
354             $log = $log->warn('No', 'really');
355             $log = $log->warn(sub {...});
356              
357             Emit L event and log C message.
358              
359             =head1 SEE ALSO
360              
361             L, L, L.
362              
363             =cut