File Coverage

blib/lib/CTK/Log.pm

Criterion	Covered	Total	%
statement	102	154	66.2
branch	24	54	44.4
condition	18	64	28.1
subroutine	21	43	48.8
pod	19	19	100.0
total	184	334	55.0

package CTK::Log; # $Id: Log.pm 276 2020-03-22 16:53:04Z minus $
use strict;
use utf8;

=encoding utf-8

=head1 NAME

CTK::Log - CTK Logging

=head1 VERSION

Version 2.63

=head1 SYNOPSIS

    use CTK::Log;
    use CTK::Log qw/:constants/;

    my $logger = new CTK::Logger (
            file        => "logs/foo.log",
            level       => CTK::Log::LOG_INFO,
            ident       => "ident string",
        );

    $logger->log( CTK::Log::LOG_INFO, " ... Blah-Blah-Blah ... " );

    $logger->log_except( "log message" );  # 9 exception
    $logger->log_fatal( "log message" );   # 8 fatal
    $logger->log_emerg( "log message" );   # 7 system is unusable
    $logger->log_alert( "log message" );   # 6 action must be taken immediately
    $logger->log_crit( "log message" );    # 5 critical conditions
    $logger->log_error( "log message" );   # 4 error conditions
    $logger->log_warning( "log message" ); # 3 warning conditions
    $logger->log_notice( "log message" );  # 2 normal but significant condition
    $logger->log_info( "log message" );    # 1 informational
    $logger->log_debug( "log message" );   # 0 debug-level messages (default)

=head1 DESCRIPTION

Logger class

=head1 METHODS

=head2 new

    my $logger = new CTK::Log (
            file        => "logs/foo.log",
            level       => "info", # or CTK::Log::LOG_INFO
            ident       => "ident string",
        );

Returns logger object for logging to file

    my $logger = new CTK::Log (
            level       => "info", # or CTK::Log::LOG_INFO
            ident       => "ident string",
        );

Returns logger object for logging to syslog

=over 8

=item B

The part of the system to report about, for example C. See L

Default: C

=item B

Specifies log file. If not specify, then will be used syslog

Default: undef

=item B

Specifies ident string for each log-record

  ident = "test"

    [Mon Apr 29 20:02:04 2019] [info] [7936] [test] Blah Blah Blah

  ident = undef

    [Mon Apr 29 20:02:04 2019] [info] [7936] Blah Blah Blah

Default: undef

=item B

This directive specifies the minimum possible priority level. You can use:

constants:

    LOG_DEBUG
    LOG_INFO
    LOG_NOTICE or LOG_NOTE
    LOG_WARNING or LOG_WARN
    LOG_ERR or LOG_ERROR
    LOG_CRIT
    LOG_ALERT
    LOG_EMERG or LOG_EMERGENCY
    LOG_FATAL
    LOG_EXCEPT or LOG_EXCEPTION

...or strings:

    'debug'
    'info'
    'notice' or 'note'
    'warning' or 'warn'
    'error' or 'err'
    'crit'
    'alert'
    'emerg' or 'emergency'
    'fatal'
    'except' or 'exception'

Default: C

=item B

Specifies flag for suppressing prefixes log-data

  ident = "test"
  pure = 0

    [Mon Apr 29 19:12:55 2019] [crit] [7480] [test] Blah-Blah-Blah

  ident = "test"
  pure = 1

    [test] Blah-Blah-Blah

  ident = undef
  pure = 1

    Blah-Blah-Blah

Default: 0

=item B

Separator of log-record elements

  separator = " "

    [Mon Apr 29 20:02:04 2019] [info] [7936] [test] Blah Blah Blah

  separator = ","

    [Mon Apr 29 20:02:04 2019],[info],[7936],[test],Blah Blah Blah

Default: C<" ">

=item B

Socket optrions for L

Allowed formats, examples:

    socketopts => "unix"
    socketopts => ["unix"]
    socketopts => { type => "tcp", port => 2486 }

Default: C

=item B

Options of L

