[僕] Log::Dispatch で Colorful!

僕ト云フ事

たろマークはてなブックマーク

2008年11月19日

[colorful][log][perl] Log::Dispatch で Colorful!

追記

CodeRepos にコミットして CPAN うpしましたー。
$default_color 無くしたので、color 指定しなければただの Dumper な Screen として使えると思います。

本文

Catalyst::Plugin::Log::Colorful を使って以来、開発中は Colorful な log じゃないと Debug モードの気がしなくなってしまった自分ですが、ちょっと、Log::Dispatch で Colorful な Dumper してみたくなったのでやってみました。

log-colorful.png

Log::Dispatch をよくわかってなくてきっとおかしな事をしていると思う。
message 周りの callback で一番最初に処理してほしいから頭に割り込んでみたり、Dumper したくて log メソッドの validate 外したり。

test_log.pl

Log::Dispatch::Config から使ってます。

use strict;
use warnings;
 
use lib qw(./lib);
 
use Data::Dumper;
use Log::Dispatch::Config;
use Log::Dispatch::Configurator::YAML;
 
my $config = Log::Dispatch::Configurator::YAML->new('log.yaml');
Log::Dispatch::Config->configure($config);
 
my $log = Log::Dispatch::Config->instance();
 
$log->notice('noooooootiiiiiiiiiceeeeeeeeeee');
$log->info('infoooooooooooooooooooooooo');
$log->error('eeeeeerrrrrrrrrrrrrrooorrrrrr');
$log->debug('deeeeeeeeebuuuuuuuuuuuuuug!');
$log->debug({
    foo => 'bar',
});

log.yaml

log.yaml はこんな感じ。

dispatchers:
  - screen
 
screen:
  class: Log::Dispatch::Colorful
  min_level: debug
  stderr: 1
  format: '[%d] [%p] %m at %F line %L%n'
  color:
    info:
      text: green
    debug:
      text: red
      background: white
    error:
      text: yellow
      background: red

Log::Dispatch::Colorful

これがその Colorful さん。

package Log::Dispatch::Colorful;
 
use strict;
use warnings;
 
use base qw( Log::Dispatch::Output );
 
use Data::Dumper;
use Log::Dispatch::Output;
use Params::Validate qw(validate BOOLEAN SCALAR ARRAYREF CODEREF);
use Term::ANSIColor;
 
Params::Validate::validation_options( allow_extra => 1 );
 
our $VERSION = '0.01';
 
our %LEVELS;
 
BEGIN {
    foreach my $l (qw( debug info notice warning err error crit critical alert emerg emergency )) {
        my $sub = sub {
            my $self = shift;
            my $messages;
            foreach my $message (@_) {
                if ( ref $message ) {
                    $message = Dumper($message);
                }
                $messages .= $message || '';
            }
 
            $self->log( level => $l, message => $messages );
        };
 
        $LEVELS{$l} = 1;
 
        no strict 'refs';
        no warnings 'redefine';
        *{ "Log::Dispatch::" . $l } = $sub;
    }
}
 
sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
 
    my %p = validate(
        @_,
        {   stderr => {
                type    => BOOLEAN,
                default => 1
            },
        }
    );
 
    my $self = bless {}, $class;
 
    $self->_basic_init(%p);
 
    my $default_color = {
        error => {
            text       => 'yellow',
            background => 'red'
        },
        debug => { text => 'red' },
    };
 
    $self->{color}  = exists $p{color}  ? $p{color}  : $default_color;
    $self->{stderr} = exists $p{stderr} ? $p{stderr} : 1;
 
    my $callbacks = [
        sub {
            my %p = @_;
 
            if  ( $self->{color}->{ $p{level} }->{text} ) {
                $p{message}
                    = color( $self->{color}->{ $p{level} }->{text} )
                    . $p{message}
                    . color('reset');
            }
 
            if ( $self->{color}->{ $p{level} }->{background} ) {
                $p{message}
                    = color( 'on_' . $self->{color}->{ $p{level} }->{background} )
                    . $p{message}
                    . color('reset');
            }
 
            $p{message};
        },
        @{ $self->{callbacks} }
    ];
    $self->{callbacks} = $callbacks;
 
    return $self;
}
 
sub log {
    my $self = shift;
 
    my %p = validate( @_, { level => { type => SCALAR }, } );
 
    return unless $self->_should_log( $p{level} );
 
    $p{message} = $self->_apply_callbacks(%p)
        if $self->{callbacks};
 
    $self->log_message(%p);
}
 
sub log_message {
    my $self = shift;
    my %p    = @_;
 
    if ( $self->{stderr} ) {
        print STDERR $p{message};
    }
    else {
        print STDOUT $p{message};
    }
}
 
1;

Dumper できるの便利だけど、リファレンス渡すと他の Log クラスに Dispatch しづらくなるなぁ。

トラックバック

このエントリーのトラックバックURL:
http://vkgtaro.jp/cgi-bin/mt/mt-tb.cgi/644

コメントを投稿