File Coverage

blib/lib/Catalyst/Log.pm
Criterion Covered Total %
statement 57 67 85.0
branch 16 18 88.8
condition 8 12 66.6
subroutine 22 24 91.6
pod 5 5 100.0
total 108 126 85.7


line stmt bran cond sub pod time code
1              
2             use Moose;
3 168     168   249624 with 'MooseX::Emulate::Class::Accessor::Fast';
  168         1532628  
  168         988  
4              
5             use Data::Dump;
6 168     168   976497 use Moose::Util 'find_meta';
  168         747509  
  168         10588  
7 168     168   1310 use Carp qw/ cluck /;
  168         387  
  168         1422  
8 168     168   35569  
  168         344  
  168         165551  
9             our %LEVELS = (); # Levels stored as bit field, ergo debug = 1, warn = 2 etc
10             our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc
11              
12             has level => (is => 'rw');
13             has _body => (is => 'rw');
14             has abort => (is => 'rw');
15             has autoflush => (is => 'rw', default => sub {1});
16             has _psgi_logger => (is => 'rw', predicate => '_has_psgi_logger', clearer => '_clear_psgi_logger');
17             has _psgi_errors => (is => 'rw', predicate => '_has_psgi_errors', clearer => '_clear_psgi_errors');
18              
19             my $self = shift;
20             $self->_clear_psgi_logger;
21 96     96 1 1843 $self->_clear_psgi_errors;
22 96         2698 }
23 96         2685  
24             my ($self, $env) = @_;
25              
26             $self->_psgi_logger($env->{'psgix.logger'}) if $env->{'psgix.logger'};
27 886     886 1 2942 $self->_psgi_errors($env->{'psgi.errors'}) if $env->{'psgi.errors'};
28             }
29 886 100       2547  
30 886 100       29245  
31             {
32             my @levels = qw[ debug info warn error fatal ];
33              
34             my $meta = find_meta(__PACKAGE__);
35             my $summed_level = 0;
36             for ( my $i = $#levels ; $i >= 0 ; $i-- ) {
37              
38             my $name = $levels[$i];
39              
40             my $level = 1 << $i;
41             $summed_level |= $level;
42              
43             $LEVELS{$name} = $level;
44             $LEVEL_MATCH{$name} = $summed_level;
45              
46             $meta->add_method($name, sub {
47             my $self = shift;
48              
49             if ( $self->level & $level ) {
50 187     187   9631 $self->_log( $name, @_ );
        185      
        187      
        187      
        187      
51             }
52 187 100       4824 });
53 33         114  
54             $meta->add_method("is_$name", sub {
55             my $self = shift;
56             return $self->level & $level;
57             });;
58 42     42   7545 }
        42      
        42      
        42      
        42      
59 42         1148 }
60              
61             around new => sub {
62             my $orig = shift;
63             my $class = shift;
64             my $self = $class->$orig;
65              
66             $self->levels( scalar(@_) ? @_ : keys %LEVELS );
67              
68             return $self;
69             };
70              
71             my ( $self, @levels ) = @_;
72             $self->level(0);
73             $self->enable(@levels);
74             }
75 169     169 1 650  
76 169         5056 my ( $self, @levels ) = @_;
77 169         679 my $level = $self->level;
78             for(map { $LEVEL_MATCH{$_} } @levels){
79             $level |= $_;
80             }
81 169     169 1 642 $self->level($level);
82 169         3826 }
83 169         658  
  764         1626  
84 764         1107 my ( $self, @levels ) = @_;
85             my $level = $self->level;
86 169         3824 for(map { $LEVELS{$_} } @levels){
87             $level &= ~$_;
88             }
89             $self->level($level);
90 0     0 1 0 }
91 0         0  
92 0         0 our $HAS_DUMPED;
  0         0  
93 0         0 my $self = shift;
94             unless ($HAS_DUMPED++) {
95 0         0 cluck("Catalyst::Log::_dump is deprecated and will be removed. Please change to using your own Dumper.\n");
96             }
97             $self->info( Data::Dump::dump(@_) );
98             }
99              
100 0     0   0 my $self = shift;
101 0 0       0 my $level = shift;
102 0         0 my $message = join( "\n", @_ );
103             if ($self->can('_has_psgi_logger') and $self->_has_psgi_logger) {
104 0         0 $self->_psgi_logger->({
105             level => $level,
106             message => $message,
107             });
108 33     33   66 } else {
109 33         64 $message .= "\n" unless $message =~ /\n$/;
110 33         86 my $body = $self->_body;
111 33 100 66     1009 $body .= sprintf( "[%s] %s", $level, $message );
112 1         26 $self->_body($body);
113             }
114             if( $self->autoflush && !$self->abort ) {
115             $self->_flush;
116             }
117 32 100       121 return 1;
118 32         662 }
119 32         160  
120 32         657 my $self = shift;
121             if ( $self->abort || !$self->_body ) {
122 33 100 66     694 $self->abort(undef);
123 31         85 }
124             else {
125 33         133 $self->_send_to_log( $self->_body );
126             }
127             $self->_body(undef);
128             }
129 1058     1058   2072  
130 1058 100 66     27944 my $self = shift;
131 1026         20995 if ($self->can('_has_psgi_errors') and $self->_has_psgi_errors) {
132             $self->_psgi_errors->print(@_);
133             } else {
134 32         640 binmode STDERR, ":utf8";
135             print STDERR @_;
136 1058         21726 }
137             }
138              
139             # 5.7 compat code.
140 20     20   37 # Alias _body to body, add a before modifier to warn..
141 20 100 66     561 my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
142 8         213 $meta->add_method('body', $meta->get_method('_body'));
143             my %package_hash; # Only warn once per method, per package.
144 12         54 # I haven't provided a way to disable them, patches welcome.
145 12         118 $meta->add_before_method_modifier('body', sub {
146             my $class = blessed(shift);
147             $package_hash{$class}++ || do {
148             warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n"
149             . "this will be removed in Catalyst 5.81");
150             };
151             });
152             # End 5.70 backwards compatibility hacks.
153              
154             no Moose;
155             __PACKAGE__->meta->make_immutable(inline_constructor => 0);
156              
157             1;
158              
159              
160             =for stopwords psgienv
161              
162             =head1 NAME
163              
164 168     168   1305 Catalyst::Log - Catalyst Log Class
  168         430  
  168         1408  
