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