Sys/Syslog/Syslog.pm

package Sys::Syslog;
require 5.006;
require Exporter;
require DynaLoader;
use Carp;
use strict;

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

# 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 = ( '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;
our ($connected, @fallbackMethods, $syslog_send, $host);

use Socket ':all';
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;       # don't forget this
    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 to report about, for example LOG_USER or LOG_LOCAL0:
see your C<syslog(3)> documentation for the facilities available in
your system.

B<You should use openlog() before calling syslog().>

=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).

If you didn't use openlog() before using syslog(), syslog will try to
guess the I<$ident> by extracting the shortest prefix of I<$format>
that ends in a ":".

=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.
(For example Solaris and IRIX require 'stream' instead of 'unix'.)
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', '%s', '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)

    # Log to UDP port on $remotehost instead of logging locally
    setlogsock('udp');
    $Sys::Syslog::host = $remotehost;
    openlog($program, 'ndelay', 'user');
    syslog('info', 'something happened over here');

=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;
    }
    no strict 'refs';
    *$AUTOLOAD = sub { $val };
    goto &$AUTOLOAD;
}

bootstrap Sys::Syslog $VERSION;

our $maskpri = &LOG_UPTO(&LOG_DEBUG);

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

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

sub setlogmask {
    my $oldmask = $maskpri;
    $maskpri = shift;
    $oldmask;
}
 
sub setlogsock {
    my $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 {
    my $priority = shift;
    my $mask = shift;
    my ($message, $whoami);
    my (@words, $num, $numpri, $numfac, $sum);
    our $facility;
    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 = our $ident;

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

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

    $whoami .= "[$$]" if our $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) {
        our $lo_nowait;
        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 {
    my($name) = @_;
    return $name+0 if $name =~ /^\s*\d+\s*$/;
    $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 { no strict 'refs'; &$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)) {
        no strict 'refs';
        my $fn = "connect_$proto";
        $connected = &$fn(\@errs) if defined &$fn;
        last if ($connected);
    }

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