7 our @ISA = qw(Exporter);
8 our @EXPORT = qw(openlog closelog setlogmask syslog);
9 our @EXPORT_OK = qw(setlogsock);
10 our $VERSION = '0.08';
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 = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
15 if ($^O =~ /^(freebsd|linux)$/) {
16 @connectMethods = grep { $_ ne 'udp' } @connectMethods;
18 my @defaultMethods = @connectMethods;
19 my $syslog_path = undef;
21 my $current_proto = undef;
23 my $fail_time = undef;
24 our ($connected, @fallbackMethods, $syslog_send, $host);
31 Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
35 use Sys::Syslog; # all except setlogsock, or:
36 use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
38 setlogsock $sock_type;
39 openlog $ident, $logopt, $facility; # don't forget this
40 syslog $priority, $format, @args;
41 $oldmask = setlogmask $mask_priority;
46 Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
47 Call C<syslog()> with a string priority and a list of C<printf()> args
48 just like C<syslog(3)>.
50 Syslog provides the functions:
54 =item openlog $ident, $logopt, $facility
57 I<$ident> is prepended to every message. I<$logopt> contains zero or
58 more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is
59 ignored, since the failover mechanism will drop down to the console
60 automatically if all other media fail. I<$facility> specifies the
61 part of the system to report about, for example LOG_USER or LOG_LOCAL0:
62 see your C<syslog(3)> documentation for the facilities available in
63 your system. This function will croak if it can't connect to the syslog
66 B<You should use openlog() before calling syslog().>
68 =item syslog $priority, $message
70 =item syslog $priority, $format, @args
72 If I<$priority> permits, logs I<$message> or I<sprintf($format, @args)>
73 with the addition that I<%m> in $message or $format is replaced with
74 C<"$!"> (the latest error message).
76 If you didn't use openlog() before using syslog(), syslog will try to
77 guess the I<$ident> by extracting the shortest prefix of I<$format>
80 =item setlogmask $mask_priority
82 Sets log mask I<$mask_priority> and returns the old mask.
84 =item setlogsock $sock_type [$stream_location] (added in 5.004_02)
86 Sets the socket type to be used for the next call to
87 C<openlog()> or C<syslog()> and returns TRUE on success,
90 A value of 'unix' will connect to the UNIX domain socket (in some
91 systems a character special device) returned by the C<_PATH_LOG> macro
92 (if your system defines it), or F</dev/log> or F</dev/conslog>,
93 whatever is writable. A value of 'stream' will connect to the stream
94 indicated by the pathname provided as the optional second parameter.
95 (For example Solaris and IRIX require 'stream' instead of 'unix'.)
96 A value of 'inet' will connect to an INET socket (either tcp or udp,
97 tried in that order) returned by getservbyname(). 'tcp' and 'udp' can
98 also be given as values. The value 'console' will send messages
99 directly to the console, as for the 'cons' option in the logopts in
102 A reference to an array can also be passed as the first parameter.
103 When this calling method is used, the array should contain a list of
104 sock_types which are attempted in order.
106 The default is to try tcp, udp, unix, stream, console.
108 Giving an invalid value for sock_type will croak.
116 Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
120 openlog($program, 'cons,pid', 'user');
121 syslog('info', '%s', 'this is another test');
122 syslog('mail|warning', 'this is a better test: %d', time);
125 syslog('debug', 'this is the last test');
128 openlog("$program $$", 'ndelay', 'user');
129 syslog('notice', 'fooprogram: this is really done');
133 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
135 # Log to UDP port on $remotehost instead of logging locally
137 $Sys::Syslog::host = $remotehost;
138 openlog($program, 'ndelay', 'user');
139 syslog('info', 'something happened over here');
147 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
148 E<lt>F<larry@wall.org>E<gt>.
150 UNIX domain sockets added by Sean Robinson
151 E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
152 E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
154 Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
155 E<lt>F<tom@compton.nu>E<gt>.
157 Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
159 Failover to different communication modes by Nick Williams
160 E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
165 # This AUTOLOAD is used to 'autoload' constants from the constant()
170 ($constname = $AUTOLOAD) =~ s/.*:://;
171 croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
172 my ($error, $val) = constant($constname);
177 *$AUTOLOAD = sub { $val };
182 XSLoader::load('Sys::Syslog', $VERSION);
184 our $maskpri = &LOG_UPTO(&LOG_DEBUG);
187 our ($ident, $logopt, $facility) = @_; # package vars
188 our $lo_pid = $logopt =~ /\bpid\b/;
189 our $lo_ndelay = $logopt =~ /\bndelay\b/;
190 our $lo_nowait = $logopt =~ /\bnowait\b/;
191 return 1 unless $lo_ndelay;
196 our $facility = our $ident = '';
201 my $oldmask = $maskpri;
208 $syslog_path = shift;
209 &disconnect if $connected;
211 @fallbackMethods = ();
212 @connectMethods = @defaultMethods;
213 if (ref $setsock eq 'ARRAY') {
214 @connectMethods = @$setsock;
215 } elsif (lc($setsock) eq 'stream') {
216 unless (defined $syslog_path) {
217 my @try = qw(/dev/log /dev/conslog);
218 if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
219 unshift @try, &_PATH_LOG;
227 carp "stream passed to setlogsock, but could not find any device"
228 unless defined $syslog_path;
230 unless (-w $syslog_path) {
231 carp "stream passed to setlogsock, but $syslog_path is not writable";
234 @connectMethods = ( 'stream' );
236 } elsif (lc($setsock) eq 'unix') {
237 if (length _PATH_LOG() && !defined $syslog_path) {
238 $syslog_path = _PATH_LOG();
239 @connectMethods = ( 'unix' );
241 carp 'unix passed to setlogsock, but path not available';
244 } elsif (lc($setsock) eq 'tcp') {
245 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
246 @connectMethods = ( 'tcp' );
248 carp "tcp passed to setlogsock, but tcp service unavailable";
251 } elsif (lc($setsock) eq 'udp') {
252 if (getservbyname('syslog', 'udp')) {
253 @connectMethods = ( 'udp' );
255 carp "udp passed to setlogsock, but udp service unavailable";
258 } elsif (lc($setsock) eq 'inet') {
259 @connectMethods = ( 'tcp', 'udp' );
260 } elsif (lc($setsock) eq 'console') {
261 @connectMethods = ( 'console' );
263 carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
269 my $priority = shift;
271 my ($message, $whoami);
272 my (@words, $num, $numpri, $numfac, $sum);
274 local($facility) = $facility; # may need to change temporarily.
276 croak "syslog: expecting argument \$priority" unless $priority;
277 croak "syslog: expecting argument \$format" unless $mask;
279 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
283 $num = &xlate($_); # Translate word to number.
284 if (/^kern$/ || $num < 0) {
285 croak "syslog: invalid level/facility: $_";
287 elsif ($num <= &LOG_PRIMASK) {
288 croak "syslog: too many levels given: $_" if defined($numpri);
290 return 0 unless &LOG_MASK($numpri) & $maskpri;
293 croak "syslog: too many facilities given: $_" if defined($numfac);
299 croak "syslog: level must be given" unless defined($numpri);
301 if (!defined($numfac)) { # Facility not specified in this call.
302 $facility = 'user' unless $facility;
303 $numfac = &xlate($facility);
306 &connect unless $connected;
308 $whoami = our $ident;
310 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
316 ($whoami = getlogin) ||
317 ($whoami = getpwuid($<)) ||
318 ($whoami = 'syslog');
321 $whoami .= "[$$]" if our $lo_pid;
323 $mask =~ s/(?<!%)%m/$!/g;
324 $mask .= "\n" unless $mask =~ /\n$/;
325 $message = @_ ? sprintf($mask, @_) : $mask;
327 $sum = $numpri + $numfac;
328 my $buf = "<$sum>$whoami: $message\0";
330 # it's possible that we'll get an error from sending
331 # (e.g. if method is UDP and there is no UDP listener,
332 # then we'll get ECONNREFUSED on the send). So what we
333 # want to do at this point is to fallback onto a different
335 while (scalar @fallbackMethods || $syslog_send) {
336 if ($failed && (time - $fail_time) > 60) {
337 # it's been a while... maybe things have been fixed
338 @fallbackMethods = ();
340 $transmit_ok = 0; # make it look like a fresh attempt
343 if ($connected && !connection_ok()) {
344 # Something was OK, but has now broken. Remember coz we'll
345 # want to go back to what used to be OK.
346 $failed = $current_proto unless $failed;
350 &connect unless $connected;
351 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
353 if (&{$syslog_send}($buf)) {
357 # typically doesn't happen, since errors are rare from write().
361 # could not send, could not fallback onto a working
362 # connection method. Lose.
366 sub _syslog_send_console {
368 chop($buf); # delete the NUL from the end
369 # The console print is a method which could block
370 # so we do it in a child process and always return success
372 if (my $pid = fork) {
377 if (waitpid($pid, 0) >= 0) {
380 # it's possible that the caller has other
381 # plans for SIGCHLD, so let's not interfere
386 if (open(CONS, ">/dev/console")) {
387 my $ret = print CONS $buf . "\r";
388 exit ($ret) if defined $pid;
391 exit if defined $pid;
395 sub _syslog_send_stream {
397 # XXX: this only works if the OS stream implementation makes a write
398 # look like a putmsg() with simple header. For instance it works on
399 # Solaris 8 but not Solaris 7.
400 # To be correct, it should use a STREAMS API, but perl doesn't have one.
401 return syswrite(SYSLOG, $buf, length($buf));
403 sub _syslog_send_socket {
405 return syswrite(SYSLOG, $buf, length($buf));
406 #return send(SYSLOG, $buf, 0);
411 return $name+0 if $name =~ /^\s*\d+\s*$/;
413 $name = "LOG_$name" unless $name =~ /^LOG_/;
414 $name = "Sys::Syslog::$name";
415 # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
416 my $value = eval { no strict 'refs'; &$name };
417 defined $value ? $value : -1;
421 @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
422 if ($transmit_ok && $current_proto) {
423 # Retry what we were on, because it's worked in the past.
424 unshift(@fallbackMethods, $current_proto);
429 while ($proto = shift(@fallbackMethods)) {
431 my $fn = "connect_$proto";
432 $connected = &$fn(\@errs) if defined &$fn;
433 last if ($connected);
438 $current_proto = $proto;
439 my($old) = select(SYSLOG); $| = 1; select($old);
441 @fallbackMethods = ();
442 foreach my $err (@errs) {
445 croak "no connection to syslog available";
452 require Sys::Hostname;
453 my($host_uniq) = Sys::Hostname::hostname();
454 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
456 my $tcp = getprotobyname('tcp');
458 push(@{$errs}, "getprotobyname failed for tcp");
461 my $syslog = getservbyname('syslog','tcp');
462 $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
463 if (!defined $syslog) {
464 push(@{$errs}, "getservbyname failed for tcp");
468 my $this = sockaddr_in($syslog, INADDR_ANY);
469 my $that = sockaddr_in($syslog, inet_aton($host));
471 push(@{$errs}, "can't lookup $host");
474 if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
475 push(@{$errs}, "tcp socket: $!");
478 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
479 setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
480 if (!CORE::connect(SYSLOG,$that)) {
481 push(@{$errs}, "tcp connect: $!");
484 $syslog_send = \&_syslog_send_socket;
491 require Sys::Hostname;
492 my($host_uniq) = Sys::Hostname::hostname();
493 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
495 my $udp = getprotobyname('udp');
497 push(@{$errs}, "getprotobyname failed for udp");
500 my $syslog = getservbyname('syslog','udp');
501 if (!defined $syslog) {
502 push(@{$errs}, "getservbyname failed for udp");
505 my $this = sockaddr_in($syslog, INADDR_ANY);
506 my $that = sockaddr_in($syslog, inet_aton($host));
508 push(@{$errs}, "can't lookup $host");
511 if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
512 push(@{$errs}, "udp socket: $!");
515 if (!CORE::connect(SYSLOG,$that)) {
516 push(@{$errs}, "udp connect: $!");
519 # We want to check that the UDP connect worked. However the only
520 # way to do that is to send a message and see if an ICMP is returned
521 _syslog_send_socket("");
522 if (!connection_ok()) {
523 push(@{$errs}, "udp connect: nobody listening");
526 $syslog_send = \&_syslog_send_socket;
532 # might want syslog_path to be variable based on syslog.h (if only
534 $syslog_path = '/dev/conslog';
535 if (!-w $syslog_path) {
536 push(@{$errs}, "stream $syslog_path is not writable");
539 if (!open(SYSLOG, ">" . $syslog_path)) {
540 push(@{$errs}, "stream can't open $syslog_path: $!");
543 $syslog_send = \&_syslog_send_stream;
549 if (length _PATH_LOG()) {
550 $syslog_path = _PATH_LOG();
552 push(@{$errs}, "_PATH_LOG not available in syslog.h");
555 my $that = sockaddr_un($syslog_path);
557 push(@{$errs}, "can't locate $syslog_path");
560 if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
561 push(@{$errs}, "unix stream socket: $!");
564 if (!CORE::connect(SYSLOG,$that)) {
565 if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
566 push(@{$errs}, "unix dgram socket: $!");
569 if (!CORE::connect(SYSLOG,$that)) {
570 push(@{$errs}, "unix dgram connect: $!");
574 $syslog_send = \&_syslog_send_socket;
578 sub connect_console {
580 if (!-w '/dev/console') {
581 push(@{$errs}, "console is not writable");
584 $syslog_send = \&_syslog_send_console;
588 # to test if the connection is still good, we need to check if any
589 # errors are present on the connection. The errors will not be raised
590 # by a write. Instead, sockets are made readable and the next read
591 # would cause the error to be returned. Unfortunately the syslog
592 # 'protocol' never provides anything for us to read. But with
593 # judicious use of select(), we can see if it would be readable...
595 return 1 if (defined $current_proto && $current_proto eq 'console');
597 vec($rin, fileno(SYSLOG), 1) = 1;
598 my $ret = select $rin, undef, $rin, 0;
599 return ($ret ? 0 : 1);
605 $syslog_send = undef;