ext/Sys/Syslog/Syslog.pm

   1 package Sys::Syslog;
   2 require 5.006;
   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.06';
  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;       # 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', '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     *$AUTOLOAD = sub { $val };
 173     goto &$AUTOLOAD;
 174 }
 175
 176 bootstrap Sys::Syslog $VERSION;
 177
 178 $maskpri = &LOG_UPTO(&LOG_DEBUG);
 179
 180 sub openlog {
 181     ($ident, $logopt, $facility) = @_;  # package vars
 182     $lo_pid = $logopt =~ /\bpid\b/;
 183     $lo_ndelay = $logopt =~ /\bndelay\b/;
 184     $lo_nowait = $logopt =~ /\bnowait\b/;
 185     return 1 unless $lo_ndelay;
 186     &connect;
 187 }
 188
 189 sub closelog {
 190     $facility = $ident = '';
 191     &disconnect;
 192 }
 193
 194 sub setlogmask {
 195     local($oldmask) = $maskpri;
 196     $maskpri = shift;
 197     $oldmask;
 198 }
 199
 200 sub setlogsock {
 201     local($setsock) = shift;
 202     $syslog_path = shift;
 203     &disconnect if $connected;
 204     $transmit_ok = 0;
 205     @fallbackMethods = ();
 206     @connectMethods = @defaultMethods;
 207     if (ref $setsock eq 'ARRAY') {
 208         @connectMethods = @$setsock;
 209     } elsif (lc($setsock) eq 'stream') {
 210         unless (defined $syslog_path) {
 211             my @try = qw(/dev/log /dev/conslog);
 212             if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
 213                 unshift @try, &_PATH_LOG;
 214             }
 215             for my $try (@try) {
 216                 if (-w $try) {
 217                     $syslog_path = $try;
 218                     last;
 219                 }
 220             }
 221             carp "stream passed to setlogsock, but could not find any device"
 222                 unless defined $syslog_path;
 223         }
 224         unless (-w $syslog_path) {
 225             carp "stream passed to setlogsock, but $syslog_path is not writable";
 226             return undef;
 227         } else {
 228             @connectMethods = ( 'stream' );
 229         }
 230     } elsif (lc($setsock) eq 'unix') {
 231         if (length _PATH_LOG() && !defined $syslog_path) {
 232             $syslog_path = _PATH_LOG();
 233             @connectMethods = ( 'unix' );
 234         } else {
 235             carp 'unix passed to setlogsock, but path not available';
 236             return undef;
 237         }
 238     } elsif (lc($setsock) eq 'tcp') {
 239         if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
 240             @connectMethods = ( 'tcp' );
 241         } else {
 242             carp "tcp passed to setlogsock, but tcp service unavailable";
 243             return undef;
 244         }
 245     } elsif (lc($setsock) eq 'udp') {
 246         if (getservbyname('syslog', 'udp')) {
 247             @connectMethods = ( 'udp' );
 248         } else {
 249             carp "udp passed to setlogsock, but udp service unavailable";
 250             return undef;
 251         }
 252     } elsif (lc($setsock) eq 'inet') {
 253         @connectMethods = ( 'tcp', 'udp' );
 254     } elsif (lc($setsock) eq 'console') {
 255         @connectMethods = ( 'console' );
 256     } else {
 257         carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
 258     }
 259     return 1;
 260 }
 261
 262 sub syslog {
 263     local($priority) = shift;
 264     local($mask) = shift;
 265     local($message, $whoami);
 266     local(@words, $num, $numpri, $numfac, $sum);
 267     local($facility) = $facility;       # may need to change temporarily.
 268
 269     croak "syslog: expecting argument \$priority" unless $priority;
 270     croak "syslog: expecting argument \$format"   unless $mask;
 271
 272     @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
 273     undef $numpri;
 274     undef $numfac;
 275     foreach (@words) {
 276         $num = &xlate($_);              # Translate word to number.
 277         if (/^kern$/ || $num < 0) {
 278             croak "syslog: invalid level/facility: $_";
 279         }
 280         elsif ($num <= &LOG_PRIMASK) {
 281             croak "syslog: too many levels given: $_" if defined($numpri);
 282             $numpri = $num;
 283             return 0 unless &LOG_MASK($numpri) & $maskpri;
 284         }
 285         else {
 286             croak "syslog: too many facilities given: $_" if defined($numfac);
 287             $facility = $_;
 288             $numfac = $num;
 289         }
 290     }
 291
 292     croak "syslog: level must be given" unless defined($numpri);
 293
 294     if (!defined($numfac)) {    # Facility not specified in this call.
 295         $facility = 'user' unless $facility;
 296         $numfac = &xlate($facility);
 297     }
 298
 299     &connect unless $connected;
 300
 301     $whoami = $ident;
 302
 303     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
 304         $whoami = $1;
 305         $mask = $2;
 306     }
 307
 308     unless ($whoami) {
 309         ($whoami = getlogin) ||
 310             ($whoami = getpwuid($<)) ||
 311                 ($whoami = 'syslog');
 312     }
 313
 314     $whoami .= "[$$]" if $lo_pid;
 315
 316     $mask =~ s/(?<!%)%m/$!/g;
 317     $mask .= "\n" unless $mask =~ /\n$/;
 318     $message = sprintf ($mask, @_);
 319
 320     $sum = $numpri + $numfac;
 321     my $buf = "<$sum>$whoami: $message\0";
 322
 323     # it's possible that we'll get an error from sending
 324     # (e.g. if method is UDP and there is no UDP listener,
 325     # then we'll get ECONNREFUSED on the send). So what we
 326     # want to do at this point is to fallback onto a different
 327     # connection method.
 328     while (scalar @fallbackMethods || $syslog_send) {
 329         if ($failed && (time - $fail_time) > 60) {
 330             # it's been a while... maybe things have been fixed
 331             @fallbackMethods = ();
 332             disconnect();
 333             $transmit_ok = 0; # make it look like a fresh attempt
 334             &connect;
 335         }
 336         if ($connected && !connection_ok()) {
 337             # Something was OK, but has now broken. Remember coz we'll
 338             # want to go back to what used to be OK.
 339             $failed = $current_proto unless $failed;
 340             $fail_time = time;
 341             disconnect();
 342         }
 343         &connect unless $connected;
 344         $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
 345         if ($syslog_send) {
 346             if (&{$syslog_send}($buf)) {
 347                 $transmit_ok++;
 348                 return 1;
 349             }
 350             # typically doesn't happen, since errors are rare from write().
 351             disconnect();
 352         }
 353     }
 354     # could not send, could not fallback onto a working
 355     # connection method. Lose.
 356     return 0;
 357 }
 358
 359 sub _syslog_send_console {
 360     my ($buf) = @_;
 361     chop($buf); # delete the NUL from the end
 362     # The console print is a method which could block
 363     # so we do it in a child process and always return success
 364     # to the caller.
 365     if (my $pid = fork) {
 366         if ($lo_nowait) {
 367             return 1;
 368         } else {
 369             if (waitpid($pid, 0) >= 0) {
 370                 return ($? >> 8);
 371             } else {
 372                 # it's possible that the caller has other
 373                 # plans for SIGCHLD, so let's not interfere
 374                 return 1;
 375             }
 376         }
 377     } else {
 378         if (open(CONS, ">/dev/console")) {
 379             my $ret = print CONS $buf . "\r";
 380             exit ($ret) if defined $pid;
 381             close CONS;
 382         }
 383         exit if defined $pid;
 384     }
 385 }
 386
 387 sub _syslog_send_stream {
 388     my ($buf) = @_;
 389     # XXX: this only works if the OS stream implementation makes a write
 390     # look like a putmsg() with simple header. For instance it works on
 391     # Solaris 8 but not Solaris 7.
 392     # To be correct, it should use a STREAMS API, but perl doesn't have one.
 393     return syswrite(SYSLOG, $buf, length($buf));
 394 }
 395 sub _syslog_send_socket {
 396     my ($buf) = @_;
 397     return syswrite(SYSLOG, $buf, length($buf));
 398     #return send(SYSLOG, $buf, 0);
 399 }
 400
 401 sub xlate {
 402     local($name) = @_;
 403     return $name+0 if $name =~ /^\s*\d+\s*$/;
 404     $name = uc $name;
 405     $name = "LOG_$name" unless $name =~ /^LOG_/;
 406     $name = "Sys::Syslog::$name";
 407     # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
 408     my $value = eval { &$name };
 409     defined $value ? $value : -1;
 410 }
 411
 412 sub connect {
 413     @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
 414     if ($transmit_ok && $current_proto) {
 415         # Retry what we were on, because it's worked in the past.
 416         unshift(@fallbackMethods, $current_proto);
 417     }
 418     $connected = 0;
 419     my @errs = ();
 420     my $proto = undef;
 421     while ($proto = shift(@fallbackMethods)) {
 422         my $fn = "connect_$proto";
 423         $connected = &$fn(\@errs) unless (!defined &$fn);
 424         last if ($connected);
 425     }
 426
 427     $transmit_ok = 0;
 428     if ($connected) {
 429         $current_proto = $proto;
 430         local($old) = select(SYSLOG); $| = 1; select($old);
 431     } else {
 432         @fallbackMethods = ();
 433         foreach my $err (@errs) {
 434             carp $err;
 435         }
 436         croak "no connection to syslog available";
 437     }
 438 }
 439
 440 sub connect_tcp {
 441     my ($errs) = @_;
 442     unless ($host) {
 443         require Sys::Hostname;
 444         my($host_uniq) = Sys::Hostname::hostname();
 445         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 446     }
 447     my $tcp = getprotobyname('tcp');
 448     if (!defined $tcp) {
 449         push(@{$errs}, "getprotobyname failed for tcp");
 450         return 0;
 451     }
 452     my $syslog = getservbyname('syslog','tcp');
 453     $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
 454     if (!defined $syslog) {
 455         push(@{$errs}, "getservbyname failed for tcp");
 456         return 0;
 457     }
 458
 459     my $this = sockaddr_in($syslog, INADDR_ANY);
 460     my $that = sockaddr_in($syslog, inet_aton($host));
 461     if (!$that) {
 462         push(@{$errs}, "can't lookup $host");
 463         return 0;
 464     }
 465     if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
 466         push(@{$errs}, "tcp socket: $!");
 467         return 0;
 468     }
 469     setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
 470     setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
 471     if (!CORE::connect(SYSLOG,$that)) {
 472         push(@{$errs}, "tcp connect: $!");
 473         return 0;
 474     }
 475     $syslog_send = \&_syslog_send_socket;
 476     return 1;
 477 }
 478
 479 sub connect_udp {
 480     my ($errs) = @_;
 481     unless ($host) {
 482         require Sys::Hostname;
 483         my($host_uniq) = Sys::Hostname::hostname();
 484         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 485     }
 486     my $udp = getprotobyname('udp');
 487     if (!defined $udp) {
 488         push(@{$errs}, "getprotobyname failed for udp");
 489         return 0;
 490     }
 491     my $syslog = getservbyname('syslog','udp');
 492     if (!defined $syslog) {
 493         push(@{$errs}, "getservbyname failed for udp");
 494         return 0;
 495     }
 496     my $this = sockaddr_in($syslog, INADDR_ANY);
 497     my $that = sockaddr_in($syslog, inet_aton($host));
 498     if (!$that) {
 499         push(@{$errs}, "can't lookup $host");
 500         return 0;
 501     }
 502     if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
 503         push(@{$errs}, "udp socket: $!");
 504         return 0;
 505     }
 506     if (!CORE::connect(SYSLOG,$that)) {
 507         push(@{$errs}, "udp connect: $!");
 508         return 0;
 509     }
 510     # We want to check that the UDP connect worked. However the only
 511     # way to do that is to send a message and see if an ICMP is returned
 512     _syslog_send_socket("");
 513     if (!connection_ok()) {
 514         push(@{$errs}, "udp connect: nobody listening");
 515         return 0;
 516     }
 517     $syslog_send = \&_syslog_send_socket;
 518     return 1;
 519 }
 520
 521 sub connect_stream {
 522     my ($errs) = @_;
 523     # might want syslog_path to be variable based on syslog.h (if only
 524     # it were in there!)
 525     $syslog_path = '/dev/conslog';
 526     if (!-w $syslog_path) {
 527         push(@{$errs}, "stream $syslog_path is not writable");
 528         return 0;
 529     }
 530     if (!open(SYSLOG, ">" . $syslog_path)) {
 531         push(@{$errs}, "stream can't open $syslog_path: $!");
 532         return 0;
 533     }
 534     $syslog_send = \&_syslog_send_stream;
 535     return 1;
 536 }
 537
 538 sub connect_unix {
 539     my ($errs) = @_;
 540     if (length _PATH_LOG()) {
 541         $syslog_path = _PATH_LOG();
 542     } else {
 543         push(@{$errs}, "_PATH_LOG not available in syslog.h");
 544         return 0;
 545     }
 546     my $that = sockaddr_un($syslog_path);
 547     if (!$that) {
 548         push(@{$errs}, "can't locate $syslog_path");
 549         return 0;
 550     }
 551     if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
 552         push(@{$errs}, "unix stream socket: $!");
 553         return 0;
 554     }
 555     if (!CORE::connect(SYSLOG,$that)) {
 556         if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
 557             push(@{$errs}, "unix dgram socket: $!");
 558             return 0;
 559         }
 560         if (!CORE::connect(SYSLOG,$that)) {
 561             push(@{$errs}, "unix dgram connect: $!");
 562             return 0;
 563         }
 564     }
 565     $syslog_send = \&_syslog_send_socket;
 566     return 1;
 567 }
 568
 569 sub connect_console {
 570     my ($errs) = @_;
 571     if (!-w '/dev/console') {
 572         push(@{$errs}, "console is not writable");
 573         return 0;
 574     }
 575     $syslog_send = \&_syslog_send_console;
 576     return 1;
 577 }
 578
 579 # to test if the connection is still good, we need to check if any
 580 # errors are present on the connection. The errors will not be raised
 581 # by a write. Instead, sockets are made readable and the next read
 582 # would cause the error to be returned. Unfortunately the syslog
 583 # 'protocol' never provides anything for us to read. But with
 584 # judicious use of select(), we can see if it would be readable...
 585 sub connection_ok {
 586     return 1 if (defined $current_proto && $current_proto eq 'console');
 587     my $rin = '';
 588     vec($rin, fileno(SYSLOG), 1) = 1;
 589     my $ret = select $rin, undef, $rin, 0;
 590     return ($ret ? 0 : 1);
 591 }
 592
 593 sub disconnect {
 594     close SYSLOG;
 595     $connected = 0;
 596     $syslog_send = undef;
 597 }
 598
 599 1;