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