ext/Sys/Syslog/Syslog.pm

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