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