File Coverage

blib/lib/Log/Minimal/Instance.pm

Criterion	Covered	Total	%
statement	73	73	100.0
branch	45	58	77.5
condition	4	6	66.6
subroutine	13	13	100.0
pod	2	2	100.0
total	137	152	90.1

package Log::Minimal::Instance;

use strict;
use warnings;
use parent 'Log::Minimal';
use File::Stamped;
use File::Spec;

our $VERSION = '0.06';

BEGIN {
    # for object methods
    for my $level (qw/crit warn info debug croak/) {
        for my $suffix (qw/f ff d/) {
            my $method = $level.$suffix;

            my $parent_code = Log::Minimal->can( ($suffix eq 'd') ? $level."f" : $method );

            no strict 'refs';
            my $code = sub {
                my $self = shift;
                local $Log::Minimal::TRACE_LEVEL = ($Log::Minimal::TRACE_LEVEL||0) + 1;
                local $Log::Minimal::LOG_LEVEL   = $self->{level};
                local $Log::Minimal::PRINT       = $self->{_print};
                $parent_code->( ($suffix eq 'd') ? Log::Minimal::ddf(@_) : @_ );
            };
            *{$method} = $code;
        }
    }
}

sub new {
    my ($class, %args) = @_;

    my $pattern           = exists $args{pattern}           ? $args{pattern}           : undef;
    my $symlink           = exists $args{symlink}           ? $args{symlink}           : undef;
    my $base_dir          = exists $args{base_dir}          ? $args{base_dir}          : '.';
    my $iomode            = exists $args{iomode}            ? $args{iomode}            : '>>:utf8';
    my $rotationtime      = exists $args{rotationtime}      ? $args{rotationtime}      : 1;
    my $autoflush         = exists $args{autoflush}         ? $args{autoflush}         : 1;
    my $close_after_write = exists $args{close_after_write} ? $args{close_after_write} : 1;
    my $auto_make_dir     = exists $args{auto_make_dir}     ? $args{auto_make_dir}     : 0;
    my $callback          = exists $args{callback}          ? $args{callback}          : undef;

    my $fh;
    if ($pattern) {
        $pattern = $class->_build_pattern($base_dir, $pattern);
        $symlink = $class->_build_pattern($base_dir, $symlink);
        $fh = File::Stamped->new(
            defined $pattern  ? (pattern  => $pattern)  : (),
            defined $callback ? (callback => $callback) : (),
            defined $symlink  ? (symlink  => $symlink)  : (),
            iomode            => $iomode,
            autoflush         => $autoflush,
            close_after_write => $close_after_write,
            rotationtime      => $rotationtime,
        );
    }
    else {
        $fh = *STDERR;
    }

    bless {
        level             => $args{level} || 'DEBUG',
        base_dir          => $base_dir,
        iomode            => $iomode,
        rotationtime      => $rotationtime,
        autoflush         => $autoflush,
        close_after_write => $close_after_write,
        auto_make_dir     => $auto_make_dir,

        _fh    => $fh,
        _print => sub {
            my ($time, $type, $message, $trace) = @_;
            print {$fh}  "$time [$type] $message at $trace\n"
        },
    }, $class;
}

sub log_to {
    my ($self, $opts, @args) = @_;

    if (ref $opts eq 'ARRAY') {
        $opts = {
            pattern => $opts->[0],
            symlink => $opts->[1],
        };
    }
    elsif (!ref $opts) {
        $opts = { pattern => $opts };
    }

    my ($pattern, $symlink, $callback);
    my $base_dir = defined $opts->{base_dir} ? $opts->{base_dir} : $self->{base_dir};
    $pattern  = $self->_build_pattern($base_dir, $opts->{pattern});
    $symlink  = $self->_build_pattern($base_dir, $opts->{symlink});
    $callback = exists $opts->{callback} ? $opts->{callback} : undef;

    my $fh = File::Stamped->new(
        defined $pattern  ? (pattern  => $pattern)  : (),
        defined $callback ? (callback => $callback) : (),
        defined $symlink  ? (symlink  => $symlink)  : (),
        iomode            => defined $opts->{iomode}            ? $opts->{iomode}            : $self->{iomode},
        autoflush         => defined $opts->{autoflush}         ? $opts->{autoflush}         : $self->{autoflush},
        close_after_write => defined $opts->{close_after_write} ? $opts->{close_after_write} : $self->{close_after_write},
        rotationtime      => defined $opts->{rotationtime}      ? $opts->{rotationtime}      : $self->{rotationtime},
        auto_make_dir     => defined $opts->{auto_make_dir}     ? $opts->{auto_make_dir}     : $self->{auto_make_dir},
    );

    local $self->{_fh}    = $fh;
    local $self->{_print} = sub {
        my ($time, $type, $message, $trace) = @_;
        print {$fh} "$time $message at $trace\n";
    };

    local $Log::Minimal::TRACE_LEVEL = ($Log::Minimal::TRACE_LEVEL||0) + 1;
    local $Log::Minimal::LOG_LEVEL   = 'DEBUG'; # Must be logging!
    $self->critf(@args);
}

sub _build_pattern {
    my ($self, $base_dir, $pattern) = @_;
    return unless defined $pattern;

    unless (File::Spec->file_name_is_absolute($pattern)) {
        $pattern = File::Spec->catfile($base_dir, $pattern);
    }
    return $pattern;
}

1;

__END__