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