package Sys::Syslog;
use strict;
use warnings;
use warnings::register;
use Carp;
use Config;
use Exporter ();
use File::Basename;
use POSIX qw< strftime setlocale LC_TIME >;
use Socket qw< :all >;
require 5.005;
*import = \&Exporter::import;
{ no strict 'vars';
$VERSION = '0.36';
%EXPORT_TAGS = (
standard => [qw(openlog syslog closelog setlogmask)],
extended => [qw(setlogsock)],
macros => [
# levels
qw(
LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR
LOG_INFO LOG_NOTICE LOG_WARNING
),
# standard facilities
qw(
LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN
LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4
LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS
LOG_SYSLOG LOG_USER LOG_UUCP
),
# Mac OS X specific facilities
qw( LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_RAS LOG_REMOTEAUTH ),
# modern BSD specific facilities
qw( LOG_CONSOLE LOG_NTP LOG_SECURITY ),
# IRIX specific facilities
qw( LOG_AUDIT LOG_LFMT ),
# options
qw(
LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR
),
# others macros
qw(
LOG_FACMASK LOG_NFACILITIES LOG_PRIMASK
LOG_MASK LOG_UPTO
),
],
);
@EXPORT = (
@{$EXPORT_TAGS{standard}},
);
@EXPORT_OK = (
@{$EXPORT_TAGS{extended}},
@{$EXPORT_TAGS{macros}},
);
eval {
require XSLoader;
XSLoader::load('Sys::Syslog', $VERSION);
1
} or do {
require DynaLoader;
push @ISA, 'DynaLoader';
bootstrap Sys::Syslog $VERSION;
};
}
#
# Constants
#
use constant HAVE_GETPROTOBYNAME => $Config::Config{d_getpbyname};
use constant HAVE_GETPROTOBYNUMBER => $Config::Config{d_getpbynumber};
use constant HAVE_SETLOCALE => $Config::Config{d_setlocale};
use constant HAVE_IPPROTO_TCP => defined &Socket::IPPROTO_TCP ? 1 : 0;
use constant HAVE_IPPROTO_UDP => defined &Socket::IPPROTO_UDP ? 1 : 0;
use constant HAVE_TCP_NODELAY => defined &Socket::TCP_NODELAY ? 1 : 0;
use constant SOCKET_IPPROTO_TCP =>
HAVE_IPPROTO_TCP ? Socket::IPPROTO_TCP
: HAVE_GETPROTOBYNAME ? scalar getprotobyname("tcp")
: 6;
use constant SOCKET_IPPROTO_UDP =>
HAVE_IPPROTO_UDP ? Socket::IPPROTO_UDP
: HAVE_GETPROTOBYNAME ? scalar getprotobyname("udp")
: 17;
use constant SOCKET_TCP_NODELAY => HAVE_TCP_NODELAY ? Socket::TCP_NODELAY : 1;
#
# Public variables
#
use vars qw($host); # host to send syslog messages to (see notes at end)
#
# Prototypes
#
sub silent_eval (&);
#
# Global variables
#
use vars qw($facility);
my $connected = 0; # flag to indicate if we're connected or not
my $syslog_send; # coderef of the function used to send messages
my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
my $syslog_xobj = undef; # if defined, holds the external object used to send messages
my $transmit_ok = 0; # flag to indicate if the last message was transmitted
my $sock_port = undef; # socket port
my $sock_timeout = 0; # socket timeout, see below
my $current_proto = undef; # current mechanism used to transmit messages
my $ident = ''; # identifiant prepended to each message
$facility = ''; # current facility
my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
my %options = (
ndelay => 0,
noeol => 0,
nofatal => 0,
nonul => 0,
nowait => 0,
perror => 0,
pid => 0,
);
# Default is now to first use the native mechanism, so Perl programs
# behave like other normal Unix programs, then try other mechanisms.
my @connectMethods = qw(native tcp udp unix pipe stream console);
if ($^O eq "freebsd" or $^O eq "linux") {
@connectMethods = grep { $_ ne 'udp' } @connectMethods;
}
# And on Win32 systems, we try to use the native mechanism for this
# platform, the events logger, available through Win32::EventLog.
EVENTLOG: {
my $verbose_if_Win32 = $^O =~ /Win32/i;
if (can_load_sys_syslog_win32($verbose_if_Win32)) {
unshift @connectMethods, 'eventlog';
}
}
my @defaultMethods = @connectMethods;
my @fallbackMethods = ();
# The timeout in connection_ok() was pushed up to 0.25 sec in
# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
#
# However, this also had the effect of slowing this test for
# all other operating systems, which apparently impacted some
# users (cf. CPAN-RT #34753). So, in order to make everybody
# happy, the timeout is now zero by default on all systems
# except on OSX where it is set to 250 msec, and can be set
# with the infamous setlogsock() function.
#
# Update 2011-08: this issue is also been seen on multiprocessor
# Debian GNU/kFreeBSD systems. See http://bugs.debian.org/627821
# and https://rt.cpan.org/Ticket/Display.html?id=69997
# Also, lowering the delay to 1 ms, which should be enough.
$sock_timeout = 0.001 if $^O =~ /darwin|gnukfreebsd/;
# Perl 5.6.0's warnings.pm doesn't have warnings::warnif()
if (not defined &warnings::warnif) {
*warnings::warnif = sub {
goto &warnings::warn if warnings::enabled(__PACKAGE__)
}
}
# coderef for a nicer handling of errors
my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.
no strict 'vars';
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
croak "Sys::Syslog::constant() not defined" if $constname eq 'constant';
my ($error, $val) = constant($constname);
croak $error if $error;
no strict 'refs';
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
}
sub openlog {
($ident, my $logopt, $facility) = @_;
# default values
$ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog';
$logopt ||= '';
$facility ||= LOG_USER();
for my $opt (split /\b/, $logopt) {
$options{$opt} = 1 if exists $options{$opt}
}
$err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
return 1 unless $options{ndelay};
connect_log();
}
sub closelog {
disconnect_log() if $connected;
$options{$_} = 0 for keys %options;
$facility = $ident = "";
$connected = 0;
return 1
}
sub setlogmask {
my $oldmask = $maskpri;
$maskpri = shift unless $_[0] == 0;
$oldmask;
}
my %mechanism = (
console => {
check => sub { 1 },
},
eventlog => {
check => sub { return can_load_sys_syslog_win32() },
err_msg => "no Win32 API available",
},
inet => {
check => sub { 1 },
},
native => {
check => sub { 1 },
},
pipe => {
check => sub {
($syslog_path) = grep { defined && length && -p && -w _ }
$syslog_path, &_PATH_LOG, "/dev/log";
return $syslog_path ? 1 : 0
},
err_msg => "path not available",
},
stream => {
check => sub {
if (not defined $syslog_path) {
my @try = qw(/dev/log /dev/conslog);
unshift @try, &_PATH_LOG if length &_PATH_LOG;
($syslog_path) = grep { -w } @try;
}
return defined $syslog_path && -w $syslog_path
},
err_msg => "could not find any writable device",
},
tcp => {
check => sub {
return 1 if defined $sock_port;
if (eval { local $SIG{__DIE__};
getservbyname('syslog','tcp') || getservbyname('syslogng','tcp')
}) {
$host = $syslog_path;
return 1
}
else {
return
}
},
err_msg => "TCP service unavailable",
},
udp => {
check => sub {
return 1 if defined $sock_port;
if (eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') }) {
$host = $syslog_path;
return 1
}
else {
return
}
},
err_msg => "UDP service unavailable",
},
unix => {
check => sub {
my @try = ($syslog_path, &_PATH_LOG);
($syslog_path) = grep { defined && length && -w } @try;
return defined $syslog_path && -w $syslog_path
},
err_msg => "path not available",
},
);
sub setlogsock {
my %opt;
# handle arguments
# - old API: setlogsock($sock_type, $sock_path, $sock_timeout)
# - new API: setlogsock(\%options)
croak "setlogsock(): Invalid number of arguments"
unless @_ >= 1 and @_ <= 3;
if (my $ref = ref $_[0]) {
if ($ref eq "HASH") {
%opt = %{ $_[0] };
croak "setlogsock(): No argument given" unless keys %opt;
}
elsif ($ref eq "ARRAY") {
@opt{qw< type path timeout >} = @_;
}
else {
croak "setlogsock(): Unexpected \L$ref\E reference"
}
}
else {
@opt{qw< type path timeout >} = @_;
}
# check socket type, remove invalid ones
my $diag_invalid_type = "setlogsock(): Invalid type%s; must be one of "
. join ", ", map { "'$_'" } sort keys %mechanism;
croak sprintf $diag_invalid_type, "" unless defined $opt{type};
my @sock_types = ref $opt{type} eq "ARRAY" ? @{$opt{type}} : ($opt{type});
my @tmp;
for my $sock_type (@sock_types) {
carp sprintf $diag_invalid_type, " '$sock_type'" and next
unless exists $mechanism{$sock_type};
push @tmp, "tcp", "udp" and next if $sock_type eq "inet";
push @tmp, $sock_type;
}
@sock_types = @tmp;
# set global options
$syslog_path = $opt{path} if defined $opt{path};
$host = $opt{host} if defined $opt{host};
$sock_timeout = $opt{timeout} if defined $opt{timeout};
$sock_port = $opt{port} if defined $opt{port};
disconnect_log() if $connected;
$transmit_ok = 0;
@fallbackMethods = ();
@connectMethods = ();
my $found = 0;
# check each given mechanism and test if it can be used on the current system
for my $sock_type (@sock_types) {
if ( $mechanism{$sock_type}{check}->() ) {
push @connectMethods, $sock_type;
$found = 1;
}
else {
warnings::warnif("setlogsock(): type='$sock_type': "
. $mechanism{$sock_type}{err_msg});
}
}
# if no mechanism worked from the given ones, use the default ones
@connectMethods = @defaultMethods unless @connectMethods;
return $found;
}
sub syslog {
my ($priority, $mask, @args) = @_;
my ($message, $buf);
my (@words, $num, $numpri, $numfac, $sum);
my $failed = undef;
my $fail_time = undef;
my $error = $!;
# if $ident is undefined, it means openlog() wasn't previously called
# so do it now in order to have sensible defaults
openlog() unless $ident;
local $facility = $facility; # may need to change temporarily.
croak "syslog: expecting argument \$priority" unless defined $priority;
croak "syslog: expecting argument \$format" unless defined $mask;
if ($priority =~ /^\d+$/) {
$numpri = LOG_PRI($priority);
$numfac = LOG_FAC($priority) << 3;
undef $numfac if $numfac == 0; # no facility given => use default
}
elsif ($priority =~ /^\w+/) {
# Allow "level" or "level|facility".
@words = split /\W+/, $priority, 2;
undef $numpri;
undef $numfac;
for my $word (@words) {
next if length $word == 0;
# Translate word to number.
$num = xlate($word);
if ($num < 0) {
croak "syslog: invalid level/facility: $word"
}
elsif ($num <= LOG_PRIMASK() and $word ne "kern") {
croak "syslog: too many levels given: $word"
if defined $numpri;
$numpri = $num;
}
else {
croak "syslog: too many facilities given: $word"
if defined $numfac;
$facility = $word if $word =~ /^[A-Za-z]/;
$numfac = $num;
}
}
}
else {
croak "syslog: invalid level/facility: $priority"
}
croak "syslog: level must be given" unless defined $numpri;
# don't log if priority is below mask level
return 0 unless LOG_MASK($numpri) & $maskpri;
if (not defined $numfac) { # Facility not specified in this call.
$facility = 'user' unless $facility;
$numfac = xlate($facility);
}
connect_log() unless $connected;
if ($mask =~ /%m/) {
# escape percent signs for sprintf()
$error =~ s/%/%%/g if @args;
# replace %m with $error, if preceded by an even number of percent signs
$mask =~ s/(?$timestamp $whoami: $message";
# add (or not) a NUL character
$buf .= "\0" if !$options{nonul};
}
# handle PERROR option
# "native" mechanism already handles it by itself
if ($options{perror} and $current_proto ne 'native') {
my $whoami = $ident;
$whoami .= "[$$]" if $options{pid};
print STDERR "$whoami: $message";
print STDERR "\n" if rindex($message, "\n") == -1;
}
# it's possible that we'll get an error from sending
# (e.g. if method is UDP and there is no UDP listener,
# then we'll get ECONNREFUSED on the send). So what we
# want to do at this point is to fallback onto a different
# connection method.
while (scalar @fallbackMethods || $syslog_send) {
if ($failed && (time - $fail_time) > 60) {
# it's been a while... maybe things have been fixed
@fallbackMethods = ();
disconnect_log();
$transmit_ok = 0; # make it look like a fresh attempt
connect_log();
}
if ($connected && !connection_ok()) {
# Something was OK, but has now broken. Remember coz we'll
# want to go back to what used to be OK.
$failed = $current_proto unless $failed;
$fail_time = time;
disconnect_log();
}
connect_log() unless $connected;
$failed = undef if ($current_proto && $failed && $current_proto eq $failed);
if ($syslog_send) {
if ($syslog_send->($buf, $numpri, $numfac)) {
$transmit_ok++;
return 1;
}
# typically doesn't happen, since errors are rare from write().
disconnect_log();
}
}
# could not send, could not fallback onto a working
# connection method. Lose.
return 0;
}
sub _syslog_send_console {
my ($buf) = @_;
# The console print is a method which could block
# so we do it in a child process and always return success
# to the caller.
if (my $pid = fork) {
if ($options{nowait}) {
return 1;
} else {
if (waitpid($pid, 0) >= 0) {
return ($? >> 8);
} else {
# it's possible that the caller has other
# plans for SIGCHLD, so let's not interfere
return 1;
}
}
} else {
if (open(CONS, ">/dev/console")) {
my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ?
POSIX::_exit($ret) if defined $pid;
close CONS;
}
POSIX::_exit(0) if defined $pid;
}
}
sub _syslog_send_stream {
my ($buf) = @_;
# XXX: this only works if the OS stream implementation makes a write
# look like a putmsg() with simple header. For instance it works on
# Solaris 8 but not Solaris 7.
# To be correct, it should use a STREAMS API, but perl doesn't have one.
return syswrite(SYSLOG, $buf, length($buf));
}
sub _syslog_send_pipe {
my ($buf) = @_;
return print SYSLOG $buf;
}
sub _syslog_send_socket {
my ($buf) = @_;
return syswrite(SYSLOG, $buf, length($buf));
#return send(SYSLOG, $buf, 0);
}
sub _syslog_send_native {
my ($buf, $numpri, $numfac) = @_;
syslog_xs($numpri|$numfac, $buf);
return 1;
}
# xlate()
# -----
# private function to translate names to numeric values
#
sub xlate {
my ($name) = @_;
return $name+0 if $name =~ /^\s*\d+\s*$/;
$name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
# ExtUtils::Constant 0.20 introduced a new way to implement
# constants, called ProxySubs. When it was used to generate
# the C code, the constant() function no longer returns the
# correct value. Therefore, we first try a direct call to
# constant(), and if the value is an error we try to call the
# constant by its full name.
my $value = constant($name);
if (index($value, "not a valid") >= 0) {
$name = "Sys::Syslog::$name";
$value = eval { no strict "refs"; &$name };
$value = $@ unless defined $value;
}
$value = -1 if index($value, "not a valid") >= 0;
return defined $value ? $value : -1;
}
# connect_log()
# -----------
# This function acts as a kind of front-end: it tries to connect to
# a syslog service using the selected methods, trying each one in the
# selected order.
#
sub connect_log {
@fallbackMethods = @connectMethods unless scalar @fallbackMethods;
if ($transmit_ok && $current_proto) {
# Retry what we were on, because it has worked in the past.
unshift(@fallbackMethods, $current_proto);
}
$connected = 0;
my @errs = ();
my $proto = undef;
while ($proto = shift @fallbackMethods) {
no strict 'refs';
my $fn = "connect_$proto";
$connected = &$fn(\@errs) if defined &$fn;
last if $connected;
}
$transmit_ok = 0;
if ($connected) {
$current_proto = $proto;
my ($old) = select(SYSLOG); $| = 1; select($old);
} else {
@fallbackMethods = ();
$err_sub->(join "\n\t- ", "no connection to syslog available", @errs);
return undef;
}
}
sub connect_tcp {
my ($errs) = @_;
my $port = $sock_port
|| eval { local $SIG{__DIE__}; getservbyname('syslog', 'tcp') }
|| eval { local $SIG{__DIE__}; getservbyname('syslogng', 'tcp') };
if (!defined $port) {
push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
return 0;
}
my $addr;
if (defined $host) {
$addr = inet_aton($host);
if (!$addr) {
push @$errs, "can't lookup $host";
return 0;
}
} else {
$addr = INADDR_LOOPBACK;
}
$addr = sockaddr_in($port, $addr);
if (!socket(SYSLOG, AF_INET, SOCK_STREAM, SOCKET_IPPROTO_TCP)) {
push @$errs, "tcp socket: $!";
return 0;
}
setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
setsockopt(SYSLOG, SOCKET_IPPROTO_TCP, SOCKET_TCP_NODELAY, 1);
if (!connect(SYSLOG, $addr)) {
push @$errs, "tcp connect: $!";
return 0;
}
$syslog_send = \&_syslog_send_socket;
return 1;
}
sub connect_udp {
my ($errs) = @_;
my $port = $sock_port
|| eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') };
if (!defined $port) {
push @$errs, "getservbyname failed for syslog/udp";
return 0;
}
my $addr;
if (defined $host) {
$addr = inet_aton($host);
if (!$addr) {
push @$errs, "can't lookup $host";
return 0;
}
} else {
$addr = INADDR_LOOPBACK;
}
$addr = sockaddr_in($port, $addr);
if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, SOCKET_IPPROTO_UDP)) {
push @$errs, "udp socket: $!";
return 0;
}
if (!connect(SYSLOG, $addr)) {
push @$errs, "udp connect: $!";
return 0;
}
# We want to check that the UDP connect worked. However the only
# way to do that is to send a message and see if an ICMP is returned
_syslog_send_socket("");
if (!connection_ok()) {
push @$errs, "udp connect: nobody listening";
return 0;
}
$syslog_send = \&_syslog_send_socket;
return 1;
}
sub connect_stream {
my ($errs) = @_;
# might want syslog_path to be variable based on syslog.h (if only
# it were in there!)
$syslog_path = '/dev/conslog' unless defined $syslog_path;
if (!-w $syslog_path) {
push @$errs, "stream $syslog_path is not writable";
return 0;
}
require Fcntl;
if (!sysopen(SYSLOG, $syslog_path, Fcntl::O_WRONLY(), 0400)) {
push @$errs, "stream can't open $syslog_path: $!";
return 0;
}
$syslog_send = \&_syslog_send_stream;
return 1;
}
sub connect_pipe {
my ($errs) = @_;
$syslog_path ||= &_PATH_LOG || "/dev/log";
if (not -w $syslog_path) {
push @$errs, "$syslog_path is not writable";
return 0;
}
if (not open(SYSLOG, ">$syslog_path")) {
push @$errs, "can't write to $syslog_path: $!";
return 0;
}
$syslog_send = \&_syslog_send_pipe;
return 1;
}
sub connect_unix {
my ($errs) = @_;
$syslog_path ||= _PATH_LOG() if length _PATH_LOG();
if (not defined $syslog_path) {
push @$errs, "_PATH_LOG not available in syslog.h and no user-supplied socket path";
return 0;
}
if (not (-S $syslog_path or -c _)) {
push @$errs, "$syslog_path is not a socket";
return 0;
}
my $addr = sockaddr_un($syslog_path);
if (!$addr) {
push @$errs, "can't locate $syslog_path";
return 0;
}
if (!socket(SYSLOG, AF_UNIX, SOCK_STREAM, 0)) {
push @$errs, "unix stream socket: $!";
return 0;
}
if (!connect(SYSLOG, $addr)) {
if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) {
push @$errs, "unix dgram socket: $!";
return 0;
}
if (!connect(SYSLOG, $addr)) {
push @$errs, "unix dgram connect: $!";
return 0;
}
}
$syslog_send = \&_syslog_send_socket;
return 1;
}
sub connect_native {
my ($errs) = @_;
my $logopt = 0;
# reconstruct the numeric equivalent of the options
for my $opt (keys %options) {
$logopt += xlate($opt) if $options{$opt}
}
openlog_xs($ident, $logopt, xlate($facility));
$syslog_send = \&_syslog_send_native;
return 1;
}
sub connect_eventlog {
my ($errs) = @_;
$syslog_xobj = Sys::Syslog::Win32::_install();
$syslog_send = \&Sys::Syslog::Win32::_syslog_send;
return 1;
}
sub connect_console {
my ($errs) = @_;
if (!-w '/dev/console') {
push @$errs, "console is not writable";
return 0;
}
$syslog_send = \&_syslog_send_console;
return 1;
}
# To test if the connection is still good, we need to check if any
# errors are present on the connection. The errors will not be raised
# by a write. Instead, sockets are made readable and the next read
# would cause the error to be returned. Unfortunately the syslog
# 'protocol' never provides anything for us to read. But with
# judicious use of select(), we can see if it would be readable...
sub connection_ok {
return 1 if defined $current_proto and (
$current_proto eq 'native' or $current_proto eq 'console'
or $current_proto eq 'eventlog'
);
my $rin = '';
vec($rin, fileno(SYSLOG), 1) = 1;
my $ret = select $rin, undef, $rin, $sock_timeout;
return ($ret ? 0 : 1);
}
sub disconnect_log {
$connected = 0;
$syslog_send = undef;
if (defined $current_proto and $current_proto eq 'native') {
closelog_xs();
unshift @fallbackMethods, $current_proto;
$current_proto = undef;
return 1;
}
elsif (defined $current_proto and $current_proto eq 'eventlog') {
$syslog_xobj->Close();
unshift @fallbackMethods, $current_proto;
$current_proto = undef;
return 1;
}
return close SYSLOG;
}
#
# Wrappers around eval() that makes sure that nobody, ever knows that
# we wanted to poke & test if something was here or not. This is needed
# because some applications are trying to be too smart, install their
# own __DIE__ handler, and mysteriously, things are starting to fail
# when they shouldn't. SpamAssassin among them.
#
sub silent_eval (&) {
local($SIG{__DIE__}, $SIG{__WARN__}, $@);
return eval { $_[0]->() }
}
sub can_load_sys_syslog_win32 {
my ($verbose) = @_;
local($SIG{__DIE__}, $SIG{__WARN__}, $@);
(my $module_path = __FILE__) =~ s:Syslog.pm$:Syslog/Win32.pm:;
my $loaded = eval { require $module_path } ? 1 : 0;
warn $@ if not $loaded and $verbose;
return $loaded
}
"Eighth Rule: read the documentation."
__END__
=head1 NAME
Sys::Syslog - Perl interface to the UNIX syslog(3) calls
=head1 VERSION
This is the documentation of version 0.36
=head1 SYNOPSIS
use Sys::Syslog; # all except setlogsock()
use Sys::Syslog qw(:standard :macros); # standard functions & macros
openlog($ident, $logopt, $facility); # don't forget this
syslog($priority, $format, @args);
$oldmask = setlogmask($mask_priority);
closelog();
=head1 DESCRIPTION
C is an interface to the UNIX C program.
Call C with a string priority and a list of C args
just like C.
=head1 EXPORTS
C exports the following C tags:
=over 4
=item *
C<:standard> exports the standard C functions:
openlog closelog setlogmask syslog
=item *
C<:extended> exports the Perl specific functions for C:
setlogsock
=item *
C<:macros> exports the symbols corresponding to most of your C
macros and the C and C functions.
See L<"CONSTANTS"> for the supported constants and their meaning.
=back
By default, C exports the symbols from the C<:standard> tag.
=head1 FUNCTIONS
=over 4
=item B
Opens the syslog.
C<$ident> is prepended to every message. C<$logopt> contains zero or
more of the options detailed below. C<$facility> specifies the part
of the system to report about, for example C or C:
see L<"Facilities"> for a list of well-known facilities, and your
C documentation for the facilities available in your system.
Check L<"SEE ALSO"> for useful links. Facility can be given as a string
or a numeric macro.
This function will croak if it can't connect to the syslog daemon.
Note that C now takes three arguments, just like C.
B before calling C.>
B
=over 4
=item *
C - This option is ignored, since the failover mechanism will drop
down to the console automatically if all other media fail.
=item *
C - Open the connection immediately (normally, the connection is
opened when the first message is logged).
=item *
C - When set to true, no end of line character (C<\n>) will be
appended to the message. This can be useful for some syslog daemons.
Added in C 0.29.
=item *
C - When set to true, C and C will only
emit warnings instead of dying if the connection to the syslog can't
be established. Added in C 0.15.
=item *
C - When set to true, no C character (C<\0>) will be
appended to the message. This can be useful for some syslog daemons.
Added in C 0.29.
=item *
C - Don't wait for child processes that may have been created
while logging the message. (The GNU C library does not create a child
process, so this option has no effect on Linux.)
=item *
C - Write the message to standard error output as well to the
system log. Added in C 0.22.
=item *
C - Include PID with each message.
=back
B
Open the syslog with options C and C, and with facility C:
openlog($name, "ndelay,pid", "local0");
Same thing, but this time using the macro corresponding to C:
openlog($name, "ndelay,pid", LOG_LOCAL0);
=item B
=item B
If C<$priority> permits, logs C<$message> or C
with the addition that C<%m> in $message or C<$format> is replaced with
C<"$!"> (the latest error message).
C<$priority> can specify a level, or a level and a facility. Levels and
facilities can be given as strings or as macros. When using the C
mechanism, priorities C and C are mapped to event type
C, C and C to C and C to
C to C.
If you didn't use C before using C, C will
try to guess the C<$ident> by extracting the shortest prefix of
C<$format> that ends in a C<":">.
B
# informational level
syslog("info", $message);
syslog(LOG_INFO, $message);
# information level, Local0 facility
syslog("info|local0", $message);
syslog(LOG_INFO|LOG_LOCAL0, $message);
=over 4
=item B
C version v0.07 and older passed the C<$message> as the
formatting string to C even when no formatting arguments
were provided. If the code calling C might execute with
older versions of this module, make sure to call the function as
C instead of C. This protects against hostile formatting sequences that
might show up if $message contains tainted data.
=back
=item B
Sets the log mask for the current process to C<$mask_priority> and
returns the old mask. If the mask argument is 0, the current log mask
is not modified. See L<"Levels"> for the list of available levels.
You can use the C function to allow all levels up to a
given priority (but it only accept the numeric macros as arguments).
B
Only log errors:
setlogmask( LOG_MASK(LOG_ERR) );
Log everything except informational messages:
setlogmask( ~(LOG_MASK(LOG_INFO)) );
Log critical messages, errors and warnings:
setlogmask( LOG_MASK(LOG_CRIT)
| LOG_MASK(LOG_ERR)
| LOG_MASK(LOG_WARNING) );
Log all messages up to debug:
setlogmask( LOG_UPTO(LOG_DEBUG) );
=item B
Sets the socket type and options to be used for the next call to C
or C. Returns true on success, C on failure.
Being Perl-specific, this function has evolved along time. It can currently
be called as follow:
=over
=item *
C
=item *
C (added in Perl 5.004_02)
=item *
C (added in
C 0.25)
=item *
C (added in C 0.28)
=back
The available options are:
=over
=item *
C - equivalent to C<$sock_type>, selects the socket type (or
"mechanism"). An array reference can be passed to specify several
mechanisms to try, in the given order.
=item *
C - equivalent to C<$stream_location>, sets the stream location.
Defaults to standard Unix location, or C<_PATH_LOG>.
=item *
C - equivalent to C<$sock_timeout>, sets the socket timeout
in seconds. Defaults to 0 on all systems except S where it
is set to 0.25 sec.
=item *
C - sets the hostname to send the messages to. Defaults to
the local host.
=item *
C - sets the TCP or UDP port to connect to. Defaults to the
first standard syslog port available on the system.
=back
The available mechanisms are:
=over
=item *
C<"native"> - use the native C functions from your C library
(added in C 0.15).
=item *
C<"eventlog"> - send messages to the Win32 events logger (Win32 only;
added in C 0.19).
=item *
C<"tcp"> - connect to a TCP socket, on the C or C
service. See also the C, C and C options.
=item *
C<"udp"> - connect to a UDP socket, on the C service.
See also the C, C and C options.
=item *
C<"inet"> - connect to an INET socket, either TCP or UDP, tried in that
order. See also the C, C and C options.
=item *
C<"unix"> - connect to a UNIX domain socket (in some systems a character
special device). The name of that socket is given by the C option
or, if omitted, the value returned by the C<_PATH_LOG> macro (if your
system defines it), F or F, whichever is writable.
=item *
C<"stream"> - connect to the stream indicated by the C option, or,
if omitted, the value returned by the C<_PATH_LOG> macro (if your system
defines it), F or F, whichever is writable. For
example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">.
=item *
C<"pipe"> - connect to the named pipe indicated by the C option,
or, if omitted, to the value returned by the C<_PATH_LOG> macro (if your
system defines it), or F (added in C 0.21).
HP-UX is a system which uses such a named pipe.
=item *
C<"console"> - send messages directly to the console, as for the C<"cons">
option of C.
=back
The default is to try C, C, C, C, C, C,
C.
Under systems with the Win32 API, C will be added as the first
mechanism to try if C is available.
Giving an invalid value for C<$sock_type> will C.
B
Select the UDP socket mechanism:
setlogsock("udp");
Send messages using the TCP socket mechanism on a custom port:
setlogsock({ type => "tcp", port => 2486 });
Send messages to a remote host using the TCP socket mechanism:
setlogsock({ type => "tcp", host => $loghost });
Try the native, UDP socket then UNIX domain socket mechanisms:
setlogsock(["native", "udp", "unix"]);
=over
=item B
Now that the "native" mechanism is supported by C and selected
by default, the use of the C function is discouraged because
other mechanisms are less portable across operating systems. Authors of
modules and programs that use this function, especially its cargo-cult form
C, are advised to remove any occurrence of it unless they
specifically want to use a given mechanism (like TCP or UDP to connect to
a remote host).
=back
=item B
Closes the log file and returns true on success.
=back
=head1 THE RULES OF SYS::SYSLOG
I
You do not call C.
I
You B call C.
I
The program crashes, Cs, calls C, the log is over.
I
One facility, one priority.
I
One log at a time.
I
No C before C.
I
Logs will go on as long as they have to.
I
If this is your first use of Sys::Syslog, you must read the doc.
=head1 EXAMPLES
An example:
openlog($program, 'cons,pid', 'user');
syslog('info', '%s', 'this is another test');
syslog('mail|warning', 'this is a better test: %d', time);
closelog();
syslog('debug', 'this is the last test');
Another example:
openlog("$program $$", 'ndelay', 'user');
syslog('notice', 'fooprogram: this is really done');
Example of use of C<%m>:
$! = 55;
syslog('info', 'problem was %m'); # %m == $! in syslog(3)
Log to UDP port on C<$remotehost> instead of logging locally:
setlogsock("udp", $remotehost);
openlog($program, 'ndelay', 'user');
syslog('info', 'something happened over here');
=head1 CONSTANTS
=head2 Facilities
=over 4
=item *
C - audit daemon (IRIX); falls back to C
=item *
C - security/authorization messages
=item *
C - security/authorization messages (private)
=item *
C - C output (FreeBSD); falls back to C
=item *
C - clock daemons (B and B)
=item *
C - system daemons without separate facility value
=item *
C - FTP daemon
=item *
C - kernel messages
=item *
C - installer subsystem (Mac OS X); falls back to C
=item *
C - launchd - general bootstrap daemon (Mac OS X);
falls back to C
=item *
C - logalert facility; falls back to C
=item *
C through C - reserved for local use
=item *
C - line printer subsystem
=item *
C - mail subsystem
=item *
C - NetInfo subsystem (Mac OS X); falls back to C
=item *
C - USENET news subsystem
=item *
C - NTP subsystem (FreeBSD, NetBSD); falls back to C
=item *
C - Remote Access Service (VPN / PPP) (Mac OS X);
falls back to C
=item *
C - remote authentication/authorization (Mac OS X);
falls back to C
=item *
C - security subsystems (firewalling, etc.) (FreeBSD);
falls back to C
=item *
C - messages generated internally by B
=item *
C (default) - generic user-level messages
=item *
C - UUCP subsystem
=back
=head2 Levels
=over 4
=item *
C - system is unusable
=item *
C - action must be taken immediately
=item *
C - critical conditions
=item *
C - error conditions
=item *
C - warning conditions
=item *
C - normal, but significant, condition
=item *
C - informational message
=item *
C - debug-level message
=back
=head1 DIAGNOSTICS
=over
=item C
B<(F)> You gave C an invalid value for C<$sock_type>.
=item C
B<(W)> You asked C to use the Win32 event logger but the
operating system running the program isn't Win32 or does not provides Win32
compatible facilities.
=item C
B<(F)> C failed to connect to the specified socket.
=item C
B<(W)> You asked C to use a stream socket, but the given
path is not writable.
=item C
B<(W)> You asked C to use a stream socket, but didn't
provide a path, and C was unable to find an appropriate one.
=item C
B<(W)> You asked C to use a TCP socket, but the service
is not available on the system.
=item C
B<(F)> You forgot to give C the indicated argument.
=item C
B<(F)> You specified an invalid level or facility.
=item C
B<(F)> You specified too many levels.
=item C
B<(F)> You specified too many facilities.
=item C
B<(F)> You forgot to specify a level.
=item C
B<(W)> You asked C to use a UDP socket, but the service
is not available on the system.
=item C
B<(W)> You asked C to use a UNIX socket, but C
was unable to find an appropriate an appropriate device.
=back
=head1 HISTORY
C is a core module, part of the standard Perl distribution
since 1990. At this time, modules as we know them didn't exist, the
Perl library was a collection of F<.pl> files, and the one for sending
syslog messages with was simply F, included with Perl 3.0.
It was converted as a module with Perl 5.0, but had a version number
only starting with Perl 5.6. Here is a small table with the matching
Perl and C versions.
Sys::Syslog Perl
----------- ----
undef 5.0.0 ~ 5.5.4
0.01 5.6.*
0.03 5.8.0
0.04 5.8.1, 5.8.2, 5.8.3
0.05 5.8.4, 5.8.5, 5.8.6
0.06 5.8.7
0.13 5.8.8
0.22 5.10.0
0.27 5.8.9, 5.10.1 ~ 5.14.*
0.29 5.16.*
0.32 5.18.*
0.33 5.20.*
0.33 5.22.*
=head1 SEE ALSO
=head2 Other modules
L - Perl implementation of the Log4j API
L - Dispatches messages to one or more outputs
L - Report a problem, with exceptions and language support
=head2 Manual Pages
L
SUSv3 issue 6, IEEE Std 1003.1, 2004 edition,
L
GNU C Library documentation on syslog,
L
FreeBSD documentation on syslog,
L
Solaris 11 documentation on syslog,
L
Mac OS X documentation on syslog,
L
IRIX documentation on syslog,
L
AIX 5L 5.3 documentation on syslog,
L
HP-UX 11i documentation on syslog,
L
Tru64 documentation on syslog,
L
Stratus VOS 15.1,
L
=head2 RFCs
I, L
-- Please note that this is an informational RFC, and therefore does not
specify a standard of any kind.
I, L
=head2 Articles
I, L
=head2 Event Log
Windows Event Log,
L
=head1 AUTHORS & ACKNOWLEDGEMENTS
Tom Christiansen EFE and Larry Wall
EFE.
UNIX domain sockets added by Sean Robinson
EFE with support from Tim Bunce
EFE and the C mailing list.
Dependency on F replaced with XS code by Tom Hughes
EFE.
Code for Cs regenerated by Nicholas Clark EFE.
Failover to different communication modes by Nick Williams
EFE.
Extracted from core distribution for publishing on the CPAN by
SEbastien Aperghis-Tramoni Esebastien (at) aperghis.netE