Default: C

=item B

Sets to 1 for send data to syslog forced

Default: 0

=item B

Sets flag utf8 for logging data. The flag is enabled by default

Default: 1

=back

=head2 error

    my $error = $logger->error;

Returns error string if occurred any errors while creating the object

=head2 status

    print $logger->error unless $logger->status;

Returns boolean status of object creating

=head1 LOG METHODS

=head2 log

    $logger->log( , , , ... );
    $logger->log( LOG_INFO, "Message: Blah-Blah-Blah" );
    $logger->log( LOG_INFO, "Message: %s", "Blah-Blah-Blah" );
    $logger->log( "info", "Message: Blah-Blah-Blah" );

Logging with info level (1). Same as log_info( "Message: %s", "Blah-Blah-Blah" )

=head2 log_debug

    $logger->log_debug( , , ... );
    $logger->log_debug( "Blah-Blah-Blah" );

Level 0: debug-level messages (default)

=head2 log_info

    $logger->log_info( , , ... );
    $logger->log_info( "Blah-Blah-Blah" );

Level 1: informational

=head2 log_notice, log_note

    $logger->log_notice( , , ... );
    $logger->log_notice( "Blah-Blah-Blah" );

Level 2: normal but significant condition

=head2 log_warning, log_warn

    $logger->log_warning( , , ... );
    $logger->log_warning( "Blah-Blah-Blah" );

Level 3: warning conditions

=head2 log_error, log_err

    $logger->log_error( , , ... );
    $logger->log_error( "Blah-Blah-Blah" );

Level 4: error conditions

=head2 log_crit

    $logger->log_crit( , , ... );
    $logger->log_crit( "Blah-Blah-Blah" );

Level 5: critical conditions

=head2 log_alert

    $logger->log_alert( , , ... );
    $logger->log_alert( "Blah-Blah-Blah" );

Level 6: action must be taken immediately

=head2 log_emerg, log_emergency

    $logger->log_emerg( , , ... );
    $logger->log_emerg( "Blah-Blah-Blah" );

Level 7: system is unusable

=head2 log_fatal

    $logger->log_fatal( , , ... );
    $logger->log_fatal( "Blah-Blah-Blah" );

Level 8: fatal

=head2 log_except,log_exception

    $logger->log_except( , , ... );
    $logger->log_except( "Blah-Blah-Blah" );

Level 9: exception

=head1 HISTORY

See C file

=head1 DEPENDENCIES

L, L

=head1 TO DO

See C file

=head1 BUGS

* none noted

=head1 SEE ALSO

L, L

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L [e-mail]

=head1 COPYRIGHT

Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C file and L

=cut


use vars qw/$VERSION %EXPORT_TAGS @EXPORT_OK/;
$VERSION = '2.63';

use base qw/Exporter/;

use Carp;
use IO::File;
use Sys::Syslog ();
use Try::Tiny;
use Cwd qw/getcwd/;
use File::Spec ();

@EXPORT_OK = qw(
        LOG_DEBUG LOG_INFO LOG_NOTICE LOG_NOTE LOG_WARNING LOG_WARN LOG_ERR
        LOG_ERROR LOG_CRIT LOG_ALERT LOG_EMERG LOG_EMERGENCY LOG_FATAL
        LOG_EXCEPT LOG_EXCEPTION
    );

%EXPORT_TAGS = (
        constants => [@EXPORT_OK],
    );

