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