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