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