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