File Coverage

lib/Beekeeper/Logger.pm

Criterion	Covered	Total	%
statement	42	89	47.1
branch	0	26	0.0
condition	0	3	0.0
subroutine	14	16	87.5
pod	0	2	0.0
total	56	136	41.1

package Beekeeper::Logger;

use strict;
use warnings;

our $VERSION = '0.10';

use constant LOG_FATAL  => 1;
use constant LOG_ALERT  => 2;
use constant LOG_CRIT   => 3;
use constant LOG_ERROR  => 4;
use constant LOG_WARN   => 5;
use constant LOG_NOTICE => 6;
use constant LOG_INFO   => 7;
use constant LOG_DEBUG  => 8;
use constant LOG_TRACE  => 9;

use JSON::XS;
use Exporter 'import';
use Time::HiRes;

my $JSON;

our @EXPORT_OK = qw(
    LOG_FATAL
    LOG_ALERT
    LOG_CRIT
    LOG_ERROR
    LOG_WARN
    LOG_NOTICE
    LOG_INFO
    LOG_DEBUG
    LOG_TRACE
    %LOG_LABEL
);

our %EXPORT_TAGS = ('log_levels' => \@EXPORT_OK );

our %LOG_LABEL = (
    &LOG_FATAL  => 'fatal',
    &LOG_ALERT  => 'alert',
    &LOG_CRIT   => 'critical',
    &LOG_ERROR  => 'error',
    &LOG_WARN   => 'warning',
    &LOG_NOTICE => 'notice',
    &LOG_INFO   => 'info',
    &LOG_DEBUG  => 'debug',
    &LOG_TRACE  => 'trace',
);


sub new {
    my $class = shift;

    my $self = {
        worker_class => undef,
        foreground   => undef,
        log_file     => undef,
        service      => undef,
        host         => undef,
        pool         => undef,
        _BUS         => undef,
        @_
    };

    unless ($self->{service}) {
        # Make an educated guess based on worker class
        my $service = lc $self->{worker_class};
        $service =~ s/::/-/g;
        $service =~ s/-worker$//;

        $self->{service} = $service;
    }

    unless ($self->{log_file}) {
        # Use a single log file per service
        my $dir  = '/var/log';
        my $user = getpwuid($>);
        my $file = $self->{service} . '.log';
        ($user) = ($user =~ m/(\w+)/); # untaint

        $self->{log_file} = (-d "$dir/$user") ? "$dir/$user/$file" : "$dir/$file";
    }

    unless ($self->{foreground}) {

        my $log_file = $self->{log_file};

        # If running as root temporarily restore uid and gid to allow opening
        local $> = $< if ($< == 0);
        local $) = $( if ($( == 0);

        if (open(my $fh, '>>', $log_file)) {
            # Send STDERR and STDOUT to log file
            open(STDERR, '>&', $fh) or die "Can't redirect STDERR to $log_file: $!";
            open(STDOUT, '>&', $fh) or die "Can't redirect STDOUT to $log_file: $!";
        }
        else {
            # Probably no permissions to open the log file
            warn "Can't open log file $log_file: $!";
        }
    }

    bless $self, $class;
    return $self;
}

sub log {
    my ($self, $level, @msg) = @_;

    my $msg = join(' ', map { defined $_ ? "$_" : 'undef' } @msg );
    chomp($msg);

    my $now = Time::HiRes::time;
    my $ms = int(($now * 1000) % 1000);
    my @t = reverse((localtime)[0..5]); $t[0] += 1900; $t[1]++;
    my $tstamp = sprintf("%4d-%02d-%02d %02d:%02d:%02d.%03d", @t, $ms);

    ## 1. Log to local file

    print STDERR "[$tstamp][$$][$LOG_LABEL{$level}] $msg\n";

    ## 2. Log to topic

    my $bus = $self->{_BUS};
    return unless $bus && $bus->{is_connected};

    # JSON-RPC notification

    $JSON = JSON::XS->new->utf8->allow_blessed->convert_blessed unless defined $JSON;

    my $json = $JSON->encode({
        jsonrpc => '2.0',
        method  => $LOG_LABEL{$level},
        params  => {
            level   => $level,
            service => $self->{service},
            host    => $self->{host},
            pool    => $self->{pool},
            pid     => $$,
            message => $msg,
            tstamp  => $now,
        }
    });

    local $@;

    eval {

        my $service = $self->{service};
        $service =~ tr|.|/|;

        $bus->publish(
            topic   => "log/$level/$service",
            payload => \$json,
        );
    };

    if ($@) {
        my $msg = $@; chomp($msg);
        print STDERR "[$tstamp][$$][$LOG_LABEL{$level}] $msg\n";
    }
}

1;

__END__