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 # 5.7 compat code.
 105 # Alias _body to body, add a before modifier to warn..
 106 my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
 107 $meta->add_method('body', $meta->get_method('_body'));
 108 my %package_hash; # Only warn once per method, per package.
 109                   # I haven't provided a way to disable them, patches welcome.
 110 $meta->add_before_method_modifier('body', sub {
 111     my $class = blessed(shift);
 112     $package_hash{$class}++ || do {
 113         warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n"
 114             . "this will be removed in Catalyst 5.81");
 115     };
 116 });
 117 # End 5.70 backwards compatibility hacks.
 118
 119 no Moose;
 120 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 121
 122 1;
 123
 124 __END__
 125
 126 =head1 NAME
 127
 128 Catalyst::Log - Catalyst Log Class
 129
 130 =head1 SYNOPSIS
 131
 132     $log = $c->log;
 133     $log->debug($message);
 134     $log->info($message);
 135     $log->warn($message);
 136     $log->error($message);
 137     $log->fatal($message);
 138
 139     if ( $log->is_debug ) {
 140          # expensive debugging
 141     }
 142
 143
 144 See L<Catalyst>.
 145
 146 =head1 DESCRIPTION
 147
 148 This module provides the default, simple logging functionality for Catalyst.
 149 If you want something different set C<< $c->log >> in your application module,
 150 e.g.:
 151
 152     $c->log( MyLogger->new );
 153
 154 Your logging object is expected to provide the interface described here.
 155 Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
 156
 157 If you want to be able to log arbitrary warnings, you can do something along
 158 the lines of
 159
 160     $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
 161
 162 however this is (a) global, (b) hairy and (c) may have unexpected side effects.
 163 Don't say we didn't warn you.
 164
 165 =head1 LOG LEVELS
 166
 167 =head2 debug
 168
 169     $log->is_debug;
 170     $log->debug($message);
 171
 172 =head2 info
 173
 174     $log->is_info;
 175     $log->info($message);
 176
 177 =head2 warn
 178
 179     $log->is_warn;
 180     $log->warn($message);
 181
 182 =head2 error
 183
 184     $log->is_error;
 185     $log->error($message);
 186
 187 =head2 fatal
 188
 189     $log->is_fatal;
 190     $log->fatal($message);
 191
 192 =head1 METHODS
 193
 194 =head2 new
 195
 196 Constructor. Defaults to enable all levels unless levels are provided in
 197 arguments.
 198
 199     $log = Catalyst::Log->new;
 200     $log = Catalyst::Log->new( 'warn', 'error' );
 201
 202 =head2 level
 203
 204 Contains a bitmask of the currently set log levels.
 205
 206 =head2 levels
 207
 208 Set log levels
 209
 210     $log->levels( 'warn', 'error', 'fatal' );
 211
 212 =head2 enable
 213
 214 Enable log levels
 215
 216     $log->enable( 'warn', 'error' );
 217
 218 =head2 disable
 219
 220 Disable log levels
 221
 222     $log->disable( 'warn', 'error' );
 223
 224 =head2 is_debug
 225
 226 =head2 is_error
 227
 228 =head2 is_fatal
 229
 230 =head2 is_info
 231
 232 =head2 is_warn
 233
 234 Is the log level active?
 235
 236 =head2 abort
 237
 238 Should Catalyst emit logs for this request? Will be reset at the end of
 239 each request.
 240
 241 *NOTE* This method is not compatible with other log apis, so if you plan
 242 to use Log4Perl or another logger, you should call it like this:
 243
 244     $c->log->abort(1) if $c->log->can('abort');
 245
 246 =head2 _send_to_log
 247
 248  $log->_send_to_log( @messages );
 249
 250 This protected method is what actually sends the log information to STDERR.
 251 You may subclass this module and override this method to get finer control
 252 over the log output.
 253
 254 =head2 meta
 255
 256 =head1 SEE ALSO
 257
 258 L<Catalyst>.
 259
 260 =head1 AUTHORS
 261
 262 Catalyst Contributors, see Catalyst.pm
 263
 264 =head1 COPYRIGHT
 265
 266 This program is free software, you can redistribute it and/or modify
 267 it under the same terms as Perl itself.
 268
 269 =cut
 270
 271 __PACKAGE__->meta->make_immutable;
 272
 273 1;