Upgrade to Sys-Syslog-0.10
[p5sagit/p5-mst-13.2.git] / ext / Sys / Syslog / Syslog.pm
CommitLineData
a0d0e21e 1package Sys::Syslog;
8168e71f 2use strict;
3use Carp;
3b355090 4require 5.006;
a0d0e21e 5require Exporter;
a0d0e21e 6
db9f82cf 7our @ISA = qw(Exporter);
108be7fb 8our @EXPORT = qw(openlog closelog setlogmask syslog);
9our @EXPORT_OK = qw(setlogsock);
8168e71f 10our $VERSION = '0.10';
a0d0e21e 11
23642f4b 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 15if ($^O =~ /^(freebsd|linux)$/) {
16 @connectMethods = grep { $_ ne 'udp' } @connectMethods;
17}
23642f4b 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 29=head1 NAME
30
8168e71f 31Sys::Syslog - Perl interface to the UNIX syslog(3) calls
32
33=head1 VERSION
34
35Version 0.10
5be1dfc7 36
37=head1 SYNOPSIS
38
8168e71f 39 use Sys::Syslog; # all except setlogsock(), or:
40 use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock()
5be1dfc7 41
3ffabb8c 42 setlogsock $sock_type;
3d256c0f 43 openlog $ident, $logopt, $facility; # don't forget this
2eae817d 44 syslog $priority, $format, @args;
5be1dfc7 45 $oldmask = setlogmask $mask_priority;
46 closelog;
47
8168e71f 48
5be1dfc7 49=head1 DESCRIPTION
50
8168e71f 51C<Sys::Syslog> is an interface to the UNIX C<syslog(3)> program.
5be1dfc7 52Call C<syslog()> with a string priority and a list of C<printf()> args
53just like C<syslog(3)>.
54
8168e71f 55
56=head1 EXPORTS
57
58By default, C<Sys::Syslog> exports the following symbols:
59
60 openlog closelog setlogmask syslog
61
62as well as the symbols corresponding to most of your C<syslog(3)> macros.
63The symbol C<setlogsock> can be exported on demand.
64
65
66=head1 FUNCTIONS
5be1dfc7 67
bbc7dcd2 68=over 4
5be1dfc7 69
8168e71f 70=item B<openlog($ident, $logopt, $facility)>
5be1dfc7 71
b91ed019 72Opens the syslog.
8168e71f 73C<$ident> is prepended to every message. C<$logopt> contains zero or
74more of the words C<pid>, C<ndelay>, C<nowait>. The C<cons> option is
23642f4b 75ignored, since the failover mechanism will drop down to the console
8168e71f 76automatically if all other media fail. C<$facility> specifies the
77part of the system to report about, for example C<LOG_USER> or C<LOG_LOCAL0>:
3d256c0f 78see your C<syslog(3)> documentation for the facilities available in
b91ed019 79your system. This function will croak if it can't connect to the syslog
80daemon.
3d256c0f 81
8168e71f 82Note that C<openlog()> now takes three arguments, just like C<openlog(3)>.
83
3d256c0f 84B<You should use openlog() before calling syslog().>
5be1dfc7 85
8168e71f 86=item B<syslog($priority, $message)>
ce43db9b 87
8168e71f 88=item B<syslog($priority, $format, @args)>
5be1dfc7 89
8168e71f 90If C<$priority> permits, logs C<$message> or C<sprintf($format, @args)>
91with the addition that C<%m> in $message or $format is replaced with
caccce6a 92C<"$!"> (the latest error message).
5be1dfc7 93
8168e71f 94If you didn't use C<openlog()> before using C<syslog()>, syslog will
95try to guess the C<$ident> by extracting the shortest prefix of
96C<$format> that ends in a C<":">.
3d256c0f 97
8168e71f 98Note that C<Sys::Syslog> version v0.07 and older passed the C<$message>
99as the formatting string to C<sprintf()> even when no formatting arguments
100were provided. If the code calling C<syslog()> might execute with older
9903e4c8 101versions of this module, make sure to call the function as
8168e71f 102C<syslog($priority, "%s", $message)> instead of C<syslog($priority,
103$message)>. This protects against hostile formatting sequences that
9903e4c8 104might show up if $message contains tainted data.
105
8168e71f 106=item B<setlogmask($mask_priority)>
5be1dfc7 107
8168e71f 108Sets log mask C<$mask_priority> and returns the old mask.
5be1dfc7 109
8168e71f 110=item B<setlogsock($sock_type)>
111
112=item B<setlogsock($sock_type, $stream_location)> (added in 5.004_02)
3ffabb8c 113
cb63fe9d 114Sets the socket type to be used for the next call to
8168e71f 115C<openlog()> or C<syslog()> and returns true on success,
116C<undef> on failure.
3ffabb8c 117
8168e71f 118A value of C<"unix"> will connect to the UNIX domain socket (in some
f66a7beb 119systems a character special device) returned by the C<_PATH_LOG> macro
120(if your system defines it), or F</dev/log> or F</dev/conslog>,
121whatever is writable. A value of 'stream' will connect to the stream
122indicated by the pathname provided as the optional second parameter.
8168e71f 123(For example Solaris and IRIX require C<"stream"> instead of C<"unix">.)
124A value of C<"inet"> will connect to an INET socket (either C<tcp> or C<udp>,
125tried in that order) returned by C<getservbyname()>. C<"tcp"> and C<"udp"> can
126also be given as values. The value C<"console"> will send messages
127directly to the console, as for the C<"cons"> option in the logopts in
128C<openlog()>.
23642f4b 129
130A reference to an array can also be passed as the first parameter.
131When this calling method is used, the array should contain a list of
132sock_types which are attempted in order.
cb63fe9d 133
8168e71f 134The default is to try C<tcp>, C<udp>, C<unix>, C<stream>, C<console>.
23642f4b 135
8168e71f 136Giving an invalid value for C<$sock_type> will croak.
cb63fe9d 137
8168e71f 138=item B<closelog()>
5be1dfc7 139
140Closes the log file.
141
142=back
143
5be1dfc7 144
145=head1 EXAMPLES
146
147 openlog($program, 'cons,pid', 'user');
e6c138cd 148 syslog('info', '%s', 'this is another test');
5be1dfc7 149 syslog('mail|warning', 'this is a better test: %d', time);
150 closelog();
151
152 syslog('debug', 'this is the last test');
cb63fe9d 153
154 setlogsock('unix');
5be1dfc7 155 openlog("$program $$", 'ndelay', 'user');
156 syslog('notice', 'fooprogram: this is really done');
157
cb63fe9d 158 setlogsock('inet');
5be1dfc7 159 $! = 55;
160 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
161
476b65d9 162 # Log to UDP port on $remotehost instead of logging locally
163 setlogsock('udp');
164 $Sys::Syslog::host = $remotehost;
165 openlog($program, 'ndelay', 'user');
166 syslog('info', 'something happened over here');
167
8168e71f 168
169=head1 CONSTANTS
170
171=head2 Facilities
172
173=over 4
174
175=item *
176
177C<LOG_AUTH> - security/authorization messages
178
179=item *
180
181C<LOG_AUTHPRIV> - security/authorization messages (private)
182
183=item *
184
185C<LOG_CRON> - clock daemon (B<cron> and B<at>)
186
187=item *
188
189C<LOG_DAEMON> - system daemons without separate facility value
190
191=item *
192
193C<LOG_FTP> - ftp daemon
194
195=item *
196
197C<LOG_KERN> - kernel messages
198
199=item *
200
201C<LOG_LOCAL0> through C<LOG_LOCAL7> - reserved for local use
202
203=item *
204
205C<LOG_LPR> - line printer subsystem
206
207=item *
208
209C<LOG_MAIL> - mail subsystem
210
211=item *
212
213C<LOG_NEWS> - USENET news subsystem
214
215=item *
216
217C<LOG_SYSLOG> - messages generated internally by B<syslogd>
218
219=item *
220
221C<LOG_USER> (default) - generic user-level messages
222
223=item *
224
225C<LOG_UUCP> - UUCP subsystem
226
227=back
228
229
230=head2 Levels
231
232=over 4
233
234=item *
235
236C<LOG_EMERG> - system is unusable
237
238=item *
239
240C<LOG_ALERT> - action must be taken immediately
241
242=item *
243
244C<LOG_CRIT> - critical conditions
245
246=item *
247
248C<-LOG_ERR> - error conditions
249
250=item *
251
252C<LOG_WARNING> - warning conditions
253
254=item *
255
256C<LOG_NOTICE> - normal, but significant, condition
257
258=item *
259
260C<LOG_INFO> - informational message
261
262=item *
263
264C<LOG_DEBUG> - debug-level message
265
266=back
267
268
269=head1 DIAGNOSTICS
270
271=over 4
272
273=item Invalid argument passed to setlogsock
274
275B<(F)> You gave C<setlogsock()> an invalid value for C<$sock_type>.
276
277=item no connection to syslog available
278
279B<(F)> C<syslog()> failed to connect to the specified socket.
280
281=item stream passed to setlogsock, but %s is not writable
282
283B<(F)> You asked C<setlogsock()> to use a stream socket, but the given
284path is not writable.
285
286=item stream passed to setlogsock, but could not find any device
287
288B<(F)> You asked C<setlogsock()> to use a stream socket, but didn't
289provide a path, and C<Sys::Syslog> was unable to find an appropriate one.
290
291=item tcp passed to setlogsock, but tcp service unavailable
292
293B<(F)> You asked C<setlogsock()> to use a TCP socket, but the service
294is not available on the system.
295
296=item syslog: expecting argument %s
297
298B<(F)> You forgot to give C<syslog()> the indicated argument.
299
300=item syslog: invalid level/facility: %s
301
302B<(F)> You specified an invalid level or facility, like C<LOG_KERN>
303(which is reserved to the kernel).
304
305=item syslog: too many levels given: %s
306
307B<(F)> You specified too many levels.
308
309=item syslog: too many facilities given: %s
310
311B<(F)> You specified too many facilities.
312
313=item syslog: level must be given
314
315B<(F)> You forgot to specify a level.
316
317=item udp passed to setlogsock, but udp service unavailable
318
319B<(F)> You asked C<setlogsock()> to use a UDP socket, but the service
320is not available on the system.
321
322=item unix passed to setlogsock, but path not available
323
324B<(F)> You asked C<setlogsock()> to use a UNIX socket, but C<Sys::Syslog>
325was unable to find an appropriate an appropriate device.
326
327=back
328
329
5be1dfc7 330=head1 SEE ALSO
331
332L<syslog(3)>
333
8168e71f 334
5be1dfc7 335=head1 AUTHOR
336
150b260b 337Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
338E<lt>F<larry@wall.org>E<gt>.
339
340UNIX domain sockets added by Sean Robinson
23642f4b 341E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
8168e71f 342E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the C<perl5-porters> mailing list.
150b260b 343
344Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
345E<lt>F<tom@compton.nu>E<gt>.
5be1dfc7 346
8168e71f 347Code for C<constant()>s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
23642f4b 348
349Failover to different communication modes by Nick Williams
350E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
b903fcff 351
8168e71f 352Extracted from core distribution for publishing on the CPAN by
353SE<eacute>bastien Aperghis-Tramoni E<lt>sebastien@aperghis.netE<gt>.
354
355
356=head1 BUGS
357
358Please report any bugs or feature requests to
359C<bug-sys-syslog at rt.cpan.org>, or through the web interface at
360L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sys-Syslog>.
361I will be notified, and then you'll automatically be notified of progress on
362your bug as I make changes.
363
364
365=head1 SUPPORT
366
367You can find documentation for this module with the perldoc command.
368
369 perldoc Sys::Syslog
370
371You can also look for information at:
372
373=over 4
374
375=item * AnnoCPAN: Annotated CPAN documentation
376
377L<http://annocpan.org/dist/Sys-Syslog>
378
379=item * CPAN Ratings
380
381L<http://cpanratings.perl.org/d/Sys-Syslog>
382
383=item * RT: CPAN's request tracker
384
385L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-Syslog>
386
387=item * Search CPAN
388
389L<http://search.cpan.org/dist/Sys-Syslog>
390
391=back
392
393
394=head1 LICENSE
395
396This program is free software; you can redistribute it and/or modify it
397under the same terms as Perl itself.
398
5be1dfc7 399=cut
a0d0e21e 400
8ce86de8 401sub AUTOLOAD {
402 # This AUTOLOAD is used to 'autoload' constants from the constant()
403 # XS function.
23642f4b 404
8ce86de8 405 my $constname;
406 our $AUTOLOAD;
407 ($constname = $AUTOLOAD) =~ s/.*:://;
b903fcff 408 croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
409 my ($error, $val) = constant($constname);
410 if ($error) {
411 croak $error;
8ce86de8 412 }
108be7fb 413 no strict 'refs';
8ce86de8 414 *$AUTOLOAD = sub { $val };
415 goto &$AUTOLOAD;
416}
417
db9f82cf 418require XSLoader;
419XSLoader::load('Sys::Syslog', $VERSION);
a0d0e21e 420
108be7fb 421our $maskpri = &LOG_UPTO(&LOG_DEBUG);
a0d0e21e 422
423sub openlog {
108be7fb 424 our ($ident, $logopt, $facility) = @_; # package vars
425 our $lo_pid = $logopt =~ /\bpid\b/;
426 our $lo_ndelay = $logopt =~ /\bndelay\b/;
427 our $lo_nowait = $logopt =~ /\bnowait\b/;
a8710ca1 428 return 1 unless $lo_ndelay;
429 &connect;
a0d0e21e 430}
431
432sub closelog {
108be7fb 433 our $facility = our $ident = '';
a0d0e21e 434 &disconnect;
435}
436
437sub setlogmask {
108be7fb 438 my $oldmask = $maskpri;
a0d0e21e 439 $maskpri = shift;
440 $oldmask;
441}
442
cb63fe9d 443sub setlogsock {
108be7fb 444 my $setsock = shift;
23642f4b 445 $syslog_path = shift;
3ffabb8c 446 &disconnect if $connected;
23642f4b 447 $transmit_ok = 0;
448 @fallbackMethods = ();
449 @connectMethods = @defaultMethods;
450 if (ref $setsock eq 'ARRAY') {
451 @connectMethods = @$setsock;
452 } elsif (lc($setsock) eq 'stream') {
f66a7beb 453 unless (defined $syslog_path) {
454 my @try = qw(/dev/log /dev/conslog);
e863979d 455 if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
f66a7beb 456 unshift @try, &_PATH_LOG;
457 }
458 for my $try (@try) {
459 if (-w $try) {
460 $syslog_path = $try;
461 last;
462 }
463 }
8168e71f 464 croak "stream passed to setlogsock, but could not find any device"
e863979d 465 unless defined $syslog_path;
f66a7beb 466 }
e863979d 467 unless (-w $syslog_path) {
8168e71f 468 croak "stream passed to setlogsock, but $syslog_path is not writable";
23642f4b 469 return undef;
470 } else {
471 @connectMethods = ( 'stream' );
472 }
473 } elsif (lc($setsock) eq 'unix') {
474 if (length _PATH_LOG() && !defined $syslog_path) {
475 $syslog_path = _PATH_LOG();
476 @connectMethods = ( 'unix' );
3ffabb8c 477 } else {
8168e71f 478 croak 'unix passed to setlogsock, but path not available';
23642f4b 479 return undef;
3ffabb8c 480 }
23642f4b 481 } elsif (lc($setsock) eq 'tcp') {
482 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
483 @connectMethods = ( 'tcp' );
484 } else {
8168e71f 485 croak "tcp passed to setlogsock, but tcp service unavailable";
23642f4b 486 return undef;
487 }
488 } elsif (lc($setsock) eq 'udp') {
489 if (getservbyname('syslog', 'udp')) {
490 @connectMethods = ( 'udp' );
491 } else {
8168e71f 492 croak "udp passed to setlogsock, but udp service unavailable";
23642f4b 493 return undef;
494 }
cb63fe9d 495 } elsif (lc($setsock) eq 'inet') {
23642f4b 496 @connectMethods = ( 'tcp', 'udp' );
497 } elsif (lc($setsock) eq 'console') {
498 @connectMethods = ( 'console' );
cb63fe9d 499 } else {
8168e71f 500 croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
cb63fe9d 501 }
f8b75b0c 502 return 1;
cb63fe9d 503}
504
a0d0e21e 505sub syslog {
108be7fb 506 my $priority = shift;
507 my $mask = shift;
508 my ($message, $whoami);
509 my (@words, $num, $numpri, $numfac, $sum);
510 our $facility;
a0d0e21e 511 local($facility) = $facility; # may need to change temporarily.
512
78ac6fa8 513 croak "syslog: expecting argument \$priority" unless $priority;
514 croak "syslog: expecting argument \$format" unless $mask;
a0d0e21e 515
516 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
517 undef $numpri;
518 undef $numfac;
519 foreach (@words) {
520 $num = &xlate($_); # Translate word to number.
521 if (/^kern$/ || $num < 0) {
522 croak "syslog: invalid level/facility: $_";
523 }
524 elsif ($num <= &LOG_PRIMASK) {
525 croak "syslog: too many levels given: $_" if defined($numpri);
526 $numpri = $num;
527 return 0 unless &LOG_MASK($numpri) & $maskpri;
528 }
529 else {
530 croak "syslog: too many facilities given: $_" if defined($numfac);
531 $facility = $_;
532 $numfac = $num;
533 }
534 }
535
536 croak "syslog: level must be given" unless defined($numpri);
537
538 if (!defined($numfac)) { # Facility not specified in this call.
539 $facility = 'user' unless $facility;
540 $numfac = &xlate($facility);
541 }
542
543 &connect unless $connected;
544
108be7fb 545 $whoami = our $ident;
a0d0e21e 546
5dad0344 547 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
a0d0e21e 548 $whoami = $1;
549 $mask = $2;
550 }
551
552 unless ($whoami) {
553 ($whoami = getlogin) ||
554 ($whoami = getpwuid($<)) ||
555 ($whoami = 'syslog');
556 }
557
108be7fb 558 $whoami .= "[$$]" if our $lo_pid;
a0d0e21e 559
5007285b 560 if ($mask =~ /%m/) {
561 my $err = $!;
562 # escape percent signs if sprintf will be called
563 $err =~ s/%/%%/g if @_;
564 # replace %m with $err, if preceded by an even number of percent signs
565 $mask =~ s/(?<!%)((?:%%)*)%m/$1$err/g;
566 }
567
a0d0e21e 568 $mask .= "\n" unless $mask =~ /\n$/;
ce43db9b 569 $message = @_ ? sprintf($mask, @_) : $mask;
a0d0e21e 570
571 $sum = $numpri + $numfac;
23642f4b 572 my $buf = "<$sum>$whoami: $message\0";
573
574 # it's possible that we'll get an error from sending
575 # (e.g. if method is UDP and there is no UDP listener,
576 # then we'll get ECONNREFUSED on the send). So what we
577 # want to do at this point is to fallback onto a different
578 # connection method.
579 while (scalar @fallbackMethods || $syslog_send) {
580 if ($failed && (time - $fail_time) > 60) {
581 # it's been a while... maybe things have been fixed
582 @fallbackMethods = ();
583 disconnect();
584 $transmit_ok = 0; # make it look like a fresh attempt
585 &connect;
586 }
587 if ($connected && !connection_ok()) {
588 # Something was OK, but has now broken. Remember coz we'll
589 # want to go back to what used to be OK.
590 $failed = $current_proto unless $failed;
591 $fail_time = time;
592 disconnect();
593 }
594 &connect unless $connected;
60b8437d 595 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
23642f4b 596 if ($syslog_send) {
597 if (&{$syslog_send}($buf)) {
598 $transmit_ok++;
599 return 1;
a0d0e21e 600 }
23642f4b 601 # typically doesn't happen, since errors are rare from write().
602 disconnect();
603 }
604 }
605 # could not send, could not fallback onto a working
606 # connection method. Lose.
607 return 0;
608}
609
610sub _syslog_send_console {
611 my ($buf) = @_;
612 chop($buf); # delete the NUL from the end
613 # The console print is a method which could block
614 # so we do it in a child process and always return success
615 # to the caller.
616 if (my $pid = fork) {
108be7fb 617 our $lo_nowait;
23642f4b 618 if ($lo_nowait) {
619 return 1;
620 } else {
621 if (waitpid($pid, 0) >= 0) {
622 return ($? >> 8);
623 } else {
624 # it's possible that the caller has other
625 # plans for SIGCHLD, so let's not interfere
626 return 1;
a0d0e21e 627 }
628 }
23642f4b 629 } else {
630 if (open(CONS, ">/dev/console")) {
631 my $ret = print CONS $buf . "\r";
632 exit ($ret) if defined $pid;
633 close CONS;
634 }
635 exit if defined $pid;
a0d0e21e 636 }
637}
638
23642f4b 639sub _syslog_send_stream {
640 my ($buf) = @_;
641 # XXX: this only works if the OS stream implementation makes a write
642 # look like a putmsg() with simple header. For instance it works on
643 # Solaris 8 but not Solaris 7.
644 # To be correct, it should use a STREAMS API, but perl doesn't have one.
645 return syswrite(SYSLOG, $buf, length($buf));
646}
8168e71f 647
23642f4b 648sub _syslog_send_socket {
649 my ($buf) = @_;
650 return syswrite(SYSLOG, $buf, length($buf));
651 #return send(SYSLOG, $buf, 0);
652}
653
a0d0e21e 654sub xlate {
108be7fb 655 my($name) = @_;
b9f13614 656 return $name+0 if $name =~ /^\s*\d+\s*$/;
55497cff 657 $name = uc $name;
a0d0e21e 658 $name = "LOG_$name" unless $name =~ /^LOG_/;
748a9306 659 $name = "Sys::Syslog::$name";
2c3b42a1 660 # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
108be7fb 661 my $value = eval { no strict 'refs'; &$name };
2c3b42a1 662 defined $value ? $value : -1;
a0d0e21e 663}
664
665sub connect {
23642f4b 666 @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
667 if ($transmit_ok && $current_proto) {
668 # Retry what we were on, because it's worked in the past.
669 unshift(@fallbackMethods, $current_proto);
670 }
671 $connected = 0;
672 my @errs = ();
673 my $proto = undef;
674 while ($proto = shift(@fallbackMethods)) {
108be7fb 675 no strict 'refs';
23642f4b 676 my $fn = "connect_$proto";
108be7fb 677 $connected = &$fn(\@errs) if defined &$fn;
23642f4b 678 last if ($connected);
679 }
680
681 $transmit_ok = 0;
682 if ($connected) {
60b8437d 683 $current_proto = $proto;
108be7fb 684 my($old) = select(SYSLOG); $| = 1; select($old);
23642f4b 685 } else {
686 @fallbackMethods = ();
687 foreach my $err (@errs) {
688 carp $err;
689 }
690 croak "no connection to syslog available";
691 }
692}
693
694sub connect_tcp {
695 my ($errs) = @_;
696 unless ($host) {
697 require Sys::Hostname;
698 my($host_uniq) = Sys::Hostname::hostname();
699 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
700 }
701 my $tcp = getprotobyname('tcp');
702 if (!defined $tcp) {
703 push(@{$errs}, "getprotobyname failed for tcp");
704 return 0;
705 }
706 my $syslog = getservbyname('syslog','tcp');
707 $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
708 if (!defined $syslog) {
709 push(@{$errs}, "getservbyname failed for tcp");
710 return 0;
711 }
712
713 my $this = sockaddr_in($syslog, INADDR_ANY);
714 my $that = sockaddr_in($syslog, inet_aton($host));
715 if (!$that) {
716 push(@{$errs}, "can't lookup $host");
717 return 0;
718 }
719 if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
720 push(@{$errs}, "tcp socket: $!");
721 return 0;
722 }
723 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
724 setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
60b8437d 725 if (!CORE::connect(SYSLOG,$that)) {
23642f4b 726 push(@{$errs}, "tcp connect: $!");
727 return 0;
728 }
729 $syslog_send = \&_syslog_send_socket;
730 return 1;
731}
732
733sub connect_udp {
734 my ($errs) = @_;
4fc7577b 735 unless ($host) {
736 require Sys::Hostname;
2eae817d 737 my($host_uniq) = Sys::Hostname::hostname();
3e3baf6d 738 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
4fc7577b 739 }
23642f4b 740 my $udp = getprotobyname('udp');
741 if (!defined $udp) {
742 push(@{$errs}, "getprotobyname failed for udp");
743 return 0;
744 }
745 my $syslog = getservbyname('syslog','udp');
746 if (!defined $syslog) {
747 push(@{$errs}, "getservbyname failed for udp");
748 return 0;
749 }
750 my $this = sockaddr_in($syslog, INADDR_ANY);
751 my $that = sockaddr_in($syslog, inet_aton($host));
752 if (!$that) {
753 push(@{$errs}, "can't lookup $host");
754 return 0;
755 }
756 if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
757 push(@{$errs}, "udp socket: $!");
758 return 0;
759 }
60b8437d 760 if (!CORE::connect(SYSLOG,$that)) {
23642f4b 761 push(@{$errs}, "udp connect: $!");
762 return 0;
763 }
764 # We want to check that the UDP connect worked. However the only
765 # way to do that is to send a message and see if an ICMP is returned
766 _syslog_send_socket("");
767 if (!connection_ok()) {
768 push(@{$errs}, "udp connect: nobody listening");
769 return 0;
770 }
771 $syslog_send = \&_syslog_send_socket;
772 return 1;
773}
774
775sub connect_stream {
776 my ($errs) = @_;
777 # might want syslog_path to be variable based on syslog.h (if only
778 # it were in there!)
779 $syslog_path = '/dev/conslog';
780 if (!-w $syslog_path) {
781 push(@{$errs}, "stream $syslog_path is not writable");
782 return 0;
783 }
784 if (!open(SYSLOG, ">" . $syslog_path)) {
785 push(@{$errs}, "stream can't open $syslog_path: $!");
786 return 0;
787 }
788 $syslog_send = \&_syslog_send_stream;
789 return 1;
790}
791
792sub connect_unix {
793 my ($errs) = @_;
794 if (length _PATH_LOG()) {
795 $syslog_path = _PATH_LOG();
cb63fe9d 796 } else {
23642f4b 797 push(@{$errs}, "_PATH_LOG not available in syslog.h");
798 return 0;
799 }
800 my $that = sockaddr_un($syslog_path);
801 if (!$that) {
802 push(@{$errs}, "can't locate $syslog_path");
803 return 0;
804 }
805 if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
806 push(@{$errs}, "unix stream socket: $!");
807 return 0;
808 }
60b8437d 809 if (!CORE::connect(SYSLOG,$that)) {
23642f4b 810 if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
811 push(@{$errs}, "unix dgram socket: $!");
812 return 0;
813 }
60b8437d 814 if (!CORE::connect(SYSLOG,$that)) {
23642f4b 815 push(@{$errs}, "unix dgram connect: $!");
816 return 0;
817 }
cb63fe9d 818 }
23642f4b 819 $syslog_send = \&_syslog_send_socket;
820 return 1;
821}
822
823sub connect_console {
824 my ($errs) = @_;
825 if (!-w '/dev/console') {
826 push(@{$errs}, "console is not writable");
827 return 0;
828 }
829 $syslog_send = \&_syslog_send_console;
830 return 1;
831}
832
833# to test if the connection is still good, we need to check if any
834# errors are present on the connection. The errors will not be raised
835# by a write. Instead, sockets are made readable and the next read
836# would cause the error to be returned. Unfortunately the syslog
837# 'protocol' never provides anything for us to read. But with
838# judicious use of select(), we can see if it would be readable...
839sub connection_ok {
dbfdd438 840 return 1 if (defined $current_proto && $current_proto eq 'console');
23642f4b 841 my $rin = '';
842 vec($rin, fileno(SYSLOG), 1) = 1;
843 my $ret = select $rin, undef, $rin, 0;
844 return ($ret ? 0 : 1);
a0d0e21e 845}
846
847sub disconnect {
848 close SYSLOG;
849 $connected = 0;
23642f4b 850 $syslog_send = undef;
a0d0e21e 851}
852
8531;