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