[perl5.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.01';

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>

# Todo: enable connect to try all three types before failing (auto setlogsock)?

=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

=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<cons>, I<nowait>.
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 (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
C<_PATH_LOG> in F<syslog.ph>.  A value of 'inet' will connect to an
INET socket returned by getservbyname().  Any other value croaks.

The default is for the INET socket to be used.

=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 <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>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 "& not defined" if $constname eq 'constant';
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {
	croak "Your vendor has not defined Sys::Syslog macro $constname";
    }
    *$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_cons = $logopt =~ /\bcons\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;
    &disconnect if $connected;
    if (lc($setsock) eq 'unix') {
        if (defined &_PATH_LOG) {
            $sock_type = 1;
        } else {
            return undef;
        }
    } elsif (lc($setsock) eq 'inet') {
        if (getservbyname('syslog','udp')) {
            undef($sock_type);
        } else {
            return undef;
        }
    } else {
        croak "Invalid argument passed to setlogsock; must be 'unix' 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;
    unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
	if ($lo_cons) {
	    if ($pid = fork) {
		unless ($lo_nowait) {
		    $died = waitpid($pid, 0);
		}
	    }
	    else {
		if (open(CONS,">/dev/console")) {
		    print CONS "<$facility.$priority>$whoami: $message\r";
		    exit if defined $pid;		# if fork failed, we're parent
		    close CONS;
		}
	    }
	}
    }
}

sub xlate {
    local($name) = @_;
    $name = uc $name;
    $name = "LOG_$name" unless $name =~ /^LOG_/;
    $name = "Sys::Syslog::$name";
    eval { &$name } || -1;
}

sub connect {
    unless ($host) {
	require Sys::Hostname;
	my($host_uniq) = Sys::Hostname::hostname();
	($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
    }
    unless ( $sock_type ) {
        my $udp = getprotobyname('udp');
        my $syslog = getservbyname('syslog','udp');
        my $this = sockaddr_in($syslog, INADDR_ANY);
        my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
        socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
        connect(SYSLOG,$that)                            || croak "connect: $!";
    } else {
        my $syslog = &_PATH_LOG                          || croak "_PATH_LOG not found in syslog.ph";
        my $that = sockaddr_un($syslog)                  || croak "Can't locate $syslog";
        socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)             || croak "socket: $!";
        if (!connect(SYSLOG,$that)) {
            socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)          || croak "socket: $!";
            connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
        }
    }
    local($old) = select(SYSLOG); $| = 1; select($old);
    $connected = 1;
}

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

1;
Commit	Line	Data
a0d0e21e LW	1	package Sys::Syslog;
	2	require 5.000;
	3	require Exporter;
8ce86de8	4	require DynaLoader;
a0d0e21e LW	5	use Carp;
a0d0e21e LW	6
8ce86de8	7	@ISA = qw(Exporter DynaLoader);
a0d0e21e	8	@EXPORT = qw(openlog closelog setlogmask syslog);
3ffabb8c	9	@EXPORT_OK = qw(setlogsock);
8ce86de8	10	$VERSION = '0.01';
a0d0e21e	11
37120919	12	use Socket;
55497cff	13	use Sys::Hostname;
37120919	14
5be1dfc7	15	# adapted from syslog.pl
a0d0e21e	16	#
5be1dfc7	17	# Tom Christiansen <tchrist@convex.com>
a0d0e21e LW	18	# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
a0d0e21e LW	19	# NOTE: openlog now takes three arguments, just like openlog(3)
3ffabb8c GS	20	# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
3ffabb8c GS	21	# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
8ce86de8	22	# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>
3ffabb8c GS	23
3ffabb8c GS	24	# Todo: enable connect to try all three types before failing (auto setlogsock)?
5be1dfc7 HF	25
	26	=head1 NAME
	27
	28	Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
	29
	30	=head1 SYNOPSIS
	31
3ffabb8c GS	32	use Sys::Syslog; # all except setlogsock, or:
3ffabb8c GS	33	use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
5be1dfc7	34
3ffabb8c	35	setlogsock $sock_type;
5be1dfc7	36	openlog $ident, $logopt, $facility;
2eae817d	37	syslog $priority, $format, @args;
5be1dfc7 HF	38	$oldmask = setlogmask $mask_priority;
	39	closelog;
	40
	41	=head1 DESCRIPTION
	42
	43	Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
	44	Call C<syslog()> with a string priority and a list of C<printf()> args
	45	just like C<syslog(3)>.
	46
	47	Syslog provides the functions:
	48
	49	=over
	50
	51	=item openlog $ident, $logopt, $facility
	52
	53	I<$ident> is prepended to every message.
