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