[p5sagit/p5-mst-13.2.git] / ext / Sys / Syslog / Syslog.pm

package Sys::Syslog;
require 5.000;
require Exporter;
require DynaLoader;
use Carp;

@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(openlog closelog setlogmask syslog);
@EXPORT_OK = qw(setlogsock);
$VERSION = '0.03';

# it would be nice to try stream/unix first, since that will be
# most efficient. However streams are dodgy - see _syslog_send_stream
#my @connectMethods = ( 'stream', 'unix', 'tcp', 'udp' );
my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' );
if ($^O =~ /^(freebsd|linux)$/) {
    @connectMethods = grep { $_ ne 'udp' } @connectMethods;
}
my @defaultMethods = @connectMethods;
my $syslog_path = undef;
my $transmit_ok = 0;
my $current_proto = undef;
my $failed = undef;
my $fail_time = undef;

use Socket;
use Sys::Hostname;

=head1 NAME

Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls

=head1 SYNOPSIS

    use Sys::Syslog;                          # all except setlogsock, or:
    use Sys::Syslog qw(:DEFAULT setlogsock);  # default set, plus setlogsock

    setlogsock $sock_type;
    openlog $ident, $logopt, $facility;
    syslog $priority, $format, @args;
    $oldmask = setlogmask $mask_priority;
    closelog;

=head1 DESCRIPTION

Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
Call C<syslog()> with a string priority and a list of C<printf()> args
just like C<syslog(3)>.

Syslog provides the functions:

=over 4

=item openlog $ident, $logopt, $facility

I<$ident> is prepended to every message.  I<$logopt> contains zero or
more of the words I<pid>, I<ndelay>, I<nowait>.  The cons option is
ignored, since the failover mechanism will drop down to the console
automatically if all other media fail.  I<$facility> specifies the
part of the system

=item syslog $priority, $format, @args

If I<$priority> permits, logs I<($format, @args)>
printed as by C<printf(3V)>, with the addition that I<%m>
is replaced with C<"$!"> (the latest error message).

=item setlogmask $mask_priority

Sets log mask I<$mask_priority> and returns the old mask.

=item setlogsock $sock_type [$stream_location] (added in 5.004_02)

Sets the socket type to be used for the next call to
C<openlog()> or C<syslog()> and returns TRUE on success,
undef on failure.

A value of 'unix' will connect to the UNIX domain socket (in some
systems a character special device) returned by the C<_PATH_LOG> macro
(if your system defines it), or F</dev/log> or F</dev/conslog>,
whatever is writable.  A value of 'stream' will connect to the stream
indicated by the pathname provided as the optional second parameter.
A value of 'inet' will connect to an INET socket (either tcp or udp,
tried in that order) returned by getservbyname(). 'tcp' and 'udp' can
also be given as values. The value 'console' will send messages
directly to the console, as for the 'cons' option in the logopts in
openlog().

A reference to an array can also be passed as the first parameter.
When this calling method is used, the array should contain a list of
sock_types which are attempted in order.

The default is to try tcp, udp, unix, stream, console.

Giving an invalid value for sock_type will croak.

=item closelog

Closes the log file.

=back

Note that C<openlog> now takes three arguments, just like C<openlog(3)>.

=head1 EXAMPLES

    openlog($program, 'cons,pid', 'user');
    syslog('info', 'this is another test');
    syslog('mail|warning', 'this is a better test: %d', time);
    closelog();

    syslog('debug', 'this is the last test');

    setlogsock('unix');
    openlog("$program $$", 'ndelay', 'user');
    syslog('notice', 'fooprogram: this is really done');

    setlogsock('inet');
    $! = 55;
    syslog('info', 'problem was %m'); # %m == $! in syslog(3)

=head1 SEE ALSO

L<syslog(3)>

=head1 AUTHOR

Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
E<lt>F<larry@wall.org>E<gt>.

UNIX domain sockets added by Sean Robinson
E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce 
E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list.

Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
E<lt>F<tom@compton.nu>E<gt>.

Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.

Failover to different communication modes by Nick Williams
E<lt>F<Nick.Williams@morganstanley.com>E<gt>.

=cut

sub AUTOLOAD {
    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.
    
    my $constname;
    our $AUTOLOAD;
    ($constname = $AUTOLOAD) =~ s/.*:://;
    croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
    my ($error, $val) = constant($constname);
    if ($error) {
	croak $error;
    }
    *$AUTOLOAD = sub { $val };
    goto &$AUTOLOAD;
}

