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