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