This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Missing chunk in change #26247.
[perl5.git] / ext / Sys / Syslog / Syslog.pm
CommitLineData
a0d0e21e 1package Sys::Syslog;
3b355090 2require 5.006;
a0d0e21e
LW
3require Exporter;
4use Carp;
108be7fb 5use strict;
a0d0e21e 6
db9f82cf 7our @ISA = qw(Exporter);
108be7fb
RGS
8our @EXPORT = qw(openlog closelog setlogmask syslog);
9our @EXPORT_OK = qw(setlogsock);
ce43db9b 10our $VERSION = '0.08';
a0d0e21e 11
23642f4b
NW
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
23642f4b 14my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
dbfdd438
SR
15if ($^O =~ /^(freebsd|linux)$/) {
16 @connectMethods = grep { $_ ne 'udp' } @connectMethods;
17}
23642f4b
NW
18my @defaultMethods = @connectMethods;
19my $syslog_path = undef;
20my $transmit_ok = 0;
21my $current_proto = undef;
22my $failed = undef;
23my $fail_time = undef;
108be7fb 24our ($connected, @fallbackMethods, $syslog_send, $host);
23642f4b 25
108be7fb 26use Socket ':all';
55497cff 27use Sys::Hostname;
37120919 28
5be1dfc7
HF
29=head1 NAME
30
31Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
32
33=head1 SYNOPSIS
34
3ffabb8c
GS
35 use Sys::Syslog; # all except setlogsock, or:
36 use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
5be1dfc7 37
3ffabb8c 38 setlogsock $sock_type;
3d256c0f 39 openlog $ident, $logopt, $facility; # don't forget this
2eae817d 40 syslog $priority, $format, @args;
5be1dfc7
HF
41 $oldmask = setlogmask $mask_priority;
42 closelog;
43
44=head1 DESCRIPTION
45
46Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
47Call C<syslog()> with a string priority and a list of C<printf()> args
48just like C<syslog(3)>.
49
50Syslog provides the functions:
51
bbc7dcd2 52=over 4
5be1dfc7
HF
53
54=item openlog $ident, $logopt, $facility
55
b91ed019 56Opens the syslog.
23642f4b
NW
57I<$ident> is prepended to every message. I<$logopt> contains zero or
58more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is
59ignored, since the failover mechanism will drop down to the console
60automatically if all other media fail. I<$facility> specifies the
3d256c0f
JH
61part of the system to report about, for example LOG_USER or LOG_LOCAL0:
62see your C<syslog(3)> documentation for the facilities available in
b91ed019
RGS
63your system. This function will croak if it can't connect to the syslog
64daemon.
3d256c0f
JH
65
66B<You should use openlog() before calling syslog().>
5be1dfc7 67
ce43db9b
GA
68=item syslog $priority, $message
69
2eae817d 70=item syslog $priority, $format, @args
5be1dfc7 71
caccce6a
RGS
72If I<$priority> permits, logs I<$message> or I<sprintf($format, @args)>
73with the addition that I<%m> in $message or $format is replaced with
74C<"$!"> (the latest error message).
5be1dfc7 75
3d256c0f
JH
76If you didn't use openlog() before using syslog(), syslog will try to
77guess the I<$ident> by extracting the shortest prefix of I<$format>
78that ends in a ":".
79
5be1dfc7
HF
80=item setlogmask $mask_priority
81
82Sets log mask I<$mask_priority> and returns the old mask.
83
23642f4b 84=item setlogsock $sock_type [$stream_location] (added in 5.004_02)
3ffabb8c 85
cb63fe9d 86Sets the socket type to be used for the next call to
3ffabb8c
GS
87C<openlog()> or C<syslog()> and returns TRUE on success,
88undef on failure.
89
f66a7beb
JB
90A value of 'unix' will connect to the UNIX domain socket (in some
91systems 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>,
93whatever is writable. A value of 'stream' will connect to the stream
94indicated by the pathname provided as the optional second parameter.
e9aaaa2f 95(For example Solaris and IRIX require 'stream' instead of 'unix'.)
f66a7beb
JB
96A value of 'inet' will connect to an INET socket (either tcp or udp,
97tried in that order) returned by getservbyname(). 'tcp' and 'udp' can
98also be given as values. The value 'console' will send messages
99directly to the console, as for the 'cons' option in the logopts in
100openlog().
23642f4b
NW
101
102A reference to an array can also be passed as the first parameter.
103When this calling method is used, the array should contain a list of
104sock_types which are attempted in order.
cb63fe9d 105
23642f4b
NW
106The default is to try tcp, udp, unix, stream, console.
107
108Giving an invalid value for sock_type will croak.
cb63fe9d 109
5be1dfc7
HF
110=item closelog
111
112Closes the log file.
113
114=back
115
116Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
117
118=head1 EXAMPLES
119
120 openlog($program, 'cons,pid', 'user');
e6c138cd 121 syslog('info', '%s', 'this is another test');
5be1dfc7
HF
122 syslog('mail|warning', 'this is a better test: %d', time);
123 closelog();
124
125 syslog('debug', 'this is the last test');
cb63fe9d
TB
126
127 setlogsock('unix');
5be1dfc7
HF
128 openlog("$program $$", 'ndelay', 'user');
129 syslog('notice', 'fooprogram: this is really done');
130
cb63fe9d 131 setlogsock('inet');
5be1dfc7
HF
132 $! = 55;
133 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
134
476b65d9
JH
135 # Log to UDP port on $remotehost instead of logging locally
136 setlogsock('udp');
137 $Sys::Syslog::host = $remotehost;
138 openlog($program, 'ndelay', 'user');
139 syslog('info', 'something happened over here');
140
5be1dfc7
HF
141=head1 SEE ALSO
142
143L<syslog(3)>
144
145=head1 AUTHOR
146
150b260b
GS
147Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
148E<lt>F<larry@wall.org>E<gt>.
149
150UNIX domain sockets added by Sean Robinson
23642f4b 151E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
a88817a4 152E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
150b260b
GS
153
154Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
155E<lt>F<tom@compton.nu>E<gt>.
5be1dfc7 156
23642f4b
NW
157Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
158
159Failover to different communication modes by Nick Williams
160E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
b903fcff 161
5be1dfc7 162=cut
a0d0e21e 163
8ce86de8
GS
164sub AUTOLOAD {
165 # This AUTOLOAD is used to 'autoload' constants from the constant()
166 # XS function.
23642f4b 167
8ce86de8
GS
168 my $constname;
169 our $AUTOLOAD;
170 ($constname = $AUTOLOAD) =~ s/.*:://;
b903fcff
JH
171 croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
172 my ($error, $val) = constant($constname);
173 if ($error) {
174 croak $error;
8ce86de8 175 }
108be7fb 176 no strict 'refs';
8ce86de8
GS
177 *$AUTOLOAD = sub { $val };
178 goto &$AUTOLOAD;
179}
180
db9f82cf
AT
181require XSLoader;
182XSLoader::load('Sys::Syslog', $VERSION);
a0d0e21e 183
108be7fb 184our $maskpri = &LOG_UPTO(&LOG_DEBUG);
a0d0e21e
LW
185
186sub openlog {
108be7fb
RGS
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/;
a8710ca1
GS
191 return 1 unless $lo_ndelay;
192 &connect;
a0d0e21e
LW
193}
194
195sub closelog {
108be7fb 196 our $facility = our $ident = '';
a0d0e21e
LW
197 &disconnect;
198}
199
200sub setlogmask {
108be7fb 201 my $oldmask = $maskpri;
a0d0e21e
LW
202 $maskpri = shift;
203 $oldmask;
204}
205
cb63fe9d 206sub setlogsock {
108be7fb 207 my $setsock = shift;
23642f4b 208 $syslog_path = shift;
3ffabb8c 209 &disconnect if $connected;
23642f4b
NW
210 $transmit_ok = 0;
211 @fallbackMethods = ();
212 @connectMethods = @defaultMethods;
213 if (ref $setsock eq 'ARRAY') {
214 @connectMethods = @$setsock;
215 } elsif (lc($setsock) eq 'stream') {
f66a7beb
JB
216 unless (defined $syslog_path) {
217 my @try = qw(/dev/log /dev/conslog);
e863979d 218 if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
f66a7beb
JB
219 unshift @try, &_PATH_LOG;
220 }
221 for my $try (@try) {
222 if (-w $try) {
223 $syslog_path = $try;
224 last;
225 }
226 }
e863979d
JH
227 carp "stream passed to setlogsock, but could not find any device"
228 unless defined $syslog_path;
f66a7beb 229 }
e863979d 230 unless (-w $syslog_path) {
23642f4b
NW
231 carp "stream passed to setlogsock, but $syslog_path is not writable";
232 return undef;
233 } else {
234 @connectMethods = ( 'stream' );
235 }
236 } elsif (lc($setsock) eq 'unix') {
237 if (length _PATH_LOG() && !defined $syslog_path) {
238 $syslog_path = _PATH_LOG();
239 @connectMethods = ( 'unix' );
3ffabb8c 240 } else {
23642f4b
NW
241 carp 'unix passed to setlogsock, but path not available';
242 return undef;
3ffabb8c 243 }
23642f4b
NW
244 } elsif (lc($setsock) eq 'tcp') {
245 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
246 @connectMethods = ( 'tcp' );
247 } else {
248 carp "tcp passed to setlogsock, but tcp service unavailable";
249 return undef;
250 }
251 } elsif (lc($setsock) eq 'udp') {
252 if (getservbyname('syslog', 'udp')) {
253 @connectMethods = ( 'udp' );
254 } else {
255 carp "udp passed to setlogsock, but udp service unavailable";
256 return undef;
257 }
cb63fe9d 258 } elsif (lc($setsock) eq 'inet') {
23642f4b
NW
259 @connectMethods = ( 'tcp', 'udp' );
260 } elsif (lc($setsock) eq 'console') {
261 @connectMethods = ( 'console' );
cb63fe9d 262 } else {
23642f4b 263 carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
cb63fe9d 264 }
f8b75b0c 265 return 1;
cb63fe9d
TB
266}
267
a0d0e21e 268sub syslog {
108be7fb
RGS
269 my $priority = shift;
270 my $mask = shift;
271 my ($message, $whoami);
272 my (@words, $num, $numpri, $numfac, $sum);
273 our $facility;
a0d0e21e
LW
274 local($facility) = $facility; # may need to change temporarily.
275
78ac6fa8
JA
276 croak "syslog: expecting argument \$priority" unless $priority;
277 croak "syslog: expecting argument \$format" unless $mask;
a0d0e21e
LW
278
279 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
280 undef $numpri;
281 undef $numfac;
282 foreach (@words) {
283 $num = &xlate($_); # Translate word to number.
284 if (/^kern$/ || $num < 0) {
285 croak "syslog: invalid level/facility: $_";
286 }
287 elsif ($num <= &LOG_PRIMASK) {
288 croak "syslog: too many levels given: $_" if defined($numpri);
289 $numpri = $num;
290 return 0 unless &LOG_MASK($numpri) & $maskpri;
291 }
292 else {
293 croak "syslog: too many facilities given: $_" if defined($numfac);
294 $facility = $_;
295 $numfac = $num;
296 }
297 }
298
299 croak "syslog: level must be given" unless defined($numpri);
300
301 if (!defined($numfac)) { # Facility not specified in this call.
302 $facility = 'user' unless $facility;
303 $numfac = &xlate($facility);
304 }
305
306 &connect unless $connected;
307
108be7fb 308 $whoami = our $ident;
a0d0e21e 309
5dad0344 310 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
a0d0e21e
LW
311 $whoami = $1;
312 $mask = $2;
313 }
314
315 unless ($whoami) {
316 ($whoami = getlogin) ||
317 ($whoami = getpwuid($<)) ||
318 ($whoami = 'syslog');
319 }
320
108be7fb 321 $whoami .= "[$$]" if our $lo_pid;
a0d0e21e 322
3b355090 323 $mask =~ s/(?<!%)%m/$!/g;
a0d0e21e 324 $mask .= "\n" unless $mask =~ /\n$/;
ce43db9b 325 $message = @_ ? sprintf($mask, @_) : $mask;
a0d0e21e
LW
326
327 $sum = $numpri + $numfac;
23642f4b
NW
328 my $buf = "<$sum>$whoami: $message\0";
329
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
334 # connection method.
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 = ();
339 disconnect();
340 $transmit_ok = 0; # make it look like a fresh attempt
341 &connect;
342 }
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;
347 $fail_time = time;
348 disconnect();
349 }
350 &connect unless $connected;
60b8437d 351 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
23642f4b
NW
352 if ($syslog_send) {
353 if (&{$syslog_send}($buf)) {
354 $transmit_ok++;
355 return 1;
a0d0e21e 356 }
23642f4b
NW
357 # typically doesn't happen, since errors are rare from write().
358 disconnect();
359 }
360 }
361 # could not send, could not fallback onto a working
362 # connection method. Lose.
363 return 0;
364}
365
366sub _syslog_send_console {
367 my ($buf) = @_;
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
371 # to the caller.
372 if (my $pid = fork) {
108be7fb 373 our $lo_nowait;
23642f4b
NW
374 if ($lo_nowait) {
375 return 1;
376 } else {
377 if (waitpid($pid, 0) >= 0) {
378 return ($? >> 8);
379 } else {
380 # it's possible that the caller has other
381 # plans for SIGCHLD, so let's not interfere
382 return 1;
a0d0e21e
LW
383 }
384 }
23642f4b
NW
385 } else {
386 if (open(CONS, ">/dev/console")) {
387 my $ret = print CONS $buf . "\r";
388 exit ($ret) if defined $pid;
389 close CONS;
390 }
391 exit if defined $pid;
a0d0e21e
LW
392 }
393}
394
23642f4b
NW
395sub _syslog_send_stream {
396 my ($buf) = @_;
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));
402}
403sub _syslog_send_socket {
404 my ($buf) = @_;
405 return syswrite(SYSLOG, $buf, length($buf));
406 #return send(SYSLOG, $buf, 0);
407}
408
a0d0e21e 409sub xlate {
108be7fb 410 my($name) = @_;
b9f13614 411 return $name+0 if $name =~ /^\s*\d+\s*$/;
55497cff 412 $name = uc $name;
a0d0e21e 413 $name = "LOG_$name" unless $name =~ /^LOG_/;
748a9306 414 $name = "Sys::Syslog::$name";
2c3b42a1 415 # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
108be7fb 416 my $value = eval { no strict 'refs'; &$name };
2c3b42a1 417 defined $value ? $value : -1;
a0d0e21e
LW
418}
419
420sub connect {
23642f4b
NW
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);
425 }
426 $connected = 0;
427 my @errs = ();
428 my $proto = undef;
429 while ($proto = shift(@fallbackMethods)) {
108be7fb 430 no strict 'refs';
23642f4b 431 my $fn = "connect_$proto";
108be7fb 432 $connected = &$fn(\@errs) if defined &$fn;
23642f4b
NW
433 last if ($connected);
434 }
435
436 $transmit_ok = 0;
437 if ($connected) {
60b8437d 438 $current_proto = $proto;
108be7fb 439 my($old) = select(SYSLOG); $| = 1; select($old);
23642f4b
NW
440 } else {
441 @fallbackMethods = ();
442 foreach my $err (@errs) {
443 carp $err;
444 }
445 croak "no connection to syslog available";
446 }
447}
448
449sub connect_tcp {
450 my ($errs) = @_;
451 unless ($host) {
452 require Sys::Hostname;
453 my($host_uniq) = Sys::Hostname::hostname();
454 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
455 }
456 my $tcp = getprotobyname('tcp');
457 if (!defined $tcp) {
458 push(@{$errs}, "getprotobyname failed for tcp");
459 return 0;
460 }
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");
465 return 0;
466 }
467
468 my $this = sockaddr_in($syslog, INADDR_ANY);
469 my $that = sockaddr_in($syslog, inet_aton($host));
470 if (!$that) {
471 push(@{$errs}, "can't lookup $host");
472 return 0;
473 }
474 if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
475 push(@{$errs}, "tcp socket: $!");
476 return 0;
477 }
478 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
479 setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
60b8437d 480 if (!CORE::connect(SYSLOG,$that)) {
23642f4b
NW
481 push(@{$errs}, "tcp connect: $!");
482 return 0;
483 }
484 $syslog_send = \&_syslog_send_socket;
485 return 1;
486}
487
488sub connect_udp {
489 my ($errs) = @_;
4fc7577b
PP
490 unless ($host) {
491 require Sys::Hostname;
2eae817d 492 my($host_uniq) = Sys::Hostname::hostname();
3e3baf6d 493 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
4fc7577b 494 }
23642f4b
NW
495 my $udp = getprotobyname('udp');
496 if (!defined $udp) {
497 push(@{$errs}, "getprotobyname failed for udp");
498 return 0;
499 }
500 my $syslog = getservbyname('syslog','udp');
501 if (!defined $syslog) {
502 push(@{$errs}, "getservbyname failed for udp");
503 return 0;
504 }
505 my $this = sockaddr_in($syslog, INADDR_ANY);
506 my $that = sockaddr_in($syslog, inet_aton($host));
507 if (!$that) {
508 push(@{$errs}, "can't lookup $host");
509 return 0;
510 }
511 if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
512 push(@{$errs}, "udp socket: $!");
513 return 0;
514 }
60b8437d 515 if (!CORE::connect(SYSLOG,$that)) {
23642f4b
NW
516 push(@{$errs}, "udp connect: $!");
517 return 0;
518 }
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");
524 return 0;
525 }
526 $syslog_send = \&_syslog_send_socket;
527 return 1;
528}
529
530sub connect_stream {
531 my ($errs) = @_;
532 # might want syslog_path to be variable based on syslog.h (if only
533 # it were in there!)
534 $syslog_path = '/dev/conslog';
535 if (!-w $syslog_path) {
536 push(@{$errs}, "stream $syslog_path is not writable");
537 return 0;
538 }
539 if (!open(SYSLOG, ">" . $syslog_path)) {
540 push(@{$errs}, "stream can't open $syslog_path: $!");
541 return 0;
542 }
543 $syslog_send = \&_syslog_send_stream;
544 return 1;
545}
546
547sub connect_unix {
548 my ($errs) = @_;
549 if (length _PATH_LOG()) {
550 $syslog_path = _PATH_LOG();
cb63fe9d 551 } else {
23642f4b
NW
552 push(@{$errs}, "_PATH_LOG not available in syslog.h");
553 return 0;
554 }
555 my $that = sockaddr_un($syslog_path);
556 if (!$that) {
557 push(@{$errs}, "can't locate $syslog_path");
558 return 0;
559 }
560 if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
561 push(@{$errs}, "unix stream socket: $!");
562 return 0;
563 }
60b8437d 564 if (!CORE::connect(SYSLOG,$that)) {
23642f4b
NW
565 if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
566 push(@{$errs}, "unix dgram socket: $!");
567 return 0;
568 }
60b8437d 569 if (!CORE::connect(SYSLOG,$that)) {
23642f4b
NW
570 push(@{$errs}, "unix dgram connect: $!");
571 return 0;
572 }
cb63fe9d 573 }
23642f4b
NW
574 $syslog_send = \&_syslog_send_socket;
575 return 1;
576}
577
578sub connect_console {
579 my ($errs) = @_;
580 if (!-w '/dev/console') {
581 push(@{$errs}, "console is not writable");
582 return 0;
583 }
584 $syslog_send = \&_syslog_send_console;
585 return 1;
586}
587
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...
594sub connection_ok {
dbfdd438 595 return 1 if (defined $current_proto && $current_proto eq 'console');
23642f4b
NW
596 my $rin = '';
597 vec($rin, fileno(SYSLOG), 1) = 1;
598 my $ret = select $rin, undef, $rin, 0;
599 return ($ret ? 0 : 1);
a0d0e21e
LW
600}
601
602sub disconnect {
603 close SYSLOG;
604 $connected = 0;
23642f4b 605 $syslog_send = undef;
a0d0e21e
LW
606}
607
6081;