bootstrap Sys::Syslog $VERSION;

$maskpri = &LOG_UPTO(&LOG_DEBUG);

sub openlog {
    ($ident, $logopt, $facility) = @_;  # package vars
    $lo_pid = $logopt =~ /\bpid\b/;
    $lo_ndelay = $logopt =~ /\bndelay\b/;
    $lo_nowait = $logopt =~ /\bnowait\b/;
    return 1 unless $lo_ndelay;
    &connect;
} 

sub closelog {
    $facility = $ident = '';
    &disconnect;
} 

sub setlogmask {
    local($oldmask) = $maskpri;
    $maskpri = shift;
    $oldmask;
}
 
sub setlogsock {
    local($setsock) = shift;
    $syslog_path = shift;
    &disconnect if $connected;
    $transmit_ok = 0;
    @fallbackMethods = ();
    @connectMethods = @defaultMethods;
    if (ref $setsock eq 'ARRAY') {
	@connectMethods = @$setsock;
    } elsif (lc($setsock) eq 'stream') {
	unless (defined $syslog_path) {
	    my @try = qw(/dev/log /dev/conslog);
	    if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
		unshift @try, &_PATH_LOG;
            }
	    for my $try (@try) {
		if (-w $try) {
		    $syslog_path = $try;
		    last;
		}
	    }
	    carp "stream passed to setlogsock, but could not find any device"
		unless defined $syslog_path;
        }
	unless (-w $syslog_path) {
	    carp "stream passed to setlogsock, but $syslog_path is not writable";
	    return undef;
	} else {
	    @connectMethods = ( 'stream' );
	}
    } elsif (lc($setsock) eq 'unix') {
        if (length _PATH_LOG() && !defined $syslog_path) {
	    $syslog_path = _PATH_LOG();
	    @connectMethods = ( 'unix' );
        } else {
	    carp 'unix passed to setlogsock, but path not available';
	    return undef;
        }
    } elsif (lc($setsock) eq 'tcp') {
	if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
	    @connectMethods = ( 'tcp' );
	} else {
	    carp "tcp passed to setlogsock, but tcp service unavailable";
	    return undef;
	}
    } elsif (lc($setsock) eq 'udp') {
	if (getservbyname('syslog', 'udp')) {
	    @connectMethods = ( 'udp' );
	} else {
	    carp "udp passed to setlogsock, but udp service unavailable";
	    return undef;
	}
    } elsif (lc($setsock) eq 'inet') {
	@connectMethods = ( 'tcp', 'udp' );
    } elsif (lc($setsock) eq 'console') {
	@connectMethods = ( 'console' );
    } else {
        carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
    }
    return 1;
}

sub syslog {
    local($priority) = shift;
    local($mask) = shift;
    local($message, $whoami);
    local(@words, $num, $numpri, $numfac, $sum);
    local($facility) = $facility;	# may need to change temporarily.

    croak "syslog: expecting argument \$priority" unless $priority;
    croak "syslog: expecting argument \$format"   unless $mask;

    @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
    undef $numpri;
    undef $numfac;
    foreach (@words) {
	$num = &xlate($_);		# Translate word to number.
	if (/^kern$/ || $num < 0) {
	    croak "syslog: invalid level/facility: $_";
	}
	elsif ($num <= &LOG_PRIMASK) {
	    croak "syslog: too many levels given: $_" if defined($numpri);
	    $numpri = $num;
	    return 0 unless &LOG_MASK($numpri) & $maskpri;
	}
	else {
	    croak "syslog: too many facilities given: $_" if defined($numfac);
	    $facility = $_;
	    $numfac = $num;
	}
    }

    croak "syslog: level must be given" unless defined($numpri);

    if (!defined($numfac)) {	# Facility not specified in this call.
	$facility = 'user' unless $facility;
	$numfac = &xlate($facility);
    }

    &connect unless $connected;

    $whoami = $ident;

    if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
	$whoami = $1;
	$mask = $2;
    } 

    unless ($whoami) {
	($whoami = getlogin) ||
	    ($whoami = getpwuid($<)) ||
		($whoami = 'syslog');
    }

    $whoami .= "[$$]" if $lo_pid;

    $mask =~ s/%m/$!/g;
    $mask .= "\n" unless $mask =~ /\n$/;
    $message = sprintf ($mask, @_);

    $sum = $numpri + $numfac;
    my $buf = "<$sum>$whoami: $message\0";

    # it's possible that we'll get an error from sending
    # (e.g. if method is UDP and there is no UDP listener,
    # then we'll get ECONNREFUSED on the send). So what we
    # want to do at this point is to fallback onto a different
    # connection method.
    while (scalar @fallbackMethods || $syslog_send) {
	if ($failed && (time - $fail_time) > 60) {
	    # it's been a while... maybe things have been fixed
	    @fallbackMethods = ();
	    disconnect();
	    $transmit_ok = 0; # make it look like a fresh attempt
	    &connect;
        }
	if ($connected && !connection_ok()) {
	    # Something was OK, but has now broken. Remember coz we'll
	    # want to go back to what used to be OK.
	    $failed = $current_proto unless $failed;
	    $fail_time = time;
	    disconnect();
	}
	&connect unless $connected;
	$failed = undef if ($current_proto && $failed && $current_proto eq $failed);
	if ($syslog_send) {
	    if (&{$syslog_send}($buf)) {
		$transmit_ok++;
		return 1;
	    }
	    # typically doesn't happen, since errors are rare from write().
	    disconnect();
	}
    }
    # could not send, could not fallback onto a working
    # connection method. Lose.
    return 0;
}

