lib/Catalyst/Log.pm

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