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 Class::MOP ();
   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 _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 $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__);
  37     my $summed_level = 0;
  38     for ( my $i = $#levels ; $i >= 0 ; $i-- ) {
  39
  40         my $name  = $levels[$i];
  41
  42         my $level = 1 << $i;
  43         $summed_level |= $level;
  44
  45         $LEVELS{$name} = $level;
  46         $LEVEL_MATCH{$name} = $summed_level;
  47
  48        $meta->add_method($name, sub {
  49             my $self = shift;
  50
  51             if ( $self->level & $level ) {
  52                 $self->_log( $name, @_ );
  53             }
  54         });
  55
  56         $meta->add_method("is_$name", sub {
  57             my $self = shift;
  58             return $self->level & $level;
  59         });;
  60     }
  61 }
  62
  63 around new => sub {
  64     my $orig = shift;
  65     my $class = shift;
  66     my $self = $class->$orig;
  67
  68     $self->levels( scalar(@_) ? @_ : keys %LEVELS );
  69
  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 }
 122
 123 sub _flush {
 124     my $self = shift;
 125     if ( $self->abort || !$self->_body ) {
 126         $self->abort(undef);
 127     }
 128     else {
 129         $self->_send_to_log( $self->_body );
 130     }
 131     $self->_body(undef);
 132 }
 133
 134 sub _send_to_log {
 135     my $self = shift;
 136     if ($self->can('_has_psgi_errors') and $self->_has_psgi_errors) {
 137         $self->_psgi_errors->print(@_);
 138     } else {
 139         print STDERR @_;
 140     }
 141 }
 142
 143 # 5.7 compat code.
 144 # Alias _body to body, add a before modifier to warn..
 145 my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 146 $meta->add_method('body', $meta->get_method('_body'));
 147 my %package_hash; # Only warn once per method, per package.
 148                   # I haven't provided a way to disable them, patches welcome.
 149 $meta->add_before_method_modifier('body', sub {
 150     my $class = blessed(shift);
 151     $package_hash{$class}++ || do {
 152         warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n"
 153             . "this will be removed in Catalyst 5.81");
 154     };
 155 });
 156 # End 5.70 backwards compatibility hacks.
 157
 158 no Moose;
 159 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 160
 161 1;
 162
 163 __END__
 164
 165 =for stopwords psgienv
 166
 167 =head1 NAME
 168
 169 Catalyst::Log - Catalyst Log Class
 170
 171 =head1 SYNOPSIS
 172
 173     $log = $c->log;
 174     $log->debug($message);
 175     $log->info($message);
 176     $log->warn($message);
 177     $log->error($message);
 178     $log->fatal($message);
 179
 180     if ( $log->is_debug ) {
 181          # expensive debugging
 182     }
 183
 184
 185 See L<Catalyst>.
 186
 187 =head1 DESCRIPTION
 188
 189 This module provides the default, simple logging functionality for Catalyst.
 190 If you want something different set C<< $c->log >> in your application module,
 191 e.g.:
 192
 193     $c->log( MyLogger->new );
 194
 195 Your logging object is expected to provide the interface described here.
 196 Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
 197
 198 If you want to be able to log arbitrary warnings, you can do something along
 199 the lines of
 200
 201     $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
 202
 203 however this is (a) global, (b) hairy and (c) may have unexpected side effects.
 204 Don't say we didn't warn you.
 205
 206 =head1 LOG LEVELS
 207
 208 =head2 debug
 209
 210     $log->is_debug;
 211     $log->debug($message);
 212
 213 =head2 info
 214
 215     $log->is_info;
 216     $log->info($message);
 217
 218 =head2 warn
 219
 220     $log->is_warn;
 221     $log->warn($message);
 222
 223 =head2 error
 224
 225     $log->is_error;
 226     $log->error($message);
 227
 228 =head2 fatal
 229
 230     $log->is_fatal;
 231     $log->fatal($message);
 232
 233 =head1 METHODS
 234
 235 =head2 new
 236
 237 Constructor. Defaults to enable all levels unless levels are provided in
 238 arguments.
 239
 240     $log = Catalyst::Log->new;
 241     $log = Catalyst::Log->new( 'warn', 'error' );
 242
 243 =head2 level
 244
 245 Contains a bitmask of the currently set log levels.
 246
 247 =head2 levels
 248
 249 Set log levels
 250
 251     $log->levels( 'warn', 'error', 'fatal' );
 252
 253 =head2 enable
 254
 255 Enable log levels
 256
 257     $log->enable( 'warn', 'error' );
 258
 259 =head2 disable
 260
 261 Disable log levels
 262
 263     $log->disable( 'warn', 'error' );
 264
 265 =head2 is_debug
 266
 267 =head2 is_error
 268
 269 =head2 is_fatal
 270
 271 =head2 is_info
 272
 273 =head2 is_warn
 274
 275 Is the log level active?
 276
 277 =head2 abort
 278
 279 Should Catalyst emit logs for this request? Will be reset at the end of
 280 each request.
 281
 282 *NOTE* This method is not compatible with other log apis, so if you plan
 283 to use Log4Perl or another logger, you should call it like this:
 284
 285     $c->log->abort(1) if $c->log->can('abort');
 286
 287 =head2 _send_to_log
 288
 289  $log->_send_to_log( @messages );
 290
 291 This protected method is what actually sends the log information to STDERR.
 292 You may subclass this module and override this method to get finer control
 293 over the log output.
 294
 295 =head2 psgienv $env
 296
 297     $log->psgienv($env);
 298
 299 NOTE: This is not meant for public consumption.
 300
 301 Set the PSGI environment for this request. This ensures logs will be sent to
 302 the right place. If the environment has a C<psgix.logger>, it will be used. If
 303 not, we will send logs to C<psgi.errors> if that exists. As a last fallback, we
 304 will send to STDERR as before.
 305
 306 =head2 clear_psgi
 307
 308 Clears the PSGI environment attributes set by L</psgienv>.
 309
 310 =head2 meta
 311
 312 =head1 SEE ALSO
 313
 314 L<Catalyst>.
 315
 316 =head1 AUTHORS
 317
 318 Catalyst Contributors, see Catalyst.pm
 319
 320 =head1 COPYRIGHT
 321
 322 This library is free software. You can redistribute it and/or modify
 323 it under the same terms as Perl itself.
 324
 325 =cut
 326
 327 __PACKAGE__->meta->make_immutable;
 328
 329 1;