sub _syslog_send_console {
    my ($buf) = @_;
    chop($buf); # delete the NUL from the end
    # The console print is a method which could block
    # so we do it in a child process and always return success
    # to the caller.
    if (my $pid = fork) {
	if ($lo_nowait) {
	    return 1;
	} else {
	    if (waitpid($pid, 0) >= 0) {
	    	return ($? >> 8);
	    } else {
		# it's possible that the caller has other
		# plans for SIGCHLD, so let's not interfere
		return 1;
	    }
	}
    } else {
        if (open(CONS, ">/dev/console")) {
	    my $ret = print CONS $buf . "\r";
	    exit ($ret) if defined $pid;
	    close CONS;
	}
	exit if defined $pid;
    }
}

sub _syslog_send_stream {
    my ($buf) = @_;
    # XXX: this only works if the OS stream implementation makes a write 
    # look like a putmsg() with simple header. For instance it works on 
    # Solaris 8 but not Solaris 7.
    # To be correct, it should use a STREAMS API, but perl doesn't have one.
    return syswrite(SYSLOG, $buf, length($buf));
}
sub _syslog_send_socket {
    my ($buf) = @_;
    return syswrite(SYSLOG, $buf, length($buf));
    #return send(SYSLOG, $buf, 0);
}

sub xlate {
    local($name) = @_;
    $name = uc $name;
    $name = "LOG_$name" unless $name =~ /^LOG_/;
    $name = "Sys::Syslog::$name";
    # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
    my $value = eval { &$name };
    defined $value ? $value : -1;
}

sub connect {
    @fallbackMethods = @connectMethods unless (scalar @fallbackMethods);
    if ($transmit_ok && $current_proto) {
	# Retry what we were on, because it's worked in the past.
	unshift(@fallbackMethods, $current_proto);
    }
    $connected = 0;
    my @errs = ();
    my $proto = undef;
    while ($proto = shift(@fallbackMethods)) {
	my $fn = "connect_$proto";
	$connected = &$fn(\@errs) unless (!defined &$fn);
	last if ($connected);
    }

    $transmit_ok = 0;
    if ($connected) {
	$current_proto = $proto;
        local($old) = select(SYSLOG); $| = 1; select($old);
    } else {
	@fallbackMethods = ();
	foreach my $err (@errs) {
	    carp $err;
	}
	croak "no connection to syslog available";
    }
}

