File Coverage

lib/Badger/Log.pm

Criterion	Covered	Total	%
statement	43	45	95.5
branch	23	26	88.4
condition	2	3	66.6
subroutine	11	12	91.6
pod	5	6	83.3
total	84	92	91.3

#========================================================================
#
# Badger::Log
#
# DESCRIPTION
#   A simple base class logging module.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Log;

use Badger::Class
    version   => 0.01,
    base      => 'Badger::Prototype',
    import    => 'class',
    utils     => 'blessed Now',
    config    => 'system|class:SYSTEM format|class:FORMAT strftime|class:STRFTIME',
    constants => 'ARRAY CODE',
    constant  => {
        MSG   => '_msg',        # suffix for message methods, e.g. warn_msg()
        LOG   => 'log',         # method a delegate must implement
    },
    vars      => {
        SYSTEM   => 'Badger',
        FORMAT   => '[] [] [] ',
        STRFTIME => '%a %b %d %T %Y',
        LEVELS => {
            debug => 0,
            info  => 0,
            warn  => 1,
            error => 1,
            fatal => 1,
        }
    },
    messages  => {
        bad_level => 'Invalid logging level: %s',
    };



class->methods(
    # Our init method is called init_log() so that we can use Badger::Log as
    # a mixin or base class without worrying about the init() method clashing
    # with init() methods from other base classes or mixins.  We create an
    # alias from init() to init_log() so that it also Just Works[tm] as a
    # stand-alone object
    init   => \&init_log,

    # Now we define two methods for each logging level.  The first expects
    # a pre-formatted output message (e.g. debug(), info(), warn(), etc)
    # the second additionally wraps around the message() method inherited
    # from Badger::Base (eg. debug_msg(), info_msg(), warn_msg(), etc)
    map {
        my $level = $_;             # lexical variable for closure

        $level => sub {
            my $self = shift;
            return $self->{ $level } unless @_;
            $self->log($level, @_)
                if $self->{ $level };
        },

        ($level.MSG) => sub {
            my $self = shift;
            return $self->{ $level } unless @_;
            $self->log($level, $self->message(@_))
                if $self->{ $level };
        }
    }
    keys %$LEVELS
);


sub init_log {
    my ($self, $config) = @_;
    my $class  = $self->class;
    my $levels = $class->hash_vars( LEVELS => $config->{ levels } );

    # populate $self for each level in $LEVEL using the
    # value in $config, or the default in $LEVEL
    while (my ($level, $default) = each %$levels) {
        $self->{ $level } =
            defined $config->{ $level }
                ? $config->{ $level }
                : $levels->{ $level };
    }

    # call the auto-generated configure() method to update $self from $config
    $self->configure($config);

    return $self;
}

sub log {
    my $self    = shift;
    my $level   = shift;
    my $action  = $self->{ $level };
    my $message = join('', @_);
    my $method;

    return $self->_fatal_msg( bad_level => $level )
        unless defined $action;

    # depending on what the $action is set to, we add the message to
    # an array, call a code reference, delegate to another log object,
    # print or ignore the mesage

    if (ref $action eq ARRAY) {
        push(@$action, $message);
    }
    elsif (ref $action eq CODE) {
        &$action($level, $message);
    }
    elsif (blessed $action && ($method = $action->can(LOG))) {
        $method->($action, $level, $message);
    }
    elsif ($action) {
        warn $self->format($level, $message), "\n";
    }
}

sub format {
    my $self = shift;
    my $args = {
        time    => Now->format($self->{ strftime }),
        system  => $self->{ system },
        level   => shift,
        message => shift,
    };
    my $format = $self->{ format };
    $format =~
        s/<(\w+)>/
            defined $args->{ $1 }
                ? $args->{ $1 }
                : "<$1>"
        /eg;
    return $format;
}

sub level {
    my $self  = shift;
    my $level = shift;
    return $self->_fatal_msg( bad_level => $level )
        unless exists $LEVELS->{ $level };
    return @_ ? ($self->{ $level } = shift) : $self->{ $level };
}

sub enable {
    my $self = shift;
    $self->level($_ => 1) for @_;
}

sub disable {
    my $self = shift;
    $self->level($_ => 0) for @_;
}

sub _error_msg {
    my $self = shift;
    $self->Badger::Base::error(
        $self->Badger::Base::message(@_)
    );
}

sub _fatal_msg {
    my $self = shift;
    $self->Badger::Base::fatal(
        $self->Badger::Base::message(@_)
    );
}


1;

__END__