lib/Catalyst/Log.pm

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