sub connect_tcp {
    my ($errs) = @_;
    unless ($host) {
	require Sys::Hostname;
	my($host_uniq) = Sys::Hostname::hostname();
	($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
    }
    my $tcp = getprotobyname('tcp');
    if (!defined $tcp) {
	push(@{$errs}, "getprotobyname failed for tcp");
	return 0;
    }
    my $syslog = getservbyname('syslog','tcp');
    $syslog = getservbyname('syslogng','tcp') unless (defined $syslog);
    if (!defined $syslog) {
	push(@{$errs}, "getservbyname failed for tcp");
	return 0;
    }

    my $this = sockaddr_in($syslog, INADDR_ANY);
    my $that = sockaddr_in($syslog, inet_aton($host));
    if (!$that) {
	push(@{$errs}, "can't lookup $host");
	return 0;
    }
    if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) {
	push(@{$errs}, "tcp socket: $!");
	return 0;
    }
    setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
    setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1);
    if (!CORE::connect(SYSLOG,$that)) {
	push(@{$errs}, "tcp connect: $!");
	return 0;
    }
    $syslog_send = \&_syslog_send_socket;
    return 1;
}

sub connect_udp {
    my ($errs) = @_;
    unless ($host) {
	require Sys::Hostname;
	my($host_uniq) = Sys::Hostname::hostname();
	($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
    }
    my $udp = getprotobyname('udp');
    if (!defined $udp) {
	push(@{$errs}, "getprotobyname failed for udp");
	return 0;
    }
    my $syslog = getservbyname('syslog','udp');
    if (!defined $syslog) {
	push(@{$errs}, "getservbyname failed for udp");
	return 0;
    }
    my $this = sockaddr_in($syslog, INADDR_ANY);
    my $that = sockaddr_in($syslog, inet_aton($host));
    if (!$that) {
	push(@{$errs}, "can't lookup $host");
	return 0;
    }
    if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) {
	push(@{$errs}, "udp socket: $!");
	return 0;
    }
    if (!CORE::connect(SYSLOG,$that)) {
	push(@{$errs}, "udp connect: $!");
	return 0;
    }
    # We want to check that the UDP connect worked. However the only
    # way to do that is to send a message and see if an ICMP is returned
    _syslog_send_socket("");
    if (!connection_ok()) {
	push(@{$errs}, "udp connect: nobody listening");
	return 0;
    }
    $syslog_send = \&_syslog_send_socket;
    return 1;
}

sub connect_stream {
    my ($errs) = @_;
    # might want syslog_path to be variable based on syslog.h (if only
    # it were in there!)
    $syslog_path = '/dev/conslog'; 
    if (!-w $syslog_path) {
	push(@{$errs}, "stream $syslog_path is not writable");
	return 0;
    }
    if (!open(SYSLOG, ">" . $syslog_path)) {
	push(@{$errs}, "stream can't open $syslog_path: $!");
	return 0;
    }
    $syslog_send = \&_syslog_send_stream;
    return 1;
}

sub connect_unix {
    my ($errs) = @_;
    if (length _PATH_LOG()) {
	$syslog_path = _PATH_LOG();
    } else {
        push(@{$errs}, "_PATH_LOG not available in syslog.h");
	return 0;
    }
    my $that = sockaddr_un($syslog_path);
    if (!$that) {
	push(@{$errs}, "can't locate $syslog_path");
	return 0;
    }
    if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) {
	push(@{$errs}, "unix stream socket: $!");
	return 0;
    }
    if (!CORE::connect(SYSLOG,$that)) {
        if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) {
	    push(@{$errs}, "unix dgram socket: $!");
	    return 0;
	}
        if (!CORE::connect(SYSLOG,$that)) {
	    push(@{$errs}, "unix dgram connect: $!");
	    return 0;
	}
    }
    $syslog_send = \&_syslog_send_socket;
    return 1;
}

sub connect_console {
    my ($errs) = @_;
    if (!-w '/dev/console') {
	push(@{$errs}, "console is not writable");
	return 0;
    }
    $syslog_send = \&_syslog_send_console;
    return 1;
}

# to test if the connection is still good, we need to check if any
# errors are present on the connection. The errors will not be raised
# by a write. Instead, sockets are made readable and the next read
# would cause the error to be returned. Unfortunately the syslog 
# 'protocol' never provides anything for us to read. But with 
# judicious use of select(), we can see if it would be readable...
sub connection_ok {
    return 1 if (defined $current_proto && $current_proto eq 'console');
    my $rin = '';
    vec($rin, fileno(SYSLOG), 1) = 1;
    my $ret = select $rin, undef, $rin, 0;
    return ($ret ? 0 : 1);
}

sub disconnect {
    close SYSLOG;
    $connected = 0;
    $syslog_send = undef;
}

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