@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(openlog closelog setlogmask syslog);
@EXPORT_OK = qw(setlogsock);
# it would be nice to try stream/unix first, since that will be
# most efficient. However streams are dodgy - see _syslog_send_stream
#my @connectMethods = ( 'stream', 'unix', 'tcp', 'udp' );
my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
if ($^O
=~ /^(freebsd|linux)$/) {
@connectMethods = grep { $_ ne 'udp' } @connectMethods;
my @defaultMethods = @connectMethods;
my $current_proto = undef;
# Tom Christiansen <tchrist@convex.com>
# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
# NOTE: openlog now takes three arguments, just like openlog(3)
# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>
Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
use Sys::Syslog; # all except setlogsock, or:
use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
openlog $ident, $logopt, $facility;
syslog $priority, $format, @args;
$oldmask = setlogmask $mask_priority;
Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
Call C<syslog()> with a string priority and a list of C<printf()> args
Syslog provides the functions:
=item openlog $ident, $logopt, $facility
I<$ident> is prepended to every message. I<$logopt> contains zero or
more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is
ignored, since the failover mechanism will drop down to the console
automatically if all other media fail. I<$facility> specifies the
=item syslog $priority, $format, @args
If I<$priority> permits, logs I<($format, @args)>
printed as by C<printf(3V)>, with the addition that I<%m>
is replaced with C<"$!"> (the latest error message).
=item setlogmask $mask_priority
Sets log mask I<$mask_priority> and returns the old mask.
=item setlogsock $sock_type [$stream_location] (added in 5.004_02)
Sets the socket type to be used for the next call to
C<openlog()> or C<syslog()> and returns TRUE on success,
A value of 'unix' will connect to the UNIX domain socket returned by
the C<_PATH_LOG> macro (if your system defines it) in F<syslog.ph>. A
value of 'stream' will connect to the stream indicated by the pathname
provided as the optional second parameter. A value of 'inet' will
connect to an INET socket (either tcp or udp, tried in that order)
returned by getservbyname(). 'tcp' and 'udp' can also be given as
values. The value 'console' will send messages directly to the
console, as for the 'cons' option in the logopts in openlog().
A reference to an array can also be passed as the first parameter.
When this calling method is used, the array should contain a list of
sock_types which are attempted in order.
The default is to try tcp, udp, unix, stream, console.
Giving an invalid value for sock_type will croak.
Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
openlog($program, 'cons,pid', 'user');
syslog('info', 'this is another test');
syslog('mail|warning', 'this is a better test: %d', time);
syslog('debug', 'this is the last test');
openlog("$program $$", 'ndelay', 'user');
syslog('notice', 'fooprogram: this is really done');
syslog('info', 'problem was %m'); # %m == $! in syslog(3)
Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
E<lt>F<larry@wall.org>E<gt>.
UNIX domain sockets added by Sean Robinson
E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
E<lt>F<tom@compton.nu>E<gt>.
Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
Failover to different communication modes by Nick Williams
E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
# This AUTOLOAD is used to 'autoload' constants from the constant()
($constname = $AUTOLOAD) =~ s/.*:://;
croak
"&Sys::Syslog::constant not defined" if $constname eq 'constant';
my ($error, $val) = constant
($constname);
*$AUTOLOAD = sub { $val };
bootstrap Sys
::Syslog
$VERSION;
$maskpri = &LOG_UPTO
(&LOG_DEBUG
);
($ident, $logopt, $facility) = @_; # package vars
$lo_pid = $logopt =~ /\bpid\b/;
$lo_ndelay = $logopt =~ /\bndelay\b/;
$lo_nowait = $logopt =~ /\bnowait\b/;
return 1 unless $lo_ndelay;
local($oldmask) = $maskpri;
&disconnect
if $connected;
@connectMethods = @defaultMethods;
if (ref $setsock eq 'ARRAY') {
@connectMethods = @
$setsock;
} elsif (lc($setsock) eq 'stream') {
$syslog_path = '/dev/log' unless($syslog_path);
carp
"stream passed to setlogsock, but $syslog_path is not writable";
@connectMethods = ( 'stream' );
} elsif (lc($setsock) eq 'unix') {
if (length _PATH_LOG
() && !defined $syslog_path) {
$syslog_path = _PATH_LOG
();
@connectMethods = ( 'unix' );
carp
'unix passed to setlogsock, but path not available';
} elsif (lc($setsock) eq 'tcp') {
if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
@connectMethods = ( 'tcp' );
carp
"tcp passed to setlogsock, but tcp service unavailable";
} elsif (lc($setsock) eq 'udp') {
if (getservbyname('syslog', 'udp')) {
@connectMethods = ( 'udp' );
carp
"udp passed to setlogsock, but udp service unavailable";
} elsif (lc($setsock) eq 'inet') {
@connectMethods = ( 'tcp', 'udp' );
} elsif (lc($setsock) eq 'console') {
@connectMethods = ( 'console' );
carp
"Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
local($priority) = shift;
local($message, $whoami);
local(@words, $num, $numpri, $numfac, $sum);
local($facility) = $facility; # may need to change temporarily.
croak
"syslog: expected both priority and mask" unless $mask && $priority;
@words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
$num = &xlate
($_); # Translate word to number.
if (/^kern$/ || $num < 0) {
croak
"syslog: invalid level/facility: $_";
elsif ($num <= &LOG_PRIMASK
) {
croak
"syslog: too many levels given: $_" if defined($numpri);
return 0 unless &LOG_MASK
($numpri) & $maskpri;
croak
"syslog: too many facilities given: $_" if defined($numfac);
croak
"syslog: level must be given" unless defined($numpri);
if (!defined($numfac)) { # Facility not specified in this call.
$facility = 'user' unless $facility;
$numfac = &xlate
($facility);
&connect unless $connected;
if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
($whoami = getpwuid($<)) ||
$whoami .= "[$$]" if $lo_pid;
$mask .= "\n" unless $mask =~ /\n$/;
$message = sprintf ($mask, @_);
$sum = $numpri + $numfac;
my $buf = "<$sum>$whoami: $message\0";
# 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
while (scalar @fallbackMethods || $syslog_send) {
if ($failed && (time - $fail_time) > 60) {
# it's been a while... maybe things have been fixed
$transmit_ok = 0; # make it look like a fresh attempt
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;
&connect unless $connected;
$failed = undef if ($current_proto && $failed && $current_proto eq $failed);
if (&{$syslog_send}($buf)) {
# typically doesn't happen, since errors are rare from write().
# could not send, could not fallback onto a working
# connection method. Lose.
sub _syslog_send_console
{
chop($buf); # delete the NUL from the end
# The console print is a method which could block
# so we do it in a child process and always return success
if (waitpid($pid, 0) >= 0) {
# it's possible that the caller has other
# plans for SIGCHLD, so let's not interfere
if (open(CONS
, ">/dev/console")) {
my $ret = print CONS
$buf . "\r";
exit ($ret) if defined $pid;
sub _syslog_send_stream
{
# 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_socket
{
return syswrite(SYSLOG
, $buf, length($buf));
#return send(SYSLOG, $buf, 0);
$name = "LOG_$name" unless $name =~ /^LOG_/;
$name = "Sys::Syslog::$name";
# Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
my $value = eval { &$name };
defined $value ?
$value : -1;
@fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
if ($transmit_ok && $current_proto) {
# Retry what we were on, because it's worked in the past.
unshift(@fallbackMethods, $current_proto);
while ($proto = shift(@fallbackMethods)) {
my $fn = "connect_$proto";
$connected = &$fn(\
@errs) unless (!defined &$fn);
local($old) = select(SYSLOG
); $| = 1; select($old);
foreach my $err (@errs) {
croak
"no connection to syslog available";
my($host_uniq) = Sys
::Hostname
::hostname
();
($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
my $tcp = getprotobyname('tcp');
push(@
{$errs}, "getprotobyname failed for tcp");
my $syslog = getservbyname('syslog','tcp');
$syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
push(@
{$errs}, "getservbyname failed for tcp");
my $this = sockaddr_in
($syslog, INADDR_ANY
);
my $that = sockaddr_in
($syslog, inet_aton
($host));
push(@
{$errs}, "can't lookup $host");
if (!socket(SYSLOG
,AF_INET
,SOCK_STREAM
,$tcp)) {
push(@
{$errs}, "tcp socket: $!");
setsockopt(SYSLOG
, SOL_SOCKET
, SO_KEEPALIVE
, 1);
setsockopt(SYSLOG
, IPPROTO_TCP
, TCP_NODELAY
, 1);
if (!CORE
::connect(SYSLOG
,$that)) {
push(@
{$errs}, "tcp connect: $!");
$syslog_send = \
&_syslog_send_socket
;
my($host_uniq) = Sys
::Hostname
::hostname
();
($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
my $udp = getprotobyname('udp');
push(@
{$errs}, "getprotobyname failed for udp");
my $syslog = getservbyname('syslog','udp');
push(@
{$errs}, "getservbyname failed for udp");
my $this = sockaddr_in
($syslog, INADDR_ANY
);
my $that = sockaddr_in
($syslog, inet_aton
($host));
push(@
{$errs}, "can't lookup $host");
if (!socket(SYSLOG
,AF_INET
,SOCK_DGRAM
,$udp)) {
push(@
{$errs}, "udp socket: $!");
if (!CORE
::connect(SYSLOG
,$that)) {
push(@
{$errs}, "udp connect: $!");
# 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
push(@
{$errs}, "udp connect: nobody listening");
$syslog_send = \
&_syslog_send_socket
;
# might want syslog_path to be variable based on syslog.h (if only
$syslog_path = '/dev/conslog';
push(@
{$errs}, "stream $syslog_path is not writable");
if (!open(SYSLOG
, ">" . $syslog_path)) {
push(@
{$errs}, "stream can't open $syslog_path: $!");
$syslog_send = \
&_syslog_send_stream
;
if (length _PATH_LOG
()) {
$syslog_path = _PATH_LOG
();
push(@
{$errs}, "_PATH_LOG not available in syslog.h");
my $that = sockaddr_un
($syslog_path);
push(@
{$errs}, "can't locate $syslog_path");
if (!socket(SYSLOG
,AF_UNIX
,SOCK_STREAM
,0)) {
push(@
{$errs}, "unix stream socket: $!");
if (!CORE
::connect(SYSLOG
,$that)) {
if (!socket(SYSLOG
,AF_UNIX
,SOCK_DGRAM
,0)) {
push(@
{$errs}, "unix dgram socket: $!");
if (!CORE
::connect(SYSLOG
,$that)) {
push(@
{$errs}, "unix dgram connect: $!");
$syslog_send = \
&_syslog_send_socket
;
if (!-w
'/dev/console') {
push(@
{$errs}, "console is not writable");
$syslog_send = \
&_syslog_send_console
;
# 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...
return 1 if (defined $current_proto && $current_proto eq 'console');
vec($rin, fileno(SYSLOG
), 1) = 1;
my $ret = select $rin, undef, $rin, 0;