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 if ($^O =~ /^(freebsd|linux)$/) {
17 @connectMethods = grep { $_ ne 'udp' } @connectMethods;
19 my @defaultMethods = @connectMethods;
20 my $syslog_path = undef;
22 my $current_proto = undef;
24 my $fail_time = undef;
29 # adapted from syslog.pl
31 # Tom Christiansen <tchrist@convex.com>
32 # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
33 # NOTE: openlog now takes three arguments, just like openlog(3)
34 # Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
35 # with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
36 # Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>
40 Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
44 use Sys::Syslog; # all except setlogsock, or:
45 use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
47 setlogsock $sock_type;
48 openlog $ident, $logopt, $facility;
49 syslog $priority, $format, @args;
50 $oldmask = setlogmask $mask_priority;
55 Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
56 Call C<syslog()> with a string priority and a list of C<printf()> args
57 just like C<syslog(3)>.
59 Syslog provides the functions:
63 =item openlog $ident, $logopt, $facility
65 I<$ident> is prepended to every message. I<$logopt> contains zero or
66 more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is
67 ignored, since the failover mechanism will drop down to the console
68 automatically if all other media fail. I<$facility> specifies the
71 =item syslog $priority, $format, @args
73 If I<$priority> permits, logs I<($format, @args)>
74 printed as by C<printf(3V)>, with the addition that I<%m>
75 is replaced with C<"$!"> (the latest error message).
77 =item setlogmask $mask_priority
79 Sets log mask I<$mask_priority> and returns the old mask.
81 =item setlogsock $sock_type [$stream_location] (added in 5.004_02)
83 Sets the socket type to be used for the next call to
84 C<openlog()> or C<syslog()> and returns TRUE on success,
87 A value of 'unix' will connect to the UNIX domain socket returned by
88 the C<_PATH_LOG> macro (if your system defines it) in F<syslog.ph>. A
89 value of 'stream' will connect to the stream indicated by the pathname
90 provided as the optional second parameter. A value of 'inet' will
91 connect to an INET socket (either tcp or udp, tried in that order)
92 returned by getservbyname(). 'tcp' and 'udp' can also be given as
93 values. The value 'console' will send messages directly to the
94 console, as for the 'cons' option in the logopts in openlog().
96 A reference to an array can also be passed as the first parameter.
97 When this calling method is used, the array should contain a list of
98 sock_types which are attempted in order.
100 The default is to try tcp, udp, unix, stream, console.
102 Giving an invalid value for sock_type will croak.
110 Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
114 openlog($program, 'cons,pid', 'user');
115 syslog('info', 'this is another test');
116 syslog('mail|warning', 'this is a better test: %d', time);
119 syslog('debug', 'this is the last test');
122 openlog("$program $$", 'ndelay', 'user');
123 syslog('notice', 'fooprogram: this is really done');
127 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
135 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
136 E<lt>F<larry@wall.org>E<gt>.
138 UNIX domain sockets added by Sean Robinson
139 E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
140 E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
142 Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
143 E<lt>F<tom@compton.nu>E<gt>.
145 Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
147 Failover to different communication modes by Nick Williams
148 E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
153 # This AUTOLOAD is used to 'autoload' constants from the constant()
158 ($constname = $AUTOLOAD) =~ s/.*:://;
159 croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
160 my ($error, $val) = constant($constname);
164 *$AUTOLOAD = sub { $val };
168 bootstrap Sys::Syslog $VERSION;
170 $maskpri = &LOG_UPTO(&LOG_DEBUG);
173 ($ident, $logopt, $facility) = @_; # package vars
174 $lo_pid = $logopt =~ /\bpid\b/;
175 $lo_ndelay = $logopt =~ /\bndelay\b/;
176 $lo_nowait = $logopt =~ /\bnowait\b/;
177 return 1 unless $lo_ndelay;
182 $facility = $ident = '';
187 local($oldmask) = $maskpri;
193 local($setsock) = shift;
194 $syslog_path = shift;
195 &disconnect if $connected;
197 @fallbackMethods = ();
198 @connectMethods = @defaultMethods;
199 if (ref $setsock eq 'ARRAY') {
200 @connectMethods = @$setsock;
201 } elsif (lc($setsock) eq 'stream') {
202 $syslog_path = '/dev/log' unless($syslog_path);
203 if (!-w $syslog_path) {
204 carp "stream passed to setlogsock, but $syslog_path is not writable";
207 @connectMethods = ( 'stream' );
209 } elsif (lc($setsock) eq 'unix') {
210 if (length _PATH_LOG() && !defined $syslog_path) {
211 $syslog_path = _PATH_LOG();
212 @connectMethods = ( 'unix' );
214 carp 'unix passed to setlogsock, but path not available';
217 } elsif (lc($setsock) eq 'tcp') {
218 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
219 @connectMethods = ( 'tcp' );
221 carp "tcp passed to setlogsock, but tcp service unavailable";
224 } elsif (lc($setsock) eq 'udp') {
225 if (getservbyname('syslog', 'udp')) {
226 @connectMethods = ( 'udp' );
228 carp "udp passed to setlogsock, but udp service unavailable";
231 } elsif (lc($setsock) eq 'inet') {
232 @connectMethods = ( 'tcp', 'udp' );
233 } elsif (lc($setsock) eq 'console') {
234 @connectMethods = ( 'console' );
236 carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
242 local($priority) = shift;
243 local($mask) = shift;
244 local($message, $whoami);
245 local(@words, $num, $numpri, $numfac, $sum);
246 local($facility) = $facility; # may need to change temporarily.
248 croak "syslog: expected both priority and mask" unless $mask && $priority;
250 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
254 $num = &xlate($_); # Translate word to number.
255 if (/^kern$/ || $num < 0) {
256 croak "syslog: invalid level/facility: $_";
258 elsif ($num <= &LOG_PRIMASK) {
259 croak "syslog: too many levels given: $_" if defined($numpri);
261 return 0 unless &LOG_MASK($numpri) & $maskpri;
264 croak "syslog: too many facilities given: $_" if defined($numfac);
270 croak "syslog: level must be given" unless defined($numpri);
272 if (!defined($numfac)) { # Facility not specified in this call.
273 $facility = 'user' unless $facility;
274 $numfac = &xlate($facility);
277 &connect unless $connected;
281 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
287 ($whoami = getlogin) ||
288 ($whoami = getpwuid($<)) ||
289 ($whoami = 'syslog');
292 $whoami .= "[$$]" if $lo_pid;
295 $mask .= "\n" unless $mask =~ /\n$/;
296 $message = sprintf ($mask, @_);
298 $sum = $numpri + $numfac;
299 my $buf = "<$sum>$whoami: $message\0";
301 # it's possible that we'll get an error from sending
302 # (e.g. if method is UDP and there is no UDP listener,
303 # then we'll get ECONNREFUSED on the send). So what we
304 # want to do at this point is to fallback onto a different
306 while (scalar @fallbackMethods || $syslog_send) {
307 if ($failed && (time - $fail_time) > 60) {
308 # it's been a while... maybe things have been fixed
309 @fallbackMethods = ();
311 $transmit_ok = 0; # make it look like a fresh attempt
314 if ($connected && !connection_ok()) {
315 # Something was OK, but has now broken. Remember coz we'll
316 # want to go back to what used to be OK.
317 $failed = $current_proto unless $failed;
321 &connect unless $connected;
322 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
324 if (&{$syslog_send}($buf)) {
328 # typically doesn't happen, since errors are rare from write().
332 # could not send, could not fallback onto a working
333 # connection method. Lose.
337 sub _syslog_send_console {
339 chop($buf); # delete the NUL from the end
340 # The console print is a method which could block
341 # so we do it in a child process and always return success
343 if (my $pid = fork) {
347 if (waitpid($pid, 0) >= 0) {
350 # it's possible that the caller has other
351 # plans for SIGCHLD, so let's not interfere
356 if (open(CONS, ">/dev/console")) {
357 my $ret = print CONS $buf . "\r";
358 exit ($ret) if defined $pid;
361 exit if defined $pid;
365 sub _syslog_send_stream {
367 # XXX: this only works if the OS stream implementation makes a write
368 # look like a putmsg() with simple header. For instance it works on
369 # Solaris 8 but not Solaris 7.
370 # To be correct, it should use a STREAMS API, but perl doesn't have one.
371 return syswrite(SYSLOG, $buf, length($buf));
373 sub _syslog_send_socket {
375 return syswrite(SYSLOG, $buf, length($buf));
376 #return send(SYSLOG, $buf, 0);
382 $name = "LOG_$name" unless $name =~ /^LOG_/;
383 $name = "Sys::Syslog::$name";
384 # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
385 my $value = eval { &$name };
386 defined $value ? $value : -1;
390 @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
391 if ($transmit_ok && $current_proto) {
392 # Retry what we were on, because it's worked in the past.
393 unshift(@fallbackMethods, $current_proto);
398 while ($proto = shift(@fallbackMethods)) {
399 my $fn = "connect_$proto";
400 $connected = &$fn(\@errs) unless (!defined &$fn);
401 last if ($connected);
406 $current_proto = $proto;
407 local($old) = select(SYSLOG); $| = 1; select($old);
409 @fallbackMethods = ();
410 foreach my $err (@errs) {
413 croak "no connection to syslog available";
420 require Sys::Hostname;
421 my($host_uniq) = Sys::Hostname::hostname();
422 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
424 my $tcp = getprotobyname('tcp');
426 push(@{$errs}, "getprotobyname failed for tcp");
429 my $syslog = getservbyname('syslog','tcp');
430 $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
431 if (!defined $syslog) {
432 push(@{$errs}, "getservbyname failed for tcp");
436 my $this = sockaddr_in($syslog, INADDR_ANY);
437 my $that = sockaddr_in($syslog, inet_aton($host));
439 push(@{$errs}, "can't lookup $host");
442 if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
443 push(@{$errs}, "tcp socket: $!");
446 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
447 setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
448 if (!CORE::connect(SYSLOG,$that)) {
449 push(@{$errs}, "tcp connect: $!");
452 $syslog_send = \&_syslog_send_socket;
459 require Sys::Hostname;
460 my($host_uniq) = Sys::Hostname::hostname();
461 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
463 my $udp = getprotobyname('udp');
465 push(@{$errs}, "getprotobyname failed for udp");
468 my $syslog = getservbyname('syslog','udp');
469 if (!defined $syslog) {
470 push(@{$errs}, "getservbyname failed for udp");
473 my $this = sockaddr_in($syslog, INADDR_ANY);
474 my $that = sockaddr_in($syslog, inet_aton($host));
476 push(@{$errs}, "can't lookup $host");
479 if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
480 push(@{$errs}, "udp socket: $!");
483 if (!CORE::connect(SYSLOG,$that)) {
484 push(@{$errs}, "udp connect: $!");
487 # We want to check that the UDP connect worked. However the only
488 # way to do that is to send a message and see if an ICMP is returned
489 _syslog_send_socket("");
490 if (!connection_ok()) {
491 push(@{$errs}, "udp connect: nobody listening");
494 $syslog_send = \&_syslog_send_socket;
500 # might want syslog_path to be variable based on syslog.h (if only
502 $syslog_path = '/dev/conslog';
503 if (!-w $syslog_path) {
504 push(@{$errs}, "stream $syslog_path is not writable");
507 if (!open(SYSLOG, ">" . $syslog_path)) {
508 push(@{$errs}, "stream can't open $syslog_path: $!");
511 $syslog_send = \&_syslog_send_stream;
517 if (length _PATH_LOG()) {
518 $syslog_path = _PATH_LOG();
520 push(@{$errs}, "_PATH_LOG not available in syslog.h");
523 my $that = sockaddr_un($syslog_path);
525 push(@{$errs}, "can't locate $syslog_path");
528 if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
529 push(@{$errs}, "unix stream socket: $!");
532 if (!CORE::connect(SYSLOG,$that)) {
533 if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
534 push(@{$errs}, "unix dgram socket: $!");
537 if (!CORE::connect(SYSLOG,$that)) {
538 push(@{$errs}, "unix dgram connect: $!");
542 $syslog_send = \&_syslog_send_socket;
546 sub connect_console {
548 if (!-w '/dev/console') {
549 push(@{$errs}, "console is not writable");
552 $syslog_send = \&_syslog_send_console;
556 # to test if the connection is still good, we need to check if any
557 # errors are present on the connection. The errors will not be raised
558 # by a write. Instead, sockets are made readable and the next read
559 # would cause the error to be returned. Unfortunately the syslog
560 # 'protocol' never provides anything for us to read. But with
561 # judicious use of select(), we can see if it would be readable...
563 return 1 if (defined $current_proto && $current_proto eq 'console');
565 vec($rin, fileno(SYSLOG), 1) = 1;
566 my $ret = select $rin, undef, $rin, 0;
567 return ($ret ? 0 : 1);
573 $syslog_send = undef;