[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.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 the
C<_PATH_LOG> macro (if you system defines it) in F<syslog.h>.  A value of
'inet' will connect to an INET socket returned by getservbyname().  If
C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef.  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
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>.

=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);
    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 (length _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";
		    close CONS;
		}
		exit if defined $pid;		# if fork failed, we're parent
	    }
	}
    }
}

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