use constant {
    LOGOPT          => 'ndelay,pid', # For Sys::Syslog
    MSWIN           => $^O =~ /mswin/i ? 1 : 0,
    SEPARATOR       => ' ',
    LOGLEVELSA      => [qw/debug info notice warning error crit alert emerg fatal except/],
    LOGLEVELS       => {
        'debug'     => 0,
        'info'      => 1,
        'notice'    => 2, 'note' => -2,
        'warning'   => 3, 'warn' => -3,
        'error'     => 4, 'err' => -4,
        'crit'      => 5,
        'alert'     => 6,
        'emerg'     => 7, 'emergency' => -7,
        'fatal'     => 8,
        'except'    => 9, 'exception' => -9,
    },
    LOG_DEBUG       => 0,
    LOG_INFO        => 1,
    LOG_NOTICE      => 2, LOG_NOTE => 2,
    LOG_WARNING     => 3, LOG_WARN => 3,
    LOG_ERR         => 4, LOG_ERROR => 4,
    LOG_CRIT        => 5,
    LOG_ALERT       => 6,
    LOG_EMERG       => 7, LOG_EMERGENCY => 7,
    LOG_FATAL       => 8,
    LOG_EXCEPT      => 9, LOG_EXCEPTION => 9,
};

my %SYSLOG_LEVEL_MAP = (
  # My LEVEL        , SysLog LEVEL
    LOG_DEBUG       , LOG_EMERG,
    LOG_INFO        , LOG_ALERT,
    LOG_NOTICE      , LOG_CRIT,
    LOG_WARNING     , LOG_ERR,
    LOG_ERR         , LOG_WARNING,
    LOG_CRIT        , LOG_NOTICE,
    LOG_ALERT       , LOG_INFO,
    LOG_EMERG       , LOG_DEBUG,
    LOG_FATAL       , LOG_DEBUG,
    LOG_EXCEPT      , LOG_DEBUG,
);