b12e51c8	54	I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
5be1dfc7 HF	55	I<$facility> specifies the part of the system
5be1dfc7 HF	56
2eae817d	57	=item syslog $priority, $format, @args
5be1dfc7	58
2eae817d	59	If I<$priority> permits, logs I<($format, @args)>
5be1dfc7 HF	60	printed as by C<printf(3V)>, with the addition that I<%m>
	61	is replaced with C<"$!"> (the latest error message).
	62
	63	=item setlogmask $mask_priority
	64
	65	Sets log mask I<$mask_priority> and returns the old mask.
	66
3ffabb8c GS	67	=item setlogsock $sock_type (added in 5.004_02)
3ffabb8c GS	68
cb63fe9d	69	Sets the socket type to be used for the next call to
3ffabb8c GS	70	C<openlog()> or C<syslog()> and returns TRUE on success,
	71	undef on failure.
	72
f8b75b0c	73	A value of 'unix' will connect to the UNIX domain socket returned by
3ffabb8c GS	74	C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an
3ffabb8c GS	75	INET socket returned by getservbyname(). Any other value croaks.
cb63fe9d TB	76
	77	The default is for the INET socket to be used.
	78
5be1dfc7 HF	79	=item closelog
	80
	81	Closes the log file.
	82
	83	=back
	84
	85	Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
	86
	87	=head1 EXAMPLES
	88
	89	openlog($program, 'cons,pid', 'user');
	90	syslog('info', 'this is another test');
	91	syslog('mail\|warning', 'this is a better test: %d', time);
	92	closelog();
	93
	94	syslog('debug', 'this is the last test');
cb63fe9d TB	95
cb63fe9d TB	96	setlogsock('unix');
5be1dfc7 HF	97	openlog("$program $$", 'ndelay', 'user');
	98	syslog('notice', 'fooprogram: this is really done');
	99
cb63fe9d	100	setlogsock('inet');
5be1dfc7 HF	101	$! = 55;
	102	syslog('info', 'problem was %m'); # %m == $! in syslog(3)
	103
5be1dfc7 HF	104	=head1 SEE ALSO
	105
	106	L<syslog(3)>
	107
	108	=head1 AUTHOR
	109
cb63fe9d TB	110	Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>.
	111	UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt>
	112	with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
8ce86de8	113	Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
5be1dfc7 HF	114
5be1dfc7 HF	115	=cut
a0d0e21e	116
8ce86de8 GS	117	sub AUTOLOAD {
	118	# This AUTOLOAD is used to 'autoload' constants from the constant()
	119	# XS function.
	120
	121	my $constname;
	122	our $AUTOLOAD;
	123	($constname = $AUTOLOAD) =~ s/.*:://;
	124	croak "& not defined" if $constname eq 'constant';
	125	my $val = constant($constname, @_ ? $_[0] : 0);
	126	if ($! != 0) {
	127	croak "Your vendor has not defined Sys::Syslog macro $constname";
	128	}
	129	*$AUTOLOAD = sub { $val };
	130	goto &$AUTOLOAD;
	131	}
	132
	133	bootstrap Sys::Syslog $VERSION;
a0d0e21e LW	134
	135	$maskpri = &LOG_UPTO(&LOG_DEBUG);
	136
	137	sub openlog {
	138	($ident, $logopt, $facility) = @_; # package vars
	139	$lo_pid = $logopt =~ /\bpid\b/;
	140	$lo_ndelay = $logopt =~ /\bndelay\b/;
	141	$lo_cons = $logopt =~ /\bcons\b/;
	142	$lo_nowait = $logopt =~ /\bnowait\b/;
a8710ca1 GS	143	return 1 unless $lo_ndelay;
a8710ca1 GS	144	&connect;
a0d0e21e LW	145	}
	146
	147	sub closelog {
	148	$facility = $ident = '';
	149	&disconnect;
	150	}
	151
	152	sub setlogmask {
	153	local($oldmask) = $maskpri;
	154	$maskpri = shift;
	155	$oldmask;
	156	}
	157
