[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
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 {
		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	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
f8b75b0c	73	A value of 'unix' will connect to the UNIX domain socket returned by
3ffabb8c	74	C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an
3ffabb8c	75	INET socket returned by getservbyname(). Any other value croaks.
cb63fe9d	76
	77	The default is for the INET socket to be used.
	78
5be1dfc7	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	95
cb63fe9d	96	setlogsock('unix');
5be1dfc7	97	openlog("$program $$", 'ndelay', 'user');
	98	syslog('notice', 'fooprogram: this is really done');
	99
cb63fe9d	100	setlogsock('inet');
5be1dfc7	101	$! = 55;
	102	syslog('info', 'problem was %m'); # %m == $! in syslog(3)
	103
5be1dfc7	104	=head1 SEE ALSO
	105
	106	L<syslog(3)>
	107
	108	=head1 AUTHOR
	109
cb63fe9d	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	114
5be1dfc7	115	=cut
a0d0e21e	116
8ce86de8	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	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	143	return 1 unless $lo_ndelay;
a8710ca1	144	&connect;
a0d0e21e	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	158	sub setlogsock {
cb63fe9d	159	local($setsock) = shift;
3ffabb8c	160	&disconnect if $connected;
cb63fe9d	161	if (lc($setsock) eq 'unix') {
3ffabb8c	162	if (defined &_PATH_LOG) {
	163	$sock_type = 1;
	164	} else {
	165	return undef;
	166	}
cb63fe9d	167	} elsif (lc($setsock) eq 'inet') {
3ffabb8c	168	if (getservbyname('syslog','udp')) {
	169	undef($sock_type);
	170	} else {
	171	return undef;
	172	}
cb63fe9d	173	} else {
	174	croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
	175	}
f8b75b0c	176	return 1;
cb63fe9d	177	}
cb63fe9d	178
a0d0e21e	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	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	238	if ($lo_cons) {
	239	if ($pid = fork) {
	240	unless ($lo_nowait) {
cb1a09d0	241	$died = waitpid($pid, 0);
a0d0e21e	242	}
	243	}
	244	else {
	245	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	}
	250	}
	251	}
	252	}
	253
	254	sub xlate {
	255	local($name) = @_;
55497cff	256	$name = uc $name;
a0d0e21e	257	$name = "LOG_$name" unless $name =~ /^LOG_/;
748a9306	258	$name = "Sys::Syslog::$name";
8ce86de8	259	eval { &$name } \|\| -1;
a0d0e21e	260	}
	261
	262	sub connect {
4fc7577b	263	unless ($host) {
4fc7577b	264	require Sys::Hostname;
2eae817d	265	my($host_uniq) = Sys::Hostname::hostname();
3e3baf6d	266	($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
4fc7577b	267	}
3ffabb8c	268	unless ( $sock_type ) {
cb63fe9d	269	my $udp = getprotobyname('udp');
	270	my $syslog = getservbyname('syslog','udp');
	271	my $this = sockaddr_in($syslog, INADDR_ANY);
	272	my $that = sockaddr_in($syslog, inet_aton($host) \|\| croak "Can't lookup $host");
	273	socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) \|\| croak "socket: $!";
	274	connect(SYSLOG,$that) \|\| croak "connect: $!";
	275	} else {
	276	my $syslog = &_PATH_LOG \|\| croak "_PATH_LOG not found in syslog.ph";
	277	my $that = sockaddr_un($syslog) \|\| croak "Can't locate $syslog";
3ffabb8c	278	socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) \|\| croak "socket: $!";
	279	if (!connect(SYSLOG,$that)) {
	280	socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) \|\| croak "socket: $!";
	281	connect(SYSLOG,$that) \|\| croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
	282	}
cb63fe9d	283	}
a0d0e21e	284	local($old) = select(SYSLOG); $\| = 1; select($old);
	285	$connected = 1;
	286	}
	287
	288	sub disconnect {
	289	close SYSLOG;
	290	$connected = 0;
	291	}
	292
	293	1;