ext/Sys/Syslog/Syslog.pm

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