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