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