File Coverage

blib/lib/Perlbal/Plugin/Syslogger.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Perlbal::Plugin::Syslogger;

use strict;
use warnings;

our $VERSION = '1.00';

use Log::Syslog::Constants 1.00;
use Log::Syslog::DangaSocket 1.05;
use Log::Syslog::Fast;
use Perlbal;
use Sys::Hostname;

use base 'Exporter';

our @EXPORT_OK = qw/ send_syslog_msg replace_perlbal_log /;

sub load {
    my $class = shift;

    Perlbal::Service::add_tunable(
        syslog_transport => {
            check_role => '*',
            des => "Transport type (udp, tcp, or unix)",
            default => 'udp',
            check_type => sub {
                my ($self, $val, $errref) = @_;
                $val = lc $val;
                return 1 if $val eq 'udp' || $val eq 'tcp' || $val eq 'unix';
                $$errref = "Expecting transport of udp, tcp, or unix";
                return 0;
            },
        }
    );
    Perlbal::Service::add_tunable(
        syslog_host => {
            check_role => '*',
            des => "Host where the syslogd is running (tcp/udp), or log socket (unix).",
            default => '127.0.0.1',
        }
    );
    Perlbal::Service::add_tunable(
        syslog_port => {
            check_role => '*',
            des => "Port on syslog_host where syslogd listens.",
            default => 514,
            check_type => 'int',
        }
    );
    Perlbal::Service::add_tunable(
        syslog_source => {
            check_role => '*',
            des => "Name of the submitting service (gets included in the log message)",
            default => 'Perlbal',
        }
    );
    Perlbal::Service::add_tunable(
        syslog_name => {
            check_role => '*',
            des => "Host of the submitting service (gets included in the log message)",
            default => hostname() || 'localhost',
        }
    );
    Perlbal::Service::add_tunable(
        syslog_facility => {
            check_role => '*',
            des => "Facility to log to; may be named or numeric",
            default => Log::Syslog::Constants::LOG_LOCAL0,
        }
    );
    Perlbal::Service::add_tunable(
        syslog_severity => {
            check_role => '*',
            des => "Severity level to log to; may be named or numeric",
            default => Log::Syslog::Constants::LOG_NOTICE,
        }
    );
}

sub register {
    my ($class, $svc) = @_;

    # stash the object that does all our work within the service configuration
    my $cfg = $svc->{extra_config} ||= {};

    my $facility = $cfg->{syslog_facility};
    if ($facility =~ /\D/) {
        $facility = Log::Syslog::Constants::get_facility($facility);
        die "unknown syslog facility $facility\n" unless defined $facility;
    }

    my $severity = $cfg->{syslog_severity};
    if ($severity =~ /\D/) {
        $severity = Log::Syslog::Constants::get_severity($facility);
        die "unknown syslog severity $severity\n" unless defined $severity;
    }

    my $transport = lc $cfg->{syslog_transport};
    if ($transport eq 'udp') {
        $cfg->{_syslogger} = Log::Syslog::Fast->new(
            Log::Syslog::Fast::LOG_UDP,
            $cfg->{syslog_host},
            $cfg->{syslog_port},
            $facility,
            $severity,
            $cfg->{syslog_source},
            $cfg->{syslog_name}
        );
    }
    elsif ($transport eq 'tcp' || $transport eq 'unix') {
        $cfg->{_syslogger} = Log::Syslog::DangaSocket->new(
            $transport,
            $cfg->{syslog_host},
            $cfg->{syslog_port},
            $cfg->{syslog_source},
            $cfg->{syslog_name},
            $facility,
            $severity,
            1,
        );
    }

    die "couldn't create syslogger: $!\n" unless $cfg->{_syslogger};

    return 1;
}

sub unregister {
    my ($class, $svc) = @_;
    delete $svc->{extra_config}{_syslogger};
    return 1;
}

sub send_syslog_msg {
    $_[0]->{extra_config}{_syslogger}->send($_[1]);
}

sub replace_perlbal_log {
    my $service = shift;
    my $logger = $service->{extra_config}{_syslogger};

    die "need a service with configured syslogger" unless $logger;

    my $old_perlbal_log = \&Perlbal::log;

    no warnings 'redefine';
    *Perlbal::log = sub {
        my ($level, $message) = @_;

        my $severity = Log::Syslog::Constants::get_severity($level);
        return unless defined $severity;

        my $old_severity = $logger->get_severity;

        $logger->set_severity($severity);

        $message .= "\n" unless $message =~ /\n$/;
        $logger->send(@_ ? sprintf($message, @_) : $message);

        $logger->set_severity($old_severity);
    };

    return $old_perlbal_log;
}

sub capture_std_handles {
    my $service = shift;
    my $logger = $service->{extra_config}{_syslogger};

    die "need a service with configured syslogger" unless $logger;

    tie *STDOUT, LineHandler => $logger;
    tie *STDERR, LineHandler => $logger;
}

package LineHandler;

use base 'Tie::Handle';

sub TIEHANDLE {
    my ($class, $logger) = @_;
    return bless \$logger, $class;
}

sub WRITE {
    my $lref = shift;
    my ($buf, $len, $offset) = @_;
    $offset ||= 0;
    $$lref->send(substr $buf, $offset, $len);
}

__END__