lib/Catalyst/Log.pm

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