lib/Catalyst/Log.pm

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