7 @ISA = qw(Exporter DynaLoader);
8 @EXPORT = qw(openlog closelog setlogmask syslog);
9 @EXPORT_OK = qw(setlogsock);
12 # it would be nice to try stream/unix first, since that will be
13 # most efficient. However streams are dodgy - see _syslog_send_stream
14 #my @connectMethods = ( 'stream', 'unix', 'tcp', 'udp' );
15 my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
16 my @defaultMethods = @connectMethods;
17 my $syslog_path = undef;
19 my $current_proto = undef;
21 my $fail_time = undef;
26 # adapted from syslog.pl
28 # Tom Christiansen <tchrist@convex.com>
29 # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
30 # NOTE: openlog now takes three arguments, just like openlog(3)
31 # Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
32 # with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
33 # Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>
37 Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
41 use Sys::Syslog; # all except setlogsock, or:
42 use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
44 setlogsock $sock_type;
45 openlog $ident, $logopt, $facility;
46 syslog $priority, $format, @args;
47 $oldmask = setlogmask $mask_priority;
52 Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
53 Call C<syslog()> with a string priority and a list of C<printf()> args
54 just like C<syslog(3)>.
56 Syslog provides the functions:
60 =item openlog $ident, $logopt, $facility
62 I<$ident> is prepended to every message. I<$logopt> contains zero or
63 more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is
64 ignored, since the failover mechanism will drop down to the console
65 automatically if all other media fail. I<$facility> specifies the
68 =item syslog $priority, $format, @args
70 If I<$priority> permits, logs I<($format, @args)>
71 printed as by C<printf(3V)>, with the addition that I<%m>
72 is replaced with C<"$!"> (the latest error message).
74 =item setlogmask $mask_priority
76 Sets log mask I<$mask_priority> and returns the old mask.
78 =item setlogsock $sock_type [$stream_location] (added in 5.004_02)
80 Sets the socket type to be used for the next call to
81 C<openlog()> or C<syslog()> and returns TRUE on success,
84 A value of 'unix' will connect to the UNIX domain socket returned by
85 the C<_PATH_LOG> macro (if your system defines it) in F<syslog.ph>. A
86 value of 'stream' will connect to the stream indicated by the pathname
87 provided as the optional second parameter. A value of 'inet' will
88 connect to an INET socket (either tcp or udp, tried in that order)
89 returned by getservbyname(). 'tcp' and 'udp' can also be given as
90 values. The value 'console' will send messages directly to the
91 console, as for the 'cons' option in the logopts in openlog().
93 A reference to an array can also be passed as the first parameter.
94 When this calling method is used, the array should contain a list of
95 sock_types which are attempted in order.
97 The default is to try tcp, udp, unix, stream, console.
99 Giving an invalid value for sock_type will croak.
107 Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
111 openlog($program, 'cons,pid', 'user');
112 syslog('info', 'this is another test');
113 syslog('mail|warning', 'this is a better test: %d', time);
116 syslog('debug', 'this is the last test');
119 openlog("$program $$", 'ndelay', 'user');
120 syslog('notice', 'fooprogram: this is really done');
124 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
132 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
133 E<lt>F<larry@wall.org>E<gt>.
135 UNIX domain sockets added by Sean Robinson
136 E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
137 E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
139 Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
140 E<lt>F<tom@compton.nu>E<gt>.
142 Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
144 Failover to different communication modes by Nick Williams
145 E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
150 # This AUTOLOAD is used to 'autoload' constants from the constant()
155 ($constname = $AUTOLOAD) =~ s/.*:://;
156 croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
157 my ($error, $val) = constant($constname);
161 *$AUTOLOAD = sub { $val };
165 bootstrap Sys::Syslog $VERSION;
167 $maskpri = &LOG_UPTO(&LOG_DEBUG);
170 ($ident, $logopt, $facility) = @_; # package vars
171 $lo_pid = $logopt =~ /\bpid\b/;
172 $lo_ndelay = $logopt =~ /\bndelay\b/;
173 $lo_nowait = $logopt =~ /\bnowait\b/;
174 return 1 unless $lo_ndelay;
179 $facility = $ident = '';
184 local($oldmask) = $maskpri;
190 local($setsock) = shift;
191 $syslog_path = shift;
192 &disconnect if $connected;
194 @fallbackMethods = ();
195 @connectMethods = @defaultMethods;
196 if (ref $setsock eq 'ARRAY') {
197 @connectMethods = @$setsock;
198 } elsif (lc($setsock) eq 'stream') {
199 $syslog_path = '/dev/log' unless($syslog_path);
200 if (!-w $syslog_path) {
201 carp "stream passed to setlogsock, but $syslog_path is not writable";
204 @connectMethods = ( 'stream' );
206 } elsif (lc($setsock) eq 'unix') {
207 if (length _PATH_LOG() && !defined $syslog_path) {
208 $syslog_path = _PATH_LOG();
209 @connectMethods = ( 'unix' );
211 carp 'unix passed to setlogsock, but path not available';
214 } elsif (lc($setsock) eq 'tcp') {
215 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
216 @connectMethods = ( 'tcp' );
218 carp "tcp passed to setlogsock, but tcp service unavailable";
221 } elsif (lc($setsock) eq 'udp') {
222 if (getservbyname('syslog', 'udp')) {
223 @connectMethods = ( 'udp' );
225 carp "udp passed to setlogsock, but udp service unavailable";
228 } elsif (lc($setsock) eq 'inet') {
229 @connectMethods = ( 'tcp', 'udp' );
230 } elsif (lc($setsock) eq 'console') {
231 @connectMethods = ( 'console' );
233 carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
239 local($priority) = shift;
240 local($mask) = shift;
241 local($message, $whoami);
242 local(@words, $num, $numpri, $numfac, $sum);
243 local($facility) = $facility; # may need to change temporarily.
245 croak "syslog: expected both priority and mask" unless $mask && $priority;
247 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
251 $num = &xlate($_); # Translate word to number.
252 if (/^kern$/ || $num < 0) {
253 croak "syslog: invalid level/facility: $_";
255 elsif ($num <= &LOG_PRIMASK) {
256 croak "syslog: too many levels given: $_" if defined($numpri);
258 return 0 unless &LOG_MASK($numpri) & $maskpri;
261 croak "syslog: too many facilities given: $_" if defined($numfac);
267 croak "syslog: level must be given" unless defined($numpri);
269 if (!defined($numfac)) { # Facility not specified in this call.
270 $facility = 'user' unless $facility;
271 $numfac = &xlate($facility);
274 &connect unless $connected;
278 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
284 ($whoami = getlogin) ||
285 ($whoami = getpwuid($<)) ||
286 ($whoami = 'syslog');
289 $whoami .= "[$$]" if $lo_pid;
292 $mask .= "\n" unless $mask =~ /\n$/;
293 $message = sprintf ($mask, @_);
295 $sum = $numpri + $numfac;
296 my $buf = "<$sum>$whoami: $message\0";
298 # it's possible that we'll get an error from sending
299 # (e.g. if method is UDP and there is no UDP listener,
300 # then we'll get ECONNREFUSED on the send). So what we
301 # want to do at this point is to fallback onto a different
303 while (scalar @fallbackMethods || $syslog_send) {
304 if ($failed && (time - $fail_time) > 60) {
305 # it's been a while... maybe things have been fixed
306 @fallbackMethods = ();
308 $transmit_ok = 0; # make it look like a fresh attempt
311 if ($connected && !connection_ok()) {
312 # Something was OK, but has now broken. Remember coz we'll
313 # want to go back to what used to be OK.
314 $failed = $current_proto unless $failed;
318 &connect unless $connected;
319 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
321 if (&{$syslog_send}($buf)) {
325 # typically doesn't happen, since errors are rare from write().
329 # could not send, could not fallback onto a working
330 # connection method. Lose.
334 sub _syslog_send_console {
336 chop($buf); # delete the NUL from the end
337 # The console print is a method which could block
338 # so we do it in a child process and always return success
340 if (my $pid = fork) {
344 if (waitpid($pid, 0) >= 0) {
347 # it's possible that the caller has other
348 # plans for SIGCHLD, so let's not interfere
353 if (open(CONS, ">/dev/console")) {
354 my $ret = print CONS $buf . "\r";
355 exit ($ret) if defined $pid;
358 exit if defined $pid;
362 sub _syslog_send_stream {
364 # XXX: this only works if the OS stream implementation makes a write
365 # look like a putmsg() with simple header. For instance it works on
366 # Solaris 8 but not Solaris 7.
367 # To be correct, it should use a STREAMS API, but perl doesn't have one.
368 return syswrite(SYSLOG, $buf, length($buf));
370 sub _syslog_send_socket {
372 return syswrite(SYSLOG, $buf, length($buf));
373 #return send(SYSLOG, $buf, 0);
379 $name = "LOG_$name" unless $name =~ /^LOG_/;
380 $name = "Sys::Syslog::$name";
381 # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
382 my $value = eval { &$name };
383 defined $value ? $value : -1;
387 @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
388 if ($transmit_ok && $current_proto) {
389 # Retry what we were on, because it's worked in the past.
390 unshift(@fallbackMethods, $current_proto);
395 while ($proto = shift(@fallbackMethods)) {
396 my $fn = "connect_$proto";
397 $connected = &$fn(\@errs) unless (!defined &$fn);
398 last if ($connected);
403 $current_proto = $proto;
404 local($old) = select(SYSLOG); $| = 1; select($old);
406 @fallbackMethods = ();
407 foreach my $err (@errs) {
410 croak "no connection to syslog available";
417 require Sys::Hostname;
418 my($host_uniq) = Sys::Hostname::hostname();
419 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
421 my $tcp = getprotobyname('tcp');
423 push(@{$errs}, "getprotobyname failed for tcp");
426 my $syslog = getservbyname('syslog','tcp');
427 $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
428 if (!defined $syslog) {
429 push(@{$errs}, "getservbyname failed for tcp");
433 my $this = sockaddr_in($syslog, INADDR_ANY);
434 my $that = sockaddr_in($syslog, inet_aton($host));
436 push(@{$errs}, "can't lookup $host");
439 if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
440 push(@{$errs}, "tcp socket: $!");
443 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
444 setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
445 if (!CORE::connect(SYSLOG,$that)) {
446 push(@{$errs}, "tcp connect: $!");
449 $syslog_send = \&_syslog_send_socket;
456 require Sys::Hostname;
457 my($host_uniq) = Sys::Hostname::hostname();
458 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
460 my $udp = getprotobyname('udp');
462 push(@{$errs}, "getprotobyname failed for udp");
465 my $syslog = getservbyname('syslog','udp');
466 if (!defined $syslog) {
467 push(@{$errs}, "getservbyname failed for udp");
470 my $this = sockaddr_in($syslog, INADDR_ANY);
471 my $that = sockaddr_in($syslog, inet_aton($host));
473 push(@{$errs}, "can't lookup $host");
476 if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
477 push(@{$errs}, "udp socket: $!");
480 if (!CORE::connect(SYSLOG,$that)) {
481 push(@{$errs}, "udp connect: $!");
484 # We want to check that the UDP connect worked. However the only
485 # way to do that is to send a message and see if an ICMP is returned
486 _syslog_send_socket("");
487 if (!connection_ok()) {
488 push(@{$errs}, "udp connect: nobody listening");
491 $syslog_send = \&_syslog_send_socket;
497 # might want syslog_path to be variable based on syslog.h (if only
499 $syslog_path = '/dev/conslog';
500 if (!-w $syslog_path) {
501 push(@{$errs}, "stream $syslog_path is not writable");
504 if (!open(SYSLOG, ">" . $syslog_path)) {
505 push(@{$errs}, "stream can't open $syslog_path: $!");
508 $syslog_send = \&_syslog_send_stream;
514 if (length _PATH_LOG()) {
515 $syslog_path = _PATH_LOG();
517 push(@{$errs}, "_PATH_LOG not available in syslog.h");
520 my $that = sockaddr_un($syslog_path);
522 push(@{$errs}, "can't locate $syslog_path");
525 if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
526 push(@{$errs}, "unix stream socket: $!");
529 if (!CORE::connect(SYSLOG,$that)) {
530 if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
531 push(@{$errs}, "unix dgram socket: $!");
534 if (!CORE::connect(SYSLOG,$that)) {
535 push(@{$errs}, "unix dgram connect: $!");
539 $syslog_send = \&_syslog_send_socket;
543 sub connect_console {
545 if (!-w '/dev/console') {
546 push(@{$errs}, "console is not writable");
549 $syslog_send = \&_syslog_send_console;
553 # to test if the connection is still good, we need to check if any
554 # errors are present on the connection. The errors will not be raised
555 # by a write. Instead, sockets are made readable and the next read
556 # would cause the error to be returned. Unfortunately the syslog
557 # 'protocol' never provides anything for us to read. But with
558 # judicious use of select(), we can see if it would be readable...
560 return 1 if ($current_proto eq 'console');
562 vec($rin, fileno(SYSLOG), 1) = 1;
563 my $ret = select $rin, undef, $rin, 0;
564 return ($ret ? 0 : 1);
570 $syslog_send = undef;