ext/Sys/Syslog/Syslog.pm

   1 package Sys::Syslog;
   2 use strict;
   3 use Carp;
   4 require 5.006;
   5 require Exporter;
   6
   7 our @ISA = qw(Exporter);
   8 our @EXPORT = qw(openlog closelog setlogmask syslog);
   9 our @EXPORT_OK = qw(setlogsock);
  10 our $VERSION = '0.10';
  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 - Perl interface to the UNIX syslog(3) calls
  32
  33 =head1 VERSION
  34
  35 Version 0.10
  36
  37 =head1 SYNOPSIS
  38
  39     use Sys::Syslog;                          # all except setlogsock(), or:
  40     use Sys::Syslog qw(:DEFAULT setlogsock);  # default set, plus setlogsock()
  41
  42     setlogsock $sock_type;
  43     openlog $ident, $logopt, $facility;       # don't forget this
  44     syslog $priority, $format, @args;
  45     $oldmask = setlogmask $mask_priority;
  46     closelog;
  47
  48
  49 =head1 DESCRIPTION
  50
  51 C<Sys::Syslog> is an interface to the UNIX C<syslog(3)> program.
  52 Call C<syslog()> with a string priority and a list of C<printf()> args
  53 just like C<syslog(3)>.
  54
  55
  56 =head1 EXPORTS
  57
  58 By default, C<Sys::Syslog> exports the following symbols:
  59
  60     openlog closelog setlogmask syslog
  61
  62 as well as the symbols corresponding to most of your C<syslog(3)> macros.
  63 The symbol C<setlogsock> can be exported on demand.
  64
  65
  66 =head1 FUNCTIONS
  67
  68 =over 4
  69
  70 =item B<openlog($ident, $logopt, $facility)>
  71
  72 Opens the syslog.
  73 C<$ident> is prepended to every message.  C<$logopt> contains zero or
  74 more of the words C<pid>, C<ndelay>, C<nowait>.  The C<cons> option is
  75 ignored, since the failover mechanism will drop down to the console
  76 automatically if all other media fail.  C<$facility> specifies the
  77 part of the system to report about, for example C<LOG_USER> or C<LOG_LOCAL0>:
  78 see your C<syslog(3)> documentation for the facilities available in
  79 your system. This function will croak if it can't connect to the syslog
  80 daemon.
  81
  82 Note that C<openlog()> now takes three arguments, just like C<openlog(3)>.
  83
  84 B<You should use openlog() before calling syslog().>
  85
  86 =item B<syslog($priority, $message)>
  87
  88 =item B<syslog($priority, $format, @args)>
  89
  90 If C<$priority> permits, logs C<$message> or C<sprintf($format, @args)>
  91 with the addition that C<%m> in $message or $format is replaced with
  92 C<"$!"> (the latest error message).
  93
  94 If you didn't use C<openlog()> before using C<syslog()>, syslog will
  95 try to guess the C<$ident> by extracting the shortest prefix of
  96 C<$format> that ends in a C<":">.
  97
  98 Note that C<Sys::Syslog> version v0.07 and older passed the C<$message>
  99 as the formatting string to C<sprintf()> even when no formatting arguments
 100 were provided.  If the code calling C<syslog()> might execute with older
 101 versions of this module, make sure to call the function as
 102 C<syslog($priority, "%s", $message)> instead of C<syslog($priority,
 103 $message)>.  This protects against hostile formatting sequences that
 104 might show up if $message contains tainted data.
 105
 106 =item B<setlogmask($mask_priority)>
 107
 108 Sets log mask C<$mask_priority> and returns the old mask.
 109
 110 =item B<setlogsock($sock_type)>
 111
 112 =item B<setlogsock($sock_type, $stream_location)> (added in 5.004_02)
 113
 114 Sets the socket type to be used for the next call to
 115 C<openlog()> or C<syslog()> and returns true on success,
 116 C<undef> on failure.
 117
 118 A value of C<"unix"> will connect to the UNIX domain socket (in some
 119 systems 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>,
 121 whatever is writable.  A value of 'stream' will connect to the stream
 122 indicated by the pathname provided as the optional second parameter.
 123 (For example Solaris and IRIX require C<"stream"> instead of C<"unix">.)
 124 A value of C<"inet"> will connect to an INET socket (either C<tcp> or C<udp>,
 125 tried in that order) returned by C<getservbyname()>. C<"tcp"> and C<"udp"> can
 126 also be given as values. The value C<"console"> will send messages
 127 directly to the console, as for the C<"cons"> option in the logopts in
 128 C<openlog()>.
 129
 130 A reference to an array can also be passed as the first parameter.
 131 When this calling method is used, the array should contain a list of
 132 sock_types which are attempted in order.
 133
 134 The default is to try C<tcp>, C<udp>, C<unix>, C<stream>, C<console>.
 135
 136 Giving an invalid value for C<$sock_type> will croak.
 137
 138 =item B<closelog()>
 139
 140 Closes the log file.
 141
 142 =back
 143
 144
 145 =head1 EXAMPLES
 146
 147     openlog($program, 'cons,pid', 'user');
 148     syslog('info', '%s', 'this is another test');
 149     syslog('mail|warning', 'this is a better test: %d', time);
 150     closelog();
 151
 152     syslog('debug', 'this is the last test');
 153
 154     setlogsock('unix');
 155     openlog("$program $$", 'ndelay', 'user');
 156     syslog('notice', 'fooprogram: this is really done');
 157
 158     setlogsock('inet');
 159     $! = 55;
 160     syslog('info', 'problem was %m'); # %m == $! in syslog(3)
 161
 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
 168
 169 =head1 CONSTANTS
 170
 171 =head2 Facilities
 172
 173 =over 4
 174
 175 =item *
 176
 177 C<LOG_AUTH> - security/authorization messages
 178
 179 =item *
 180
 181 C<LOG_AUTHPRIV> - security/authorization messages (private)
 182
 183 =item *
 184
 185 C<LOG_CRON> - clock daemon (B<cron> and B<at>)
 186
 187 =item *
 188
 189 C<LOG_DAEMON> - system daemons without separate facility value
 190
 191 =item *
 192
 193 C<LOG_FTP> - ftp daemon
 194
 195 =item *
 196
 197 C<LOG_KERN> - kernel messages
 198
 199 =item *
 200
 201 C<LOG_LOCAL0> through C<LOG_LOCAL7> - reserved for local use
 202
 203 =item *
 204
 205 C<LOG_LPR> - line printer subsystem
 206
 207 =item *
 208
 209 C<LOG_MAIL> - mail subsystem
 210
 211 =item *
 212
 213 C<LOG_NEWS> - USENET news subsystem
 214
 215 =item *
 216
 217 C<LOG_SYSLOG> - messages generated internally by B<syslogd>
 218
 219 =item *
 220
 221 C<LOG_USER> (default) - generic user-level messages
 222
 223 =item *
 224
 225 C<LOG_UUCP> - UUCP subsystem
 226
 227 =back
 228
 229
 230 =head2 Levels
 231
 232 =over 4
 233
 234 =item *
 235
 236 C<LOG_EMERG> - system is unusable
 237
 238 =item *
 239
 240 C<LOG_ALERT> - action must be taken immediately
 241
 242 =item *
 243
 244 C<LOG_CRIT> - critical conditions
 245
 246 =item *
 247
 248 C<-LOG_ERR> - error conditions
 249
 250 =item *
 251
 252 C<LOG_WARNING> - warning conditions
 253
 254 =item *
 255
 256 C<LOG_NOTICE> - normal, but significant, condition
 257
 258 =item *
 259
 260 C<LOG_INFO> - informational message
 261
 262 =item *
 263
 264 C<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
 275 B<(F)> You gave C<setlogsock()> an invalid value for C<$sock_type>.
 276
 277 =item no connection to syslog available
 278
 279 B<(F)> C<syslog()> failed to connect to the specified socket.
 280
 281 =item stream passed to setlogsock, but %s is not writable
 282
 283 B<(F)> You asked C<setlogsock()> to use a stream socket, but the given
 284 path is not writable.
 285
 286 =item stream passed to setlogsock, but could not find any device
 287
 288 B<(F)> You asked C<setlogsock()> to use a stream socket, but didn't
 289 provide 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
 293 B<(F)> You asked C<setlogsock()> to use a TCP socket, but the service
 294 is not available on the system.
 295
 296 =item syslog: expecting argument %s
 297
 298 B<(F)> You forgot to give C<syslog()> the indicated argument.
 299
 300 =item syslog: invalid level/facility: %s
 301
 302 B<(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
 307 B<(F)> You specified too many levels.
 308
 309 =item syslog: too many facilities given: %s
 310
 311 B<(F)> You specified too many facilities.
 312
 313 =item syslog: level must be given
 314
 315 B<(F)> You forgot to specify a level.
 316
 317 =item udp passed to setlogsock, but udp service unavailable
 318
 319 B<(F)> You asked C<setlogsock()> to use a UDP socket, but the service
 320 is not available on the system.
 321
 322 =item unix passed to setlogsock, but path not available
 323
 324 B<(F)> You asked C<setlogsock()> to use a UNIX socket, but C<Sys::Syslog>
 325 was unable to find an appropriate an appropriate device.
 326
 327 =back
 328
 329
 330 =head1 SEE ALSO
 331
 332 L<syslog(3)>
 333
 334
 335 =head1 AUTHOR
 336
 337 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
 338 E<lt>F<larry@wall.org>E<gt>.
 339
 340 UNIX domain sockets added by Sean Robinson
 341 E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce
 342 E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the C<perl5-porters> mailing list.
 343
 344 Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
 345 E<lt>F<tom@compton.nu>E<gt>.
 346
 347 Code for C<constant()>s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
 348
 349 Failover to different communication modes by Nick Williams
 350 E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
 351
 352 Extracted from core distribution for publishing on the CPAN by
 353 SE<eacute>bastien Aperghis-Tramoni E<lt>sebastien@aperghis.netE<gt>.
 354
 355
 356 =head1 BUGS
 357
 358 Please report any bugs or feature requests to
 359 C<bug-sys-syslog at rt.cpan.org>, or through the web interface at
 360 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sys-Syslog>.
 361 I will be notified, and then you'll automatically be notified of progress on
 362 your bug as I make changes.
 363
 364
 365 =head1 SUPPORT
 366
 367 You can find documentation for this module with the perldoc command.
 368
 369     perldoc Sys::Syslog
 370
 371 You can also look for information at:
 372
 373 =over 4
 374
 375 =item * AnnoCPAN: Annotated CPAN documentation
 376
 377 L<http://annocpan.org/dist/Sys-Syslog>
 378
 379 =item * CPAN Ratings
 380
 381 L<http://cpanratings.perl.org/d/Sys-Syslog>
 382
 383 =item * RT: CPAN's request tracker
 384
 385 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-Syslog>
 386
 387 =item * Search CPAN
 388
 389 L<http://search.cpan.org/dist/Sys-Syslog>
 390
 391 =back
 392
 393
 394 =head1 LICENSE
 395
 396 This program is free software; you can redistribute it and/or modify it
 397 under the same terms as Perl itself.
 398
 399 =cut
 400
 401 sub AUTOLOAD {
 402     # This AUTOLOAD is used to 'autoload' constants from the constant()
 403     # XS function.
 404
 405     my $constname;
 406     our $AUTOLOAD;
 407     ($constname = $AUTOLOAD) =~ s/.*:://;
 408     croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
 409     my ($error, $val) = constant($constname);
 410     if ($error) {
 411         croak $error;
 412     }
 413     no strict 'refs';
 414     *$AUTOLOAD = sub { $val };
 415     goto &$AUTOLOAD;
 416 }
 417
 418 require XSLoader;
 419 XSLoader::load('Sys::Syslog', $VERSION);
 420
 421 our $maskpri = &LOG_UPTO(&LOG_DEBUG);
 422
 423 sub openlog {
 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/;
 428     return 1 unless $lo_ndelay;
 429     &connect;
 430 }
 431
 432 sub closelog {
 433     our $facility = our $ident = '';
 434     &disconnect;
 435 }
 436
 437 sub setlogmask {
 438     my $oldmask = $maskpri;
 439     $maskpri = shift;
 440     $oldmask;
 441 }
 442
 443 sub setlogsock {
 444     my $setsock = shift;
 445     $syslog_path = shift;
 446     &disconnect if $connected;
 447     $transmit_ok = 0;
 448     @fallbackMethods = ();
 449     @connectMethods = @defaultMethods;
 450     if (ref $setsock eq 'ARRAY') {
 451         @connectMethods = @$setsock;
 452     } elsif (lc($setsock) eq 'stream') {
 453         unless (defined $syslog_path) {
 454             my @try = qw(/dev/log /dev/conslog);
 455             if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
 456                 unshift @try, &_PATH_LOG;
 457             }
 458             for my $try (@try) {
 459                 if (-w $try) {
 460                     $syslog_path = $try;
 461                     last;
 462                 }
 463             }
 464             croak "stream passed to setlogsock, but could not find any device"
 465                 unless defined $syslog_path;
 466         }
 467         unless (-w $syslog_path) {
 468             croak "stream passed to setlogsock, but $syslog_path is not writable";
 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' );
 477         } else {
 478             croak 'unix passed to setlogsock, but path not available';
 479             return undef;
 480         }
 481     } elsif (lc($setsock) eq 'tcp') {
 482         if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
 483             @connectMethods = ( 'tcp' );
 484         } else {
 485             croak "tcp passed to setlogsock, but tcp service unavailable";
 486             return undef;
 487         }
 488     } elsif (lc($setsock) eq 'udp') {
 489         if (getservbyname('syslog', 'udp')) {
 490             @connectMethods = ( 'udp' );
 491         } else {
 492             croak "udp passed to setlogsock, but udp service unavailable";
 493             return undef;
 494         }
 495     } elsif (lc($setsock) eq 'inet') {
 496         @connectMethods = ( 'tcp', 'udp' );
 497     } elsif (lc($setsock) eq 'console') {
 498         @connectMethods = ( 'console' );
 499     } else {
 500         croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
 501     }
 502     return 1;
 503 }
 504
 505 sub syslog {
 506     my $priority = shift;
 507     my $mask = shift;
 508     my ($message, $whoami);
 509     my (@words, $num, $numpri, $numfac, $sum);
 510     our $facility;
 511     local($facility) = $facility;       # may need to change temporarily.
 512
 513     croak "syslog: expecting argument \$priority" unless $priority;
 514     croak "syslog: expecting argument \$format"   unless $mask;
 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
 545     $whoami = our $ident;
 546
 547     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
 548         $whoami = $1;
 549         $mask = $2;
 550     }
 551
 552     unless ($whoami) {
 553         ($whoami = getlogin) ||
 554             ($whoami = getpwuid($<)) ||
 555                 ($whoami = 'syslog');
 556     }
 557
 558     $whoami .= "[$$]" if our $lo_pid;
 559
 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
 568     $mask .= "\n" unless $mask =~ /\n$/;
 569     $message = @_ ? sprintf($mask, @_) : $mask;
 570
 571     $sum = $numpri + $numfac;
 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;
 595         $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
 596         if ($syslog_send) {
 597             if (&{$syslog_send}($buf)) {
 598                 $transmit_ok++;
 599                 return 1;
 600             }
 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
 610 sub _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) {
 617         our $lo_nowait;
 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;
 627             }
 628         }
 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;
 636     }
 637 }
 638
 639 sub _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 }
 647
 648 sub _syslog_send_socket {
 649     my ($buf) = @_;
 650     return syswrite(SYSLOG, $buf, length($buf));
 651     #return send(SYSLOG, $buf, 0);
 652 }
 653
 654 sub xlate {
 655     my($name) = @_;
 656     return $name+0 if $name =~ /^\s*\d+\s*$/;
 657     $name = uc $name;
 658     $name = "LOG_$name" unless $name =~ /^LOG_/;
 659     $name = "Sys::Syslog::$name";
 660     # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
 661     my $value = eval { no strict 'refs'; &$name };
 662     defined $value ? $value : -1;
 663 }
 664
 665 sub connect {
 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)) {
 675         no strict 'refs';
 676         my $fn = "connect_$proto";
 677         $connected = &$fn(\@errs) if defined &$fn;
 678         last if ($connected);
 679     }
 680
 681     $transmit_ok = 0;
 682     if ($connected) {
 683         $current_proto = $proto;
 684         my($old) = select(SYSLOG); $| = 1; select($old);
 685     } else {
 686         @fallbackMethods = ();
 687         foreach my $err (@errs) {
 688             carp $err;
 689         }
 690         croak "no connection to syslog available";
 691     }
 692 }
 693
 694 sub 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);
 725     if (!CORE::connect(SYSLOG,$that)) {
 726         push(@{$errs}, "tcp connect: $!");
 727         return 0;
 728     }
 729     $syslog_send = \&_syslog_send_socket;
 730     return 1;
 731 }
 732
 733 sub connect_udp {
 734     my ($errs) = @_;
 735     unless ($host) {
 736         require Sys::Hostname;
 737         my($host_uniq) = Sys::Hostname::hostname();
 738         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 739     }
 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     }
 760     if (!CORE::connect(SYSLOG,$that)) {
 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
 775 sub 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
 792 sub connect_unix {
 793     my ($errs) = @_;
 794     if (length _PATH_LOG()) {
 795         $syslog_path = _PATH_LOG();
 796     } else {
 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     }
 809     if (!CORE::connect(SYSLOG,$that)) {
 810         if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
 811             push(@{$errs}, "unix dgram socket: $!");
 812             return 0;
 813         }
 814         if (!CORE::connect(SYSLOG,$that)) {
 815             push(@{$errs}, "unix dgram connect: $!");
 816             return 0;
 817         }
 818     }
 819     $syslog_send = \&_syslog_send_socket;
 820     return 1;
 821 }
 822
 823 sub 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...
 839 sub connection_ok {
 840     return 1 if (defined $current_proto && $current_proto eq 'console');
 841     my $rin = '';
 842     vec($rin, fileno(SYSLOG), 1) = 1;
 843     my $ret = select $rin, undef, $rin, 0;
 844     return ($ret ? 0 : 1);
 845 }
 846
 847 sub disconnect {
 848     close SYSLOG;
 849     $connected = 0;
 850     $syslog_send = undef;
 851 }
 852
 853 1;