cb63fe9d TB	158	sub setlogsock {
cb63fe9d TB	159	local($setsock) = shift;
3ffabb8c	160	&disconnect if $connected;
cb63fe9d	161	if (lc($setsock) eq 'unix') {
3ffabb8c GS	162	if (defined &_PATH_LOG) {
	163	$sock_type = 1;
	164	} else {
	165	return undef;
	166	}
cb63fe9d	167	} elsif (lc($setsock) eq 'inet') {
3ffabb8c GS	168	if (getservbyname('syslog','udp')) {
	169	undef($sock_type);
	170	} else {
	171	return undef;
	172	}
cb63fe9d TB	173	} else {
	174	croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
	175	}
f8b75b0c	176	return 1;
cb63fe9d TB	177	}
cb63fe9d TB	178
a0d0e21e LW	179	sub syslog {
	180	local($priority) = shift;
	181	local($mask) = shift;
	182	local($message, $whoami);
	183	local(@words, $num, $numpri, $numfac, $sum);
	184	local($facility) = $facility; # may need to change temporarily.
	185
	186	croak "syslog: expected both priority and mask" unless $mask && $priority;
	187
	188	@words = split(/\W+/, $priority, 2);# Allow "level" or "level\|facility".
	189	undef $numpri;
	190	undef $numfac;
	191	foreach (@words) {
	192	$num = &xlate($_); # Translate word to number.
	193	if (/^kern$/ \|\| $num < 0) {
	194	croak "syslog: invalid level/facility: $_";
	195	}
	196	elsif ($num <= &LOG_PRIMASK) {
	197	croak "syslog: too many levels given: $_" if defined($numpri);
	198	$numpri = $num;
	199	return 0 unless &LOG_MASK($numpri) & $maskpri;
	200	}
	201	else {
	202	croak "syslog: too many facilities given: $_" if defined($numfac);
	203	$facility = $_;
	204	$numfac = $num;
	205	}
	206	}
	207
	208	croak "syslog: level must be given" unless defined($numpri);
	209
	210	if (!defined($numfac)) { # Facility not specified in this call.
	211	$facility = 'user' unless $facility;
	212	$numfac = &xlate($facility);
	213	}
	214
	215	&connect unless $connected;
	216
	217	$whoami = $ident;
	218
5dad0344	219	if (!$whoami && $mask =~ /^(\S.?):\s?(.)/) {
a0d0e21e LW	220	$whoami = $1;
	221	$mask = $2;
	222	}
	223
	224	unless ($whoami) {
	225	($whoami = getlogin) \|\|
	226	($whoami = getpwuid($<)) \|\|
	227	($whoami = 'syslog');
	228	}
	229
	230	$whoami .= "[$$]" if $lo_pid;
	231
	232	$mask =~ s/%m/$!/g;
	233	$mask .= "\n" unless $mask =~ /\n$/;
	234	$message = sprintf ($mask, @_);
	235
	236	$sum = $numpri + $numfac;
cb63fe9d	237	unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
a0d0e21e LW	238	if ($lo_cons) {
	239	if ($pid = fork) {
	240	unless ($lo_nowait) {
cb1a09d0	241	$died = waitpid($pid, 0);
a0d0e21e LW	242	}
	243	}
	244	else {
aa667c33 GS	245	if (open(CONS,">/dev/console")) {
	246	print CONS "<$facility.$priority>$whoami: $message\r";
	247	exit if defined $pid; # if fork failed, we're parent
	248	close CONS;
	249	}
a0d0e21e LW	250	}
	251	}
	252	}
	253	}
	254
	255	sub xlate {
	256	local($name) = @_;
55497cff	257	$name = uc $name;
a0d0e21e	258	$name = "LOG_$name" unless $name =~ /^LOG_/;
748a9306	259	$name = "Sys::Syslog::$name";
8ce86de8	260	eval { &$name } \|\| -1;
a0d0e21e LW	261	}
	262
	263	sub connect {
4fc7577b	264	unless ($host) {
4fc7577b	265	require Sys::Hostname;
2eae817d	266	my($host_uniq) = Sys::Hostname::hostname();
3e3baf6d	267	($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
4fc7577b	268	}
3ffabb8c	269	unless ( $sock_type ) {
cb63fe9d TB	270	my $udp = getprotobyname('udp');
	271	my $syslog = getservbyname('syslog','udp');
	272	my $this = sockaddr_in($syslog, INADDR_ANY);
	273	my $that = sockaddr_in($syslog, inet_aton($host) \|\| croak "Can't lookup $host");
	274	socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) \|\| croak "socket: $!";
	275	connect(SYSLOG,$that) \|\| croak "connect: $!";
	276	} else {
	277	my $syslog = &_PATH_LOG \|\| croak "_PATH_LOG not found in syslog.ph";
	278	my $that = sockaddr_un($syslog) \|\| croak "Can't locate $syslog";
3ffabb8c GS	279	socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) \|\| croak "socket: $!";
	280	if (!connect(SYSLOG,$that)) {
	281	socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) \|\| croak "socket: $!";
	282	connect(SYSLOG,$that) \|\| croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
	283	}
cb63fe9d	284	}
a0d0e21e LW	285	local($old) = select(SYSLOG); $\| = 1; select($old);
	286	$connected = 1;
	287	}
	288
	289	sub disconnect {
	290	close SYSLOG;
	291	$connected = 0;
	292	}
	293
	294	1;