165              
166             =head1 SYNOPSIS
167              
168             $log = $c->log;
169             $log->debug($message);
170             $log->info($message);
171             $log->warn($message);
172             $log->error($message);
173             $log->fatal($message);
174              
175             if ( $log->is_debug ) {
176             # expensive debugging
177             }
178              
179              
180             See L<Catalyst>.
181              
182             =head1 DESCRIPTION
183              
184             This module provides the default, simple logging functionality for Catalyst.
185             If you want something different set C<< $c->log >> in your application module,
186             e.g.:
187              
188             $c->log( MyLogger->new );
189              
190             Your logging object is expected to provide the interface described here.
191             Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
192              
193             If you want to be able to log arbitrary warnings, you can do something along
194             the lines of
195              
196             $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
197              
198             however this is (a) global, (b) hairy and (c) may have unexpected side effects.
199             Don't say we didn't warn you.
200              
201             =head1 LOG LEVELS
202              
203             =head2 debug
204              
205             $log->is_debug;
206             $log->debug($message);
207              
208             =head2 info
209              
210             $log->is_info;
211             $log->info($message);
212              
213             =head2 warn
214              
215             $log->is_warn;
216             $log->warn($message);
217              
218             =head2 error
219              
220             $log->is_error;
221             $log->error($message);
222              
223             =head2 fatal
224              
225             $log->is_fatal;
226             $log->fatal($message);
227              
228             =head1 METHODS
229              
230             =head2 new
231              
232             Constructor. Defaults to enable all levels unless levels are provided in
233             arguments.
234              
235             $log = Catalyst::Log->new;
236             $log = Catalyst::Log->new( 'warn', 'error' );
237              
238             =head2 level
239              
240             Contains a bitmask of the currently set log levels.
241              
242             =head2 levels
243              
244             Set log levels
245              
246             $log->levels( 'warn', 'error', 'fatal' );
247              
248             =head2 enable
249              
250             Enable log levels
251              
252             $log->enable( 'warn', 'error' );
253              
254             =head2 disable
255              
256             Disable log levels
257              
258             $log->disable( 'warn', 'error' );
259              
260             =head2 is_debug
261              
262             =head2 is_error
263              
264             =head2 is_fatal
265              
266             =head2 is_info
267              
268             =head2 is_warn
269              
270             Is the log level active?
271              
272             =head2 abort
273              
274             Should Catalyst emit logs for this request? Will be reset at the end of
275             each request.
276              
277             *NOTE* This method is not compatible with other log apis, so if you plan
278             to use Log4Perl or another logger, you should call it like this:
279              
280             $c->log->abort(1) if $c->log->can('abort');
281              
282             =head2 autoflush
283              
284             When enabled (default), messages are written to the log immediately instead
285             of queued until the end of the request.
286              
287             This option, as well as C<abort>, is provided for modules such as
288             L<Catalyst::Plugin::Static::Simple> to be able to programmatically
289             suppress the output of log messages. By turning off C<autoflush> (application-wide
290             setting) and then setting the C<abort> flag within a given request, all log
291             messages for the given request will be suppressed. C<abort> can still be set
292             independently of turning off C<autoflush>, however. It just means any messages
293             sent to the log up until that point in the request will obviously still be emitted,
294             since C<autoflush> means they are written in real-time.
295              
296             If you need to turn off autoflush you should do it like this (in your main app
297             class):
298              
299             after setup_finalize => sub {
300             my $c = shift;
301             $c->log->autoflush(0) if $c->log->can('autoflush');
302             };
303              
304             =head2 _send_to_log
305              
306             $log->_send_to_log( @messages );
307              
308             This protected method is what actually sends the log information to STDERR.
309             You may subclass this module and override this method to get finer control
310             over the log output.
311              
312             =head2 psgienv $env
313              
314             $log->psgienv($env);
315              
316             NOTE: This is not meant for public consumption.
317              
318             Set the PSGI environment for this request. This ensures logs will be sent to
319             the right place. If the environment has a C<psgix.logger>, it will be used. If
320             not, we will send logs to C<psgi.errors> if that exists. As a last fallback, we
321             will send to STDERR as before.
322              
323             =head2 clear_psgi
324              
325             Clears the PSGI environment attributes set by L</psgienv>.
326              
327             =head2 meta
328              
329             =head1 SEE ALSO
330              
331             L<Catalyst>.
332              
333             =head1 AUTHORS
334              
335             Catalyst Contributors, see Catalyst.pm
336              
337             =head1 COPYRIGHT
338              
339             This library is free software. You can redistribute it and/or modify
340             it under the same terms as Perl itself.
341              
342             =cut
343              
344             __PACKAGE__->meta->make_immutable;
345              
346             1;