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