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 psgienv => (is => 'rw', predicate => 'has_psgienv', clearer => 'clear_psgienv');
  17
  18 {
  19     my @levels = qw[ debug info warn error fatal ];
  20
  21     my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__);
  22     my $summed_level = 0;
  23     for ( my $i = $#levels ; $i >= 0 ; $i-- ) {
  24
  25         my $name  = $levels[$i];
  26
  27         my $level = 1 << $i;
  28         $summed_level |= $level;
  29
  30         $LEVELS{$name} = $level;
  31         $LEVEL_MATCH{$name} = $summed_level;
  32
  33        $meta->add_method($name, sub {
  34             my $self = shift;
  35
  36             if ( $self->level & $level ) {
  37                 $self->_log( $name, @_ );
  38             }
  39         });
  40
  41         $meta->add_method("is_$name", sub {
  42             my $self = shift;
  43             return $self->level & $level;
  44         });;
  45     }
  46 }
  47
  48 around new => sub {
  49     my $orig = shift;
  50     my $class = shift;
  51     my $self = $class->$orig;
  52
  53     $self->levels( scalar(@_) ? @_ : keys %LEVELS );
  54
  55     return $self;
  56 };
  57
  58 sub levels {
  59     my ( $self, @levels ) = @_;
  60     $self->level(0);
  61     $self->enable(@levels);
  62 }
  63
  64 sub enable {
  65     my ( $self, @levels ) = @_;
  66     my $level = $self->level;
  67     for(map { $LEVEL_MATCH{$_} } @levels){
  68       $level |= $_;
  69     }
  70     $self->level($level);
  71 }
  72
  73 sub disable {
  74     my ( $self, @levels ) = @_;
  75     my $level = $self->level;
  76     for(map { $LEVELS{$_} } @levels){
  77       $level &= ~$_;
  78     }
  79     $self->level($level);
  80 }
  81
  82 our $HAS_DUMPED;
  83 sub _dump {
  84     my $self = shift;
  85     unless ($HAS_DUMPED++) {
  86         cluck("Catalyst::Log::_dump is deprecated and will be removed. Please change to using your own Dumper.\n");
  87     }
  88     $self->info( Data::Dump::dump(@_) );
  89 }
  90
  91 sub _log {
  92     my $self    = shift;
  93     my $level   = shift;
  94     my $message = join( "\n", @_ );
  95     if ($self->can('has_psgienv') and $self->has_psgienv and $self->psgienv->{'psgix.logger'}) {
  96         $self->psgienv->{'psgix.logger'}->({
  97                 level => $level,
  98                 message => $message,
  99             });
 100     } else {
 101         $message .= "\n" unless $message =~ /\n$/;
 102         my $body = $self->_body;
 103         $body .= sprintf( "[%s] %s", $level, $message );
 104         $self->_body($body);
 105     }
 106 }
 107
 108 sub _flush {
 109     my $self = shift;
 110     if ( $self->abort || !$self->_body ) {
 111         $self->abort(undef);
 112     }
 113     else {
 114         $self->_send_to_log( $self->_body );
 115     }
 116     $self->_body(undef);
 117 }
 118
 119 sub _send_to_log {
 120     my $self = shift;
 121     if ($self->can('has_psgienv') and $self->has_psgienv) {
 122         $self->psgienv->{'psgi.errors'}->print(@_);
 123     } else {
 124         print STDERR @_;
 125     }
 126 }
 127
 128 # 5.7 compat code.
 129 # Alias _body to body, add a before modifier to warn..
 130 my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 131 $meta->add_method('body', $meta->get_method('_body'));
 132 my %package_hash; # Only warn once per method, per package.
 133                   # I haven't provided a way to disable them, patches welcome.
 134 $meta->add_before_method_modifier('body', sub {
 135     my $class = blessed(shift);
 136     $package_hash{$class}++ || do {
 137         warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n"
 138             . "this will be removed in Catalyst 5.81");
 139     };
 140 });
 141 # End 5.70 backwards compatibility hacks.
 142
 143 no Moose;
 144 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 145
 146 1;
 147
 148 __END__
 149
 150 =head1 NAME
 151
 152 Catalyst::Log - Catalyst Log Class
 153
 154 =head1 SYNOPSIS
 155
 156     $log = $c->log;
 157     $log->debug($message);
 158     $log->info($message);
 159     $log->warn($message);
 160     $log->error($message);
 161     $log->fatal($message);
 162
 163     if ( $log->is_debug ) {
 164          # expensive debugging
 165     }
 166
 167
 168 See L<Catalyst>.
 169
 170 =head1 DESCRIPTION
 171
 172 This module provides the default, simple logging functionality for Catalyst.
 173 If you want something different set C<< $c->log >> in your application module,
 174 e.g.:
 175
 176     $c->log( MyLogger->new );
 177
 178 Your logging object is expected to provide the interface described here.
 179 Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
 180
 181 If you want to be able to log arbitrary warnings, you can do something along
 182 the lines of
 183
 184     $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
 185
 186 however this is (a) global, (b) hairy and (c) may have unexpected side effects.
 187 Don't say we didn't warn you.
 188
 189 =head1 LOG LEVELS
 190
 191 =head2 debug
 192
 193     $log->is_debug;
 194     $log->debug($message);
 195
 196 =head2 info
 197
 198     $log->is_info;
 199     $log->info($message);
 200
 201 =head2 warn
 202
 203     $log->is_warn;
 204     $log->warn($message);
 205
 206 =head2 error
 207
 208     $log->is_error;
 209     $log->error($message);
 210
 211 =head2 fatal
 212
 213     $log->is_fatal;
 214     $log->fatal($message);
 215
 216 =head1 METHODS
 217
 218 =head2 new
 219
 220 Constructor. Defaults to enable all levels unless levels are provided in
 221 arguments.
 222
 223     $log = Catalyst::Log->new;
 224     $log = Catalyst::Log->new( 'warn', 'error' );
 225
 226 =head2 level
 227
 228 Contains a bitmask of the currently set log levels.
 229
 230 =head2 levels
 231
 232 Set log levels
 233
 234     $log->levels( 'warn', 'error', 'fatal' );
 235
 236 =head2 enable
 237
 238 Enable log levels
 239
 240     $log->enable( 'warn', 'error' );
 241
 242 =head2 disable
 243
 244 Disable log levels
 245
 246     $log->disable( 'warn', 'error' );
 247
 248 =head2 is_debug
 249
 250 =head2 is_error
 251
 252 =head2 is_fatal
 253
 254 =head2 is_info
 255
 256 =head2 is_warn
 257
 258 Is the log level active?
 259
 260 =head2 abort
 261
 262 Should Catalyst emit logs for this request? Will be reset at the end of
 263 each request.
 264
 265 *NOTE* This method is not compatible with other log apis, so if you plan
 266 to use Log4Perl or another logger, you should call it like this:
 267
 268     $c->log->abort(1) if $c->log->can('abort');
 269
 270 =head2 _send_to_log
 271
 272  $log->_send_to_log( @messages );
 273
 274 This protected method is what actually sends the log information to STDERR.
 275 You may subclass this module and override this method to get finer control
 276 over the log output.
 277
 278 =head2 meta
 279
 280 =head1 SEE ALSO
 281
 282 L<Catalyst>.
 283
 284 =head1 AUTHORS
 285
 286 Catalyst Contributors, see Catalyst.pm
 287
 288 =head1 COPYRIGHT
 289
 290 This library is free software. You can redistribute it and/or modify
 291 it under the same terms as Perl itself.
 292
 293 =cut
 294
 295 __PACKAGE__->meta->make_immutable;
 296
 297 1;