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