sub new {
    my $class = shift;
    my %args = @_;
    my $level = _getLevel($args{level} // LOG_DEBUG);
    carp(sprintf("Incorrect level %s", $args{level})) unless defined $level;
    my $usesyslog = $args{usesyslog} || 0;
    my $syslogopts = $args{syslogopts} // LOGOPT;
    my $socketopts = $args{socketopts};
    my $facility = $args{facility} || Sys::Syslog::LOG_USER;
    my $file = $args{file};
    $usesyslog = 1 unless defined($file) && length($file);
    $file = File::Spec->catfile(getcwd(), $file)
        if $file && !File::Spec->file_name_is_absolute($file);

    # Create object
    my $self = bless {
        status      => 0,
        error       => "",
        usesyslog   => $usesyslog,
        file        => $file,
        level       => $level || LOG_DEBUG,
        ident       => $args{ident},
        syslogopts  => $syslogopts,
        socketopts  => $socketopts,
        facility    => $facility,
        separator   => $args{separator} // SEPARATOR,
        "utf8"      => $args{"utf8"} // 1,
        pure        => $args{pure} // 0,
        fh          => undef,
    }, $class;

    if ($usesyslog) {
        # never log to console - thats too slow, and
        # it corrupts the DBD database connection!
        if ($socketopts && ref($socketopts) eq 'ARRAY') {
            Sys::Syslog::setlogsock(@$socketopts);
        } elsif ($socketopts && (!ref($socketopts) || ref($socketopts) eq 'HASH')) {
            Sys::Syslog::setlogsock($socketopts);
        }
        #elsif (!MSWIN) {
        #    Sys::Syslog::setlogsock('unix');
        #}
        my $ident = $args{ident} || scalar(caller(0));
        try { # ignore errors
            Sys::Syslog::openlog($ident, $syslogopts, $facility);
        } catch {
            $self->{error} = $_;
            return $self;
        };
        $self->{status} = 1;
    } else {
        my $fh;
        try {
            $fh = new IO::File($file, "a");
        } catch {
            $self->{error} = sprintf("Can't open log file %s: %s", $file, $_);
            return $self;
        };
        unless (defined($fh)) {
            $self->{error} = sprintf("Can't open log file %s", $file);
            return $self;
        }
        $fh->binmode(":raw:utf8") if $self->{"utf8"};
        $fh->autoflush(1);
        $self->{fh} = $fh;
        $self->{status} = 1;
    }

    return $self;
}
sub error {
    my $self = shift;
    return $self->{error} // '';
}
sub status {
    my $self = shift;
    return $self->{status} ? 1 : 0;
}

sub log {
    my $self = shift;
    my $ll = shift // LOG_DEBUG;
    my @msg = @_;
    return 0 unless $self->status;
    my $ident = $self->{ident};
    my $level = _getLevel($ll);
    unless (defined($level)) {
        unshift(@msg, $ll);
        $level = LOG_DEBUG;
    }
    return 0 if $level < $self->{level};

    # Flush!
    if ($self->{usesyslog}) {
        return $self->_flush_to_syslog($level, @msg);
    } else {
        return $self->_flush_to_file($level, @msg);
    }

    return 0;
}
sub log_debug { shift->log(LOG_DEBUG, @_) };
sub log_info { shift->log(LOG_INFO, @_) };
sub log_notice { shift->log(LOG_NOTICE, @_) };
sub log_note { goto &log_notice };
sub log_warning { shift->log(LOG_WARNING, @_) };
sub log_warn { goto &log_warning };
sub log_error { shift->log(LOG_ERROR, @_) };
sub log_err { goto &log_error };
sub log_crit { shift->log(LOG_CRIT, @_) };
sub log_alert { shift->log(LOG_ALERT, @_) };
sub log_emerg { shift->log(LOG_EMERG, @_) };
sub log_emergency { goto &log_emerg };
sub log_fatal { shift->log(LOG_FATAL, @_) };
sub log_except { shift->log(LOG_EXCEPT, @_) };
sub log_exception { goto &log_except };

# Internal methods
sub _flush_to_file {
    my $self = shift;
    my $level = shift;
    my $format = shift // "";
    my @message = @_;
    return unless defined $level;

    # Adding
    my @buffer = ();
    unless ($self->{pure}) {
        push @buffer, sprintf("[%s]", scalar(localtime(time())));
        push @buffer, sprintf("[%s]", LOGLEVELSA()->[$level]);
        push @buffer, sprintf("[%s]", $$);
    }

    # Ident?
    my $ident = $self->{ident};
    push @buffer, sprintf("[%s]", $ident) if defined($ident) && length($ident);

    # Print
    my $fh = $self->{fh};
    if (defined($fh)) {
        try {
            $fh->print(join($self->{separator}, @buffer, "")) if @buffer;
            $fh->printf($format, @message);
            $fh->print("\n");
        } catch {
            $self->{error} = $_;
            return 0;
        };
    } else {
        $self->{status} = 0;
        return 0;
    }

    return 1;
}
sub _flush_to_syslog {
    my $self = shift;
    my $level = shift;
    my $format = shift // "";
    my @message = @_;
    return unless defined $level;
    my $sl = _to_syslog($level);
    try { # ignore errors
        Sys::Syslog::syslog($sl, $format, @message);
    } catch {
        $self->{error} = $_;
        return 0;
    };
    return 1;
}

# Internal functions
sub _getLevel { # Returns integer val: 0-9 -- ok, undef - incorrect :(
    my $ll = shift;
    return LOG_DEBUG unless defined $ll;
    my $loglevels = LOGLEVELS;
    my %levels  = %$loglevels; # name => val
    my %rlevels = reverse %$loglevels; # val => name
    if (($ll =~ /^[0-9]+$/) && exists($rlevels{$ll})) { # integer val
        return $ll if $ll >= LOG_DEBUG and $ll <= LOG_EXCEPT;
        return LOG_DEBUG;
    } elsif (($ll =~ /^[a-z]+$/i) && exists($levels{lc($ll)})) { # string
        return $levels{lc($ll)};
    }
    return undef;
}
sub _to_syslog { # for syslog
    my $level = shift // LOG_DEBUG;
    return $SYSLOG_LEVEL_MAP{$level} // $SYSLOG_LEVEL_MAP{(LOG_DEBUG)};
}

sub DESTROY {
    my $self = shift;
    return 1 unless $self && $self->status;
    if ($self->{usesyslog}) {
        Sys::Syslog::closelog();
    } else {
        $self->{fh}->close if defined($self->{fh}) && ref($self->{fh});
    }
    undef($self);
    return 1;
}

1;

__END__