ext/Sys/Syslog/Syslog.pm

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