X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FSys%2FSyslog%2FSyslog.pm;h=18f1d4d36d00034cc7272a1a81400374c8d3e464;hb=23642f4bb492bd33c14577e3d077059727e1fe92;hp=eabf7b4daceef0591f839a57a3a5061874b3ef59;hpb=c0f17b391dca1e5edc58fe5acc2495940cfff533;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index eabf7b4..18f1d4d 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -9,6 +9,17 @@ use Carp; @EXPORT_OK = qw(setlogsock); $VERSION = '0.02'; +# 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' ); +my @defaultMethods = @connectMethods; +my $syslog_path = undef; +my $transmit_ok = 0; +my $current_proto = undef; +my $failed = undef; +my $fail_time = undef; + use Socket; use Sys::Hostname; @@ -21,8 +32,6 @@ use Sys::Hostname; # 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 @@ -50,9 +59,11 @@ 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, I, I, I. -I<$facility> specifies the part of the system +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 =item syslog $priority, $format, @args @@ -64,19 +75,28 @@ is replaced with C<"$!"> (the latest error message). 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 returned by +the C<_PATH_LOG> macro (if your system defines it) in F. 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 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 @@ -113,20 +133,23 @@ Tom Christiansen EFE and Larry Wall EFE. UNIX domain sockets added by Sean Robinson -EFE with support from Tim Bunce -EFE and the perl5-porters mailing list. +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 Enick@ccl4.orgE. +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/.*:://; @@ -147,7 +170,6 @@ 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/; return 1 unless $lo_ndelay; &connect; @@ -166,21 +188,49 @@ sub setlogmask { sub setlogsock { local($setsock) = shift; + $syslog_path = shift; &disconnect if $connected; - if (lc($setsock) eq 'unix') { - if (length _PATH_LOG()) { - $sock_type = 1; + $transmit_ok = 0; + @fallbackMethods = (); + @connectMethods = @defaultMethods; + if (ref $setsock eq 'ARRAY') { + @connectMethods = @$setsock; + } elsif (lc($setsock) eq 'stream') { + $syslog_path = '/dev/log' unless($syslog_path); + if (!-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') { - if (getservbyname('syslog','udp')) { - undef($sock_type); - } else { - return undef; - } + @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; } @@ -243,24 +293,86 @@ sub syslog { $message = sprintf ($mask, @_); $sum = $numpri + $numfac; - unless (send(SYSLOG,"<$sum>$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 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) { + 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) = @_; $name = uc $name; @@ -272,35 +384,190 @@ sub xlate { } 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)) { + my $fn = "connect_$proto"; + $connected = &$fn(\@errs) unless (!defined &$fn); + last if ($connected); + } + + $transmit_ok = 0; + if ($connected) { + $current_proto = $proto; + local($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 _) + } + 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 (!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 _) } - unless ( $sock_type ) { - my $udp = getprotobyname('udp') || croak "getprotobyname failed for udp"; - my $syslog = getservbyname('syslog','udp') || croak "getservbyname failed"; - 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 $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 (!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: $!"; + 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; + } + if (!connect(SYSLOG,$that)) { + if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) { + push(@{$errs}, "unix dgram socket: $!"); + return 0; + } 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}, "unix dgram connect: $!"); + return 0; + } } - local($old) = select(SYSLOG); $| = 1; select($old); - $connected = 1; + $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 ($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;