[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;

# adapted from syslog.pl
#
# Tom Christiansen <tchrist@convex.com>
# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
# NOTE: openlog now takes three arguments, just like openlog(3)
# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
#  with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>

=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 returned by
the C<_PATH_LOG> macro (if your system defines it) in F<syslog.ph>.  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') {
	$syslog_path = '/dev/log' unless($syslog_path);
	if (!-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: expected both priority and mask" unless $mask && $priority;

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