view release on metacpan or  search on metacpan

lib/Log/Syslog/Fast/PP.pm  view on Meta::CPAN

use 5.006002;
use strict;
use warnings;

use Log::Syslog::Fast::Constants ':all';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
our %EXPORT_TAGS = %Log::Syslog::Fast::Constants::EXPORT_TAGS;
our @EXPORT_OK = @Log::Syslog::Fast::Constants::EXPORT_OK;

use Carp;
use POSIX 'strftime';
use IO::Socket::IP;
use IO::Socket::UNIX;
use Socket;

sub DESTROY { }

use constant PRIORITY   => 0;
use constant SENDER     => 1;
use constant NAME       => 2;
use constant PID        => 3;
use constant SOCK       => 4;
use constant LAST_TIME  => 5;
use constant PREFIX     => 6;
use constant PREFIX_LEN => 7;
use constant FORMAT     => 8;

sub new {
    my $ref = shift;
    $ref = __PACKAGE__ unless defined $ref;
    my $class = ref $ref || $ref;

    my ($proto, $hostname, $port, $facility, $severity, $sender, $name) = @_;

    croak "hostname required" unless defined $hostname;
    croak "sender required"   unless defined $sender;
    croak "name required"     unless defined $name;

    my $self = bless [
        ($facility << 3) | $severity, # prio
        $sender, # sender
        $name, # name
        $$, # pid
        undef, # sock
        undef, # last_time
        undef, # prefix
        undef, # prefix_len
        LOG_RFC3164, # format
    ], $class;

    $self->update_prefix(time());

    eval { $self->set_receiver($proto, $hostname, $port) };
    die "Error in ->new: $@" if $@;
    return $self;
}

sub update_prefix {
    my $self = shift;
    my $t = shift;

    $self->[LAST_TIME] = $t;

    my $timestr = strftime("%h %e %T", localtime $t);
    if ($self->[FORMAT] == LOG_RFC5424) {
        $timestr = strftime("%Y-%m-%dT%H:%M:%S%z", localtime $t);
        $timestr =~ s/(\d{2})$/:$1/; # see http://tools.ietf.org/html/rfc3339#section-5.6 time-numoffset
    }

    $self->[PREFIX] = sprintf "<%d>%s %s %s[%d]: ",
        $self->[PRIORITY], $timestr, $self->[SENDER], $self->[NAME], $self->[PID];
    if ($self->[FORMAT] == LOG_RFC5424) {
        $self->[PREFIX] = sprintf "<%d>1 %s %s %s %d - - ",
            $self->[PRIORITY], $timestr, $self->[SENDER], $self->[NAME], $self->[PID];
    }
    if ($self->[FORMAT] == LOG_RFC3164_LOCAL) {
        $self->[PREFIX] = sprintf "<%d>%s %s[%d]: ",
            $self->[PRIORITY], $timestr, $self->[NAME], $self->[PID];
    }
}

sub set_receiver {
    my $self = shift;
    croak("hostname required") unless defined $_[1];

    my ($proto, $hostname, $port) = @_;

    if ($proto == LOG_TCP) {
        $self->[SOCK] = IO::Socket::IP->new(
            Proto    => 'tcp',
            PeerHost => $hostname,
            PeerPort => $port,
        );
    }
    elsif ($proto == LOG_UDP) {
        $self->[SOCK] = IO::Socket::IP->new(
            Proto    => 'udp',
            PeerHost => $hostname,
            PeerPort => $port,
        );
    }
    elsif ($proto == LOG_UNIX) {
        eval {
            $self->[SOCK] = IO::Socket::UNIX->new(
                Type => SOCK_STREAM,
                Peer => $hostname,
            );
        };
        if ($@ || !$self->[SOCK]) {
            $self->[SOCK] = IO::Socket::UNIX->new(
                Type => SOCK_DGRAM,
                Peer => $hostname,
            );
        }
    }

    die "Error in ->set_receiver: $!" unless $self->[SOCK];
}