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