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