File Coverage

blib/lib/Log/Facile.pm

Criterion	Covered	Total	%
statement	117	124	94.3
branch	55	68	80.8
condition	19	27	70.3
subroutine	18	18	100.0
pod	9	9	100.0
total	218	246	88.6

package Log::Facile;

use strict;

use vars qw($VERSION $TEMPLATE);
our $VERSION = '1.03';
our $TEMPLATE = 'template';

use Carp;

# log template config
my @tmpl_accessor = ('TEMPLATE', 'DATE', 'LEVEL', 'MESSAGE',);

# available accessor list
my @accessor = (
                'log_file',   'level_debug', 'level_info', 'level_error',
                'level_warn', 'level_fatal', 'swap_dir',   'date_format',
                'debug_flag', $TEMPLATE,
               );

# constructor
sub new
{
    my ($class, $log_file, $swap_dir) = @_;

    bless {
           log_file       => $log_file,
           swap_dir       => $swap_dir,
           date_format    => 'yyyy/mm/dd hh:mi:ss',
           $TEMPLATE => {
                              'TEMPLATE' => 'DATE [LEVEL] MESSAGE',
                              'DATE'     => undef,
                              'LEVEL'    => undef,
                              'MESSAGE'  => undef,
                             },
          }, $class;
}

# getter
sub get
{
    my ($self, $key, $tmpl_key) = @_;

    if (_is_tmpl_accessor($key, $tmpl_key) == 1)
    {
        # log template value
        return $self->{$TEMPLATE}->{$tmpl_key};
    }
    elsif (_is_tmpl_accessor($key, $tmpl_key) == 2)
    {
        # new template value
        return $self->{$TEMPLATE};
    }
    elsif (_is_valid_accessor($key))
    {
        # get field
        return $self->{$key};
    }
    else
    {
        # error
        return 0;
    }
}

# setter
sub set
{
    my ($self, $key, $value_or_key, $tmpl_value) = @_;

    if (_is_tmpl_accessor($key, $value_or_key) == 1)
    {
        $self->{$TEMPLATE}->{$value_or_key} = $tmpl_value;
    }
    elsif (_is_tmpl_accessor($key, $value_or_key) == 2)
    {
        push @tmpl_accessor, $value_or_key;
        $self->{$TEMPLATE}->{$value_or_key} = $tmpl_value;
    }
    elsif (_is_tmpl_accessor($key, $value_or_key) == 255)
    {
        return 0;
    }
    elsif (_is_valid_accessor($key))
    {
        $self->{$key} = $value_or_key;
    }
    else
    {
        return 0;
    }
    return $self;
}

# tmpl accessor check
sub _is_tmpl_accessor
{
    my ($tmpl_key, $key) = @_;

    my $enable = 0;
    if (defined $tmpl_key && $tmpl_key eq $TEMPLATE)
    {
        $enable = 2;
        for my $each (@tmpl_accessor)
        {
            if (defined $key && $each eq $key)
            {
                $enable = 1;
                last;
            }
            elsif (defined $key
                   && ($each =~ m/$key/ || $key =~ m/$each/))
            {
                croak "Can't use '"
                  . $key
                  . "' to template "
                  . "because '"
                  . $each
                  . "' has already used.";
                $enable = 255;
            }
        }
    }
    return $enable;
}

# accessor check
sub _is_valid_accessor
{
    my $key = shift;

    my $enable = 0;
    for my $each (@accessor)
    {
        if (defined $key && $key eq $each)
        {
            $enable = 1;
            last;
        }
    }
    croak 'invalid field name :-P - ' . $key if !$enable;
    return $enable;
}

# replace log item
sub _replace_log_item
{
    my ($self, $key, $value) = @_;

    # get defined object
    if ( defined $key
        && _is_tmpl_accessor($TEMPLATE, $key) == 1
        && defined $self->get($TEMPLATE)->{$key})
    {
        return $self->get($TEMPLATE)->{$key};
    }
    elsif (   defined $key
           && $key eq 'DATE'
           && !defined $self->get($TEMPLATE)->{'DATE'})
    {

        # get date default sub
        return $self->_current_date();
    }
    else
    {

        # return accepted value
        return $value;
    }
}

# get log output string
sub _get_log_str
{
    my ($self, $date, $level, $message) = @_;

    # template hash
    my $t_hash = $self->get($TEMPLATE);

    # log template string
    my $log_str = $t_hash->{'TEMPLATE'};

    # default values
    $log_str =~ s/DATE/$date/g;
    $log_str =~ s/LEVEL/$level/g;
    $log_str =~ s/MESSAGE/$message/g;

    # user defined values
    for my $key (@tmpl_accessor)
    {
        my $replace = $self->_replace_log_item($key);
        $log_str =~ s/$key/$replace/g;
    }
    return $log_str;
}

# log writer
sub _write
{
    my ($self, $p_level, $p_message) = @_;

    # default values
    my $date    = $self->_replace_log_item('DATE');
    my $level   = $self->_replace_log_item('LEVEL', $p_level);
    my $message = $self->_replace_log_item('MESSAGE', $p_message);

    # log string
    my $log_str = $self->_get_log_str($date, $level, $message) . $/;

    # execute writing log file
    open my $log, ">> " . $self->get('log_file')
      or croak 'log file open error - ' . $!;
    print $log $log_str;
    close $log
      or croak 'log file close error - ' . $!;
}

sub debug
{
    my ($self, $message_str) = @_;
    if ($self->get('debug_flag'))
    {
        my $level =
          defined $self->get('level_debug')
          ? $self->get('level_debug')
          : 'DEBUG';
        return $self->_write($level, $message_str);
    }
    else
    {
        return 1;
    }
}

sub info
{
    my ($self, $message_str) = @_;
    my $level =
      defined $self->get('level_info')
      ? $self->get('level_info')
      : 'INFO';
    return $self->_write($level, $message_str);
}

sub error
{
    my ($self, $message_str) = @_;
    my $level =
      defined $self->get('level_error')
      ? $self->get('level_error')
      : 'ERROR';
    return $self->_write($level, $message_str);
}

sub warn
{
    my ($self, $message_str) = @_;
    my $level =
      defined $self->get('level_warn')
      ? $self->get('level_warn')
      : 'WARN';
    return $self->_write($level, $message_str);
}

sub fatal
{
    my ($self, $message_str) = @_;
    my $level =
      defined $self->get('level_fatal')
      ? $self->get('level_fatal')
      : 'FATAL';
    return $self->_write($level, $message_str);
}

sub swap
{
    my ($self, $swap_dir) = @_;

    # set swap dir
    if (defined $swap_dir)
    {
        $self->set('swap_dir', $swap_dir);
    }
    elsif (!defined $self->get('swap_dir'))
    {
        my $log_dir = $self->get('log_file');
        $log_dir =~ s/(.+\/).+$/$1/;
        $self->set('swap_dir', $log_dir);
    }

    # get log filename prefix
    my $file_pref = $self->get('log_file');
    $file_pref =~ s/.+\/(.+?)$/$1/;

    # move current log file
    if (!-d $self->get('swap_dir'))
    {
        mkdir $self->get('swap_dir')
          or croak 'create swap dir error - ' . $!;
    }
    if (-f $self->get('log_file'))
    {
        rename $self->get('log_file'), $self->get('swap_dir') . '/' . $file_pref
          or croak 'current file move error - ' . $!;
    }
    else
    {
        return 1;
    }

    # rename files
    opendir my $s_dir, $self->get('swap_dir')
      or croak 'dir open error - ' . $!;

    for my $each (grep /$file_pref/, reverse sort readdir $s_dir)
    {
        $each = $self->get('swap_dir') . '/' . $each;
        my $rename_pref = $self->get('swap_dir') . '/' . $file_pref . '.';
        if ($each =~ /\.(\d)$/)
        {
            rename $each, $rename_pref . ($1 + 1)
              or croak 'rename error (' . $rename_pref . ($1 + 1) . ') - ' . $!;
        }
        else
        {
            rename $each, $rename_pref . '1'
              or croak 'rename error (' . $rename_pref . '.1) - ' . $!;
        }
    }
    closedir $s_dir
      or croak 'dir close error - ' . $!;
}

# get current datetime
sub _current_date
{
    my ($self, $pat) = @_;

    # datetime values
    my @da    = localtime(time);
    my $year4 = sprintf("%04d", $da[5] + 1900);
    my $year2 = sprintf("%02d", $da[5] + 1900 - 2000);
    my $month = sprintf("%02d", $da[4] + 1);
    my $day   = sprintf("%02d", $da[3]);
    my $hour  = sprintf("%02d", $da[2]);
    my $min   = sprintf("%02d", $da[1]);
    my $sec   = sprintf("%02d", $da[0]);

    # date format
    my $date_str =
      (defined $self->get('date_format'))
      ? $self->get('date_format')
      : 'yyyy/mm/dd hh:mi:ss';

    # replace format values
    $date_str =~ s/yyyy/$year4/g;
    $date_str =~ s/yy/$year2/g;
    $date_str =~ s/mm/$month/g;
    $date_str =~ s/dd/$day/g;
    $date_str =~ s/hh/$hour/g;
    $date_str =~ s/mi/$min/g;
    $date_str =~ s/ss/$sec/g;

    return $date_str;
}

1;
__END__