X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ee8c7f5465f003860e2347a2946abacac39bd9b9..caccce6a1f0bee322fe569bba47ff533e3727c06:/ext/Sys/Syslog/Syslog.pm diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index c7ce3de..d06ac17 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -1,28 +1,31 @@ package Sys::Syslog; -require 5.000; +require 5.006; require Exporter; -require DynaLoader; use Carp; - -@ISA = qw(Exporter DynaLoader); -@EXPORT = qw(openlog closelog setlogmask syslog); -@EXPORT_OK = qw(setlogsock); -$VERSION = '0.01'; - -use Socket; +use strict; + +our @ISA = qw(Exporter); +our @EXPORT = qw(openlog closelog setlogmask syslog); +our @EXPORT_OK = qw(setlogsock); +our $VERSION = '0.08'; + +# 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 = ( 'tcp', 'udp', 'unix', 'stream', 'console' ); +if ($^O =~ /^(freebsd|linux)$/) { + @connectMethods = grep { $_ ne 'udp' } @connectMethods; +} +my @defaultMethods = @connectMethods; +my $syslog_path = undef; +my $transmit_ok = 0; +my $current_proto = undef; +my $failed = undef; +my $fail_time = undef; +our ($connected, @fallbackMethods, $syslog_send, $host); + +use Socket ':all'; use Sys::Hostname; -# adapted from syslog.pl -# -# Tom Christiansen -# modified to use sockets by Larry Wall -# NOTE: openlog now takes three arguments, just like openlog(3) -# Modified to add UNIX domain sockets by Sean Robinson -# with support from Tim Bunce and the perl5-porters mailing list -# Modified to use an XS backend instead of syslog.ph by Tom Hughes - -# Todo: enable connect to try all three types before failing (auto setlogsock)? - =head1 NAME Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls @@ -33,7 +36,7 @@ Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock setlogsock $sock_type; - openlog $ident, $logopt, $facility; + openlog $ident, $logopt, $facility; # don't forget this syslog $priority, $format, @args; $oldmask = setlogmask $mask_priority; closelog; @@ -46,37 +49,63 @@ just like C. Syslog provides the functions: -=over +=over 4 =item openlog $ident, $logopt, $facility -I<$ident> is prepended to every message. -I<$logopt> contains zero or more of the words I, I, I, I. -I<$facility> specifies the part of the system +Opens the syslog. +I<$ident> is prepended to every message. I<$logopt> contains zero or +more of the words I, I, I. 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 +part of the system to report about, for example LOG_USER or LOG_LOCAL0: +see your C documentation for the facilities available in +your system. This function will croak if it can't connect to the syslog +daemon. + +B + +=item syslog $priority, $message =item syslog $priority, $format, @args -If I<$priority> permits, logs I<($format, @args)> -printed as by C, with the addition that I<%m> -is replaced with C<"$!"> (the latest error message). +If I<$priority> permits, logs I<$message> or I +with the addition that I<%m> in $message or $format is replaced with +C<"$!"> (the latest error message). + +If you didn't use openlog() before using syslog(), syslog will try to +guess the I<$ident> by extracting the shortest prefix of I<$format> +that ends in a ":". =item setlogmask $mask_priority Sets log mask I<$mask_priority> and returns the old mask. -=item setlogsock $sock_type (added in 5.004_02) +=item setlogsock $sock_type [$stream_location] (added in 5.004_02) Sets the socket type to be used for the next call to C or C and returns TRUE on success, undef on failure. -A value of 'unix' will connect to the UNIX domain socket returned by the -C<_PATH_LOG> macro (if you system defines it) in F. A value of -'inet' will connect to an INET socket returned by getservbyname(). If -C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef. Any -other value croaks. +A value of 'unix' will connect to the UNIX domain socket (in some +systems a character special device) returned by the C<_PATH_LOG> macro +(if your system defines it), or F or F, +whatever is writable. A value of 'stream' will connect to the stream +indicated by the pathname provided as the optional second parameter. +(For example Solaris and IRIX require 'stream' instead of 'unix'.) +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 for the INET socket to be used. +The default is to try tcp, udp, unix, stream, console. + +Giving an invalid value for sock_type will croak. =item closelog @@ -89,7 +118,7 @@ Note that C now takes three arguments, just like C. =head1 EXAMPLES openlog($program, 'cons,pid', 'user'); - syslog('info', 'this is another test'); + syslog('info', '%s', 'this is another test'); syslog('mail|warning', 'this is a better test: %d', time); closelog(); @@ -103,6 +132,12 @@ Note that C now takes three arguments, just like C. $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) + # Log to UDP port on $remotehost instead of logging locally + setlogsock('udp'); + $Sys::Syslog::host = $remotehost; + openlog($program, 'ndelay', 'user'); + syslog('info', 'something happened over here'); + =head1 SEE ALSO L @@ -113,84 +148,133 @@ Tom Christiansen EFE and Larry Wall EFE. UNIX domain sockets added by Sean Robinson -EFE with support from Tim Bunce +EFE with support from Tim Bunce EFE and the perl5-porters mailing list. Dependency on F replaced with XS code by Tom Hughes EFE. +Code for constant()s regenerated by Nicholas Clark EFE. + +Failover to different communication modes by Nick Williams +EFE. + =cut sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. - + my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; - croak "& not defined" if $constname eq 'constant'; - my $val = constant($constname); - if ($! != 0) { - croak "Your vendor has not defined Sys::Syslog macro $constname"; + croak "&Sys::Syslog::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { + croak $error; } + no strict 'refs'; *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } -bootstrap Sys::Syslog $VERSION; +require XSLoader; +XSLoader::load('Sys::Syslog', $VERSION); -$maskpri = &LOG_UPTO(&LOG_DEBUG); +our $maskpri = &LOG_UPTO(&LOG_DEBUG); sub openlog { - ($ident, $logopt, $facility) = @_; # package vars - $lo_pid = $logopt =~ /\bpid\b/; - $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_cons = $logopt =~ /\bcons\b/; - $lo_nowait = $logopt =~ /\bnowait\b/; + our ($ident, $logopt, $facility) = @_; # package vars + our $lo_pid = $logopt =~ /\bpid\b/; + our $lo_ndelay = $logopt =~ /\bndelay\b/; + our $lo_nowait = $logopt =~ /\bnowait\b/; return 1 unless $lo_ndelay; &connect; } sub closelog { - $facility = $ident = ''; + our $facility = our $ident = ''; &disconnect; } sub setlogmask { - local($oldmask) = $maskpri; + my $oldmask = $maskpri; $maskpri = shift; $oldmask; } sub setlogsock { - local($setsock) = shift; + my $setsock = shift; + $syslog_path = shift; &disconnect if $connected; - if (lc($setsock) eq 'unix') { - if (length _PATH_LOG()) { - $sock_type = 1; - } else { - return undef; + $transmit_ok = 0; + @fallbackMethods = (); + @connectMethods = @defaultMethods; + if (ref $setsock eq 'ARRAY') { + @connectMethods = @$setsock; + } elsif (lc($setsock) eq 'stream') { + unless (defined $syslog_path) { + my @try = qw(/dev/log /dev/conslog); + if (length &_PATH_LOG) { # Undefined _PATH_LOG is "". + unshift @try, &_PATH_LOG; + } + for my $try (@try) { + if (-w $try) { + $syslog_path = $try; + last; + } + } + carp "stream passed to setlogsock, but could not find any device" + unless defined $syslog_path; } - } elsif (lc($setsock) eq 'inet') { - if (getservbyname('syslog','udp')) { - undef($sock_type); + unless (-w $syslog_path) { + carp "stream passed to setlogsock, but $syslog_path is not writable"; + return undef; + } else { + @connectMethods = ( 'stream' ); + } + } elsif (lc($setsock) eq 'unix') { + if (length _PATH_LOG() && !defined $syslog_path) { + $syslog_path = _PATH_LOG(); + @connectMethods = ( 'unix' ); } else { - return undef; + carp 'unix passed to setlogsock, but path not available'; + return undef; } + } elsif (lc($setsock) eq 'tcp') { + if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) { + @connectMethods = ( 'tcp' ); + } else { + carp "tcp passed to setlogsock, but tcp service unavailable"; + return undef; + } + } elsif (lc($setsock) eq 'udp') { + if (getservbyname('syslog', 'udp')) { + @connectMethods = ( 'udp' ); + } else { + carp "udp passed to setlogsock, but udp service unavailable"; + return undef; + } + } elsif (lc($setsock) eq 'inet') { + @connectMethods = ( 'tcp', 'udp' ); + } elsif (lc($setsock) eq 'console') { + @connectMethods = ( 'console' ); } else { - croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'"; } return 1; } sub syslog { - local($priority) = shift; - local($mask) = shift; - local($message, $whoami); - local(@words, $num, $numpri, $numfac, $sum); + my $priority = shift; + my $mask = shift; + my ($message, $whoami); + my (@words, $num, $numpri, $numfac, $sum); + our $facility; local($facility) = $facility; # may need to change temporarily. - croak "syslog: expected both priority and mask" unless $mask && $priority; + croak "syslog: expecting argument \$priority" unless $priority; + croak "syslog: expecting argument \$format" unless $mask; @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". undef $numpri; @@ -221,7 +305,7 @@ sub syslog { &connect unless $connected; - $whoami = $ident; + $whoami = our $ident; if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { $whoami = $1; @@ -234,69 +318,291 @@ sub syslog { ($whoami = 'syslog'); } - $whoami .= "[$$]" if $lo_pid; + $whoami .= "[$$]" if our $lo_pid; - $mask =~ s/%m/$!/g; + $mask =~ s/(?$whoami: $message\0",0)) { - if ($lo_cons) { - if ($pid = fork) { - unless ($lo_nowait) { - $died = waitpid($pid, 0); - } + 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 + # 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(); + $transmit_ok = 0; # make it look like a fresh attempt + &connect; + } + 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(); + } + &connect unless $connected; + $failed = undef if ($current_proto && $failed && $current_proto eq $failed); + if ($syslog_send) { + if (&{$syslog_send}($buf)) { + $transmit_ok++; + return 1; } - else { - if (open(CONS,">/dev/console")) { - print CONS "<$facility.$priority>$whoami: $message\r"; - close CONS; - } - exit if defined $pid; # if fork failed, we're parent + # typically doesn't happen, since errors are rare from write(). + disconnect(); + } + } + # could not send, could not fallback onto a working + # connection method. Lose. + return 0; +} + +sub _syslog_send_console { + my ($buf) = @_; + 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 + # to the caller. + if (my $pid = fork) { + our $lo_nowait; + if ($lo_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"; + exit ($ret) if defined $pid; + close CONS; + } + exit 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_socket { + my ($buf) = @_; + return syswrite(SYSLOG, $buf, length($buf)); + #return send(SYSLOG, $buf, 0); +} + sub xlate { - local($name) = @_; + my($name) = @_; + return $name+0 if $name =~ /^\s*\d+\s*$/; $name = uc $name; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "Sys::Syslog::$name"; - eval { &$name } || -1; + # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero. + my $value = eval { no strict 'refs'; &$name }; + defined $value ? $value : -1; } sub connect { + @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); + } + $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 = (); + foreach my $err (@errs) { + carp $err; + } + croak "no connection to syslog available"; + } +} + +sub connect_tcp { + my ($errs) = @_; unless ($host) { require Sys::Hostname; my($host_uniq) = Sys::Hostname::hostname(); ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } - unless ( $sock_type ) { - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); - socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $!"; + my $tcp = getprotobyname('tcp'); + if (!defined $tcp) { + push(@{$errs}, "getprotobyname failed for tcp"); + return 0; + } + my $syslog = getservbyname('syslog','tcp'); + $syslog = getservbyname('syslogng','tcp') unless (defined $syslog); + if (!defined $syslog) { + push(@{$errs}, "getservbyname failed for tcp"); + return 0; + } + + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host)); + if (!$that) { + push(@{$errs}, "can't lookup $host"); + return 0; + } + if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) { + push(@{$errs}, "tcp socket: $!"); + return 0; + } + setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1); + setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1); + if (!CORE::connect(SYSLOG,$that)) { + push(@{$errs}, "tcp connect: $!"); + return 0; + } + $syslog_send = \&_syslog_send_socket; + return 1; +} + +sub connect_udp { + my ($errs) = @_; + unless ($host) { + require Sys::Hostname; + my($host_uniq) = Sys::Hostname::hostname(); + ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) + } + my $udp = getprotobyname('udp'); + if (!defined $udp) { + push(@{$errs}, "getprotobyname failed for udp"); + return 0; + } + my $syslog = getservbyname('syslog','udp'); + if (!defined $syslog) { + push(@{$errs}, "getservbyname failed for udp"); + return 0; + } + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host)); + if (!$that) { + push(@{$errs}, "can't lookup $host"); + return 0; + } + if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) { + push(@{$errs}, "udp socket: $!"); + return 0; + } + if (!CORE::connect(SYSLOG,$that)) { + 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'; + if (!-w $syslog_path) { + push(@{$errs}, "stream $syslog_path is not writable"); + return 0; + } + if (!open(SYSLOG, ">" . $syslog_path)) { + push(@{$errs}, "stream can't open $syslog_path: $!"); + return 0; + } + $syslog_send = \&_syslog_send_stream; + return 1; +} + +sub connect_unix { + my ($errs) = @_; + if (length _PATH_LOG()) { + $syslog_path = _PATH_LOG(); } else { - my $syslog = _PATH_LOG(); - length($syslog) || croak "_PATH_LOG unavailable in syslog.h"; - my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; - socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; - if (!connect(SYSLOG,$that)) { - socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!"; - connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)"; - } + push(@{$errs}, "_PATH_LOG not available in syslog.h"); + return 0; + } + my $that = sockaddr_un($syslog_path); + if (!$that) { + push(@{$errs}, "can't locate $syslog_path"); + return 0; + } + if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) { + push(@{$errs}, "unix stream socket: $!"); + return 0; } - local($old) = select(SYSLOG); $| = 1; select($old); - $connected = 1; + if (!CORE::connect(SYSLOG,$that)) { + if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) { + push(@{$errs}, "unix dgram socket: $!"); + return 0; + } + if (!CORE::connect(SYSLOG,$that)) { + push(@{$errs}, "unix dgram connect: $!"); + return 0; + } + } + $syslog_send = \&_syslog_send_socket; + 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 && $current_proto eq 'console'); + my $rin = ''; + vec($rin, fileno(SYSLOG), 1) = 1; + my $ret = select $rin, undef, $rin, 0; + return ($ret ? 0 : 1); } sub disconnect { close SYSLOG; $connected = 0; + $syslog_send = undef; } 1;