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