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