This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
13598e7de060f7f8c0e99d39527666b45689ae11
[perl5.git] / ext / Sys / Syslog / Syslog.pm
1 package Sys::Syslog;
2 require 5.000;
3 require Exporter;
4 require DynaLoader;
5 use Carp;
6
7 @ISA = qw(Exporter DynaLoader);
8 @EXPORT = qw(openlog closelog setlogmask syslog);
9 @EXPORT_OK = qw(setlogsock);
10 $VERSION = '0.04';
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 = ( 'stream', 'unix', 'tcp', 'udp' );
15 my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
16 if ($^O =~ /^(freebsd|linux)$/) {
17     @connectMethods = grep { $_ ne 'udp' } @connectMethods;
18 }
19 my @defaultMethods = @connectMethods;
20 my $syslog_path = undef;
21 my $transmit_ok = 0;
22 my $current_proto = undef;
23 my $failed = undef;
24 my $fail_time = undef;
25
26 use Socket;
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 I<$ident> is prepended to every message.  I<$logopt> contains zero or
57 more of the words I<pid>, I<ndelay>, I<nowait>.  The cons option is
58 ignored, since the failover mechanism will drop down to the console
59 automatically if all other media fail.  I<$facility> specifies the
60 part of the system to report about, for example LOG_USER or LOG_LOCAL0:
61 see your C<syslog(3)> documentation for the facilities available in
62 your system.
63
64 B<You should use openlog() before calling syslog().>
65
66 =item syslog $priority, $format, @args
67
68 If I<$priority> permits, logs I<($format, @args)>
69 printed as by C<printf(3V)>, with the addition that I<%m>
70 is replaced with C<"$!"> (the latest error message).
71
72 If you didn't use openlog() before using syslog(), syslog will try to
73 guess the I<$ident> by extracting the shortest prefix of I<$format>
74 that ends in a ":".
75
76 =item setlogmask $mask_priority
77
78 Sets log mask I<$mask_priority> and returns the old mask.
79
80 =item setlogsock $sock_type [$stream_location] (added in 5.004_02)
81
82 Sets the socket type to be used for the next call to
83 C<openlog()> or C<syslog()> and returns TRUE on success,
84 undef on failure.
85
86 A value of 'unix' will connect to the UNIX domain socket (in some
87 systems 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>,
89 whatever is writable.  A value of 'stream' will connect to the stream
90 indicated by the pathname provided as the optional second parameter.
91 (For example Solaris and IRIX require 'stream' instead of 'unix'.)
92 A value of 'inet' will connect to an INET socket (either tcp or udp,
93 tried in that order) returned by getservbyname(). 'tcp' and 'udp' can
94 also be given as values. The value 'console' will send messages
95 directly to the console, as for the 'cons' option in the logopts in
96 openlog().
97
98 A reference to an array can also be passed as the first parameter.
99 When this calling method is used, the array should contain a list of
100 sock_types which are attempted in order.
101
102 The default is to try tcp, udp, unix, stream, console.
103
104 Giving an invalid value for sock_type will croak.
105
106 =item closelog
107
108 Closes the log file.
109
110 =back
111
112 Note 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');
122
123     setlogsock('unix');
124     openlog("$program $$", 'ndelay', 'user');
125     syslog('notice', 'fooprogram: this is really done');
126
127     setlogsock('inet');
128     $! = 55;
129     syslog('info', 'problem was %m'); # %m == $! in syslog(3)
130
131 =head1 SEE ALSO
132
133 L<syslog(3)>
134
135 =head1 AUTHOR
136
137 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
138 E<lt>F<larry@wall.org>E<gt>.
139
140 UNIX domain sockets added by Sean Robinson
141 E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce 
142 E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.
143
144 Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
145 E<lt>F<tom@compton.nu>E<gt>.
146
147 Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
148
149 Failover to different communication modes by Nick Williams
150 E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
151
152 =cut
153
154 sub AUTOLOAD {
155     # This AUTOLOAD is used to 'autoload' constants from the constant()
156     # XS function.
157     
158     my $constname;
159     our $AUTOLOAD;
160     ($constname = $AUTOLOAD) =~ s/.*:://;
161     croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
162     my ($error, $val) = constant($constname);
163     if ($error) {
164         croak $error;
165     }
166     *$AUTOLOAD = sub { $val };
167     goto &$AUTOLOAD;
168 }
169
170 bootstrap Sys::Syslog $VERSION;
171
172 $maskpri = &LOG_UPTO(&LOG_DEBUG);
173
174 sub openlog {
175     ($ident, $logopt, $facility) = @_;  # package vars
176     $lo_pid = $logopt =~ /\bpid\b/;
177     $lo_ndelay = $logopt =~ /\bndelay\b/;
178     $lo_nowait = $logopt =~ /\bnowait\b/;
179     return 1 unless $lo_ndelay;
180     &connect;
181
182
183 sub closelog {
184     $facility = $ident = '';
185     &disconnect;
186
187
188 sub setlogmask {
189     local($oldmask) = $maskpri;
190     $maskpri = shift;
191     $oldmask;
192 }
193  
194 sub setlogsock {
195     local($setsock) = shift;
196     $syslog_path = shift;
197     &disconnect if $connected;
198     $transmit_ok = 0;
199     @fallbackMethods = ();
200     @connectMethods = @defaultMethods;
201     if (ref $setsock eq 'ARRAY') {
202         @connectMethods = @$setsock;
203     } elsif (lc($setsock) eq 'stream') {
204         unless (defined $syslog_path) {
205             my @try = qw(/dev/log /dev/conslog);
206             if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
207                 unshift @try, &_PATH_LOG;
208             }
209             for my $try (@try) {
210                 if (-w $try) {
211                     $syslog_path = $try;
212                     last;
213                 }
214             }
215             carp "stream passed to setlogsock, but could not find any device"
216                 unless defined $syslog_path;
217         }
218         unless (-w $syslog_path) {
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' );
228         } else {
229             carp 'unix passed to setlogsock, but path not available';
230             return undef;
231         }
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         }
246     } elsif (lc($setsock) eq 'inet') {
247         @connectMethods = ( 'tcp', 'udp' );
248     } elsif (lc($setsock) eq 'console') {
249         @connectMethods = ( 'console' );
250     } else {
251         carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
252     }
253     return 1;
254 }
255
256 sub 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
263     croak "syslog: expecting argument \$priority" unless $priority;
264     croak "syslog: expecting argument \$format"   unless $mask;
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
297     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
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;
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;
338         $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
339         if ($syslog_send) {
340             if (&{$syslog_send}($buf)) {
341                 $transmit_ok++;
342                 return 1;
343             }
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
353 sub _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;
369             }
370         }
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;
378     }
379 }
380
381 sub _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 }
389 sub _syslog_send_socket {
390     my ($buf) = @_;
391     return syswrite(SYSLOG, $buf, length($buf));
392     #return send(SYSLOG, $buf, 0);
393 }
394
395 sub xlate {
396     local($name) = @_;
397     $name = uc $name;
398     $name = "LOG_$name" unless $name =~ /^LOG_/;
399     $name = "Sys::Syslog::$name";
400     # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
401     my $value = eval { &$name };
402     defined $value ? $value : -1;
403 }
404
405 sub connect {
406     @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
407     if ($transmit_ok && $current_proto) {
408         # Retry what we were on, because it's worked in the past.
409         unshift(@fallbackMethods, $current_proto);
410     }
411     $connected = 0;
412     my @errs = ();
413     my $proto = undef;
414     while ($proto = shift(@fallbackMethods)) {
415         my $fn = "connect_$proto";
416         $connected = &$fn(\@errs) unless (!defined &$fn);
417         last if ($connected);
418     }
419
420     $transmit_ok = 0;
421     if ($connected) {
422         $current_proto = $proto;
423         local($old) = select(SYSLOG); $| = 1; select($old);
424     } else {
425         @fallbackMethods = ();
426         foreach my $err (@errs) {
427             carp $err;
428         }
429         croak "no connection to syslog available";
430     }
431 }
432
433 sub connect_tcp {
434     my ($errs) = @_;
435     unless ($host) {
436         require Sys::Hostname;
437         my($host_uniq) = Sys::Hostname::hostname();
438         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
439     }
440     my $tcp = getprotobyname('tcp');
441     if (!defined $tcp) {
442         push(@{$errs}, "getprotobyname failed for tcp");
443         return 0;
444     }
445     my $syslog = getservbyname('syslog','tcp');
446     $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
447     if (!defined $syslog) {
448         push(@{$errs}, "getservbyname failed for tcp");
449         return 0;
450     }
451
452     my $this = sockaddr_in($syslog, INADDR_ANY);
453     my $that = sockaddr_in($syslog, inet_aton($host));
454     if (!$that) {
455         push(@{$errs}, "can't lookup $host");
456         return 0;
457     }
458     if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
459         push(@{$errs}, "tcp socket: $!");
460         return 0;
461     }
462     setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
463     setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
464     if (!CORE::connect(SYSLOG,$that)) {
465         push(@{$errs}, "tcp connect: $!");
466         return 0;
467     }
468     $syslog_send = \&_syslog_send_socket;
469     return 1;
470 }
471
472 sub connect_udp {
473     my ($errs) = @_;
474     unless ($host) {
475         require Sys::Hostname;
476         my($host_uniq) = Sys::Hostname::hostname();
477         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
478     }
479     my $udp = getprotobyname('udp');
480     if (!defined $udp) {
481         push(@{$errs}, "getprotobyname failed for udp");
482         return 0;
483     }
484     my $syslog = getservbyname('syslog','udp');
485     if (!defined $syslog) {
486         push(@{$errs}, "getservbyname failed for udp");
487         return 0;
488     }
489     my $this = sockaddr_in($syslog, INADDR_ANY);
490     my $that = sockaddr_in($syslog, inet_aton($host));
491     if (!$that) {
492         push(@{$errs}, "can't lookup $host");
493         return 0;
494     }
495     if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
496         push(@{$errs}, "udp socket: $!");
497         return 0;
498     }
499     if (!CORE::connect(SYSLOG,$that)) {
500         push(@{$errs}, "udp connect: $!");
501         return 0;
502     }
503     # We want to check that the UDP connect worked. However the only
504     # way to do that is to send a message and see if an ICMP is returned
505     _syslog_send_socket("");
506     if (!connection_ok()) {
507         push(@{$errs}, "udp connect: nobody listening");
508         return 0;
509     }
510     $syslog_send = \&_syslog_send_socket;
511     return 1;
512 }
513
514 sub connect_stream {
515     my ($errs) = @_;
516     # might want syslog_path to be variable based on syslog.h (if only
517     # it were in there!)
518     $syslog_path = '/dev/conslog'; 
519     if (!-w $syslog_path) {
520         push(@{$errs}, "stream $syslog_path is not writable");
521         return 0;
522     }
523     if (!open(SYSLOG, ">" . $syslog_path)) {
524         push(@{$errs}, "stream can't open $syslog_path: $!");
525         return 0;
526     }
527     $syslog_send = \&_syslog_send_stream;
528     return 1;
529 }
530
531 sub connect_unix {
532     my ($errs) = @_;
533     if (length _PATH_LOG()) {
534         $syslog_path = _PATH_LOG();
535     } else {
536         push(@{$errs}, "_PATH_LOG not available in syslog.h");
537         return 0;
538     }
539     my $that = sockaddr_un($syslog_path);
540     if (!$that) {
541         push(@{$errs}, "can't locate $syslog_path");
542         return 0;
543     }
544     if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
545         push(@{$errs}, "unix stream socket: $!");
546         return 0;
547     }
548     if (!CORE::connect(SYSLOG,$that)) {
549         if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
550             push(@{$errs}, "unix dgram socket: $!");
551             return 0;
552         }
553         if (!CORE::connect(SYSLOG,$that)) {
554             push(@{$errs}, "unix dgram connect: $!");
555             return 0;
556         }
557     }
558     $syslog_send = \&_syslog_send_socket;
559     return 1;
560 }
561
562 sub connect_console {
563     my ($errs) = @_;
564     if (!-w '/dev/console') {
565         push(@{$errs}, "console is not writable");
566         return 0;
567     }
568     $syslog_send = \&_syslog_send_console;
569     return 1;
570 }
571
572 # to test if the connection is still good, we need to check if any
573 # errors are present on the connection. The errors will not be raised
574 # by a write. Instead, sockets are made readable and the next read
575 # would cause the error to be returned. Unfortunately the syslog 
576 # 'protocol' never provides anything for us to read. But with 
577 # judicious use of select(), we can see if it would be readable...
578 sub connection_ok {
579     return 1 if (defined $current_proto && $current_proto eq 'console');
580     my $rin = '';
581     vec($rin, fileno(SYSLOG), 1) = 1;
582     my $ret = select $rin, undef, $rin, 0;
583     return ($ret ? 0 : 1);
584 }
585
586 sub disconnect {
587     close SYSLOG;
588     $connected = 0;
589     $syslog_send = undef;
590 }
591
592 1;