Path: utzoo!utgpu!news-server.csri.toronto.edu!clyde.concordia.ca!mcgill-vision!bloom-beacon!mintaka!yale!think!samsung!usc!jarthur!elroy.jpl.nasa.gov!jpl-devvax!lwall
From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
Newsgroups: comp.lang.perl
Subject: Re: openlog(3), syslog(3) in perl
Message-ID: <7423@jpl-devvax.JPL.NASA.GOV>
Date: 15 Mar 90 02:03:51 GMT
References: <39461@apple.Apple.COM>
Reply-To: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
Organization: Jet Propulsion Laboratory, Pasadena, CA
Lines: 179

In article <39461@apple.Apple.COM> fair@apple.com (Erik E. Fair) writes:
: Has anybody duplicated these routines for perl 3.0 yet, in such a
: manner that you don't have to spawn a process for every line you log
: (i.e. that hack I saw already isn't acceptable)?
: 
: 	trolling for wheels that are already 'round,
: 
: 	Erik E. Fair	apple!fair	fair@apple.com
: 
: P.S.	I'm not a perl hacker (yet).

Little does he know the insidious nature of the malady...  :-)

Here's a warmed-over version of Tom's syslog.pl.  It talks to the inet
socket of syslogd.  (There is, in fact, a hidden option to log to a different
machine.)  It also purports to support the logopt flags of openlog, though
some of them haven't been tested.  I won't claim the wheel's round yet,
but it's getting closer.

Larry

#!/bin/sh
: make a subdirectory, cd to it, and run this through sh.
echo 'If this kit is complete, "End of kit" will echo at the end'
echo Extracting syslog.pl
sed >syslog.pl <<'!STUFFY!FUNK!' -e 's/X//'
X#
X# syslog.pl
X#
X# tom christiansen <tchrist@convex.com>
X# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
X# NOTE: openlog now takes three arguments, just like openlog(3)
X#
X# call syslog() with a string priority and a list of printf() args
X# like syslog(3)
X#
X#  usage: do 'syslog.pl' || die "syslog.pl: $@";
X#
X#  then (put these all in a script to test function)
X#		
X#
X#	do openlog($program,'cons,pid','user');
X#	do syslog('info','this is another test');
X#	do syslog('warn','this is a better test: %d', time);
X#	do closelog();
X#	
X#	do syslog('debug','this is the last test');
X#	do openlog("$program $$",'ndelay','user');
X#	do syslog('notice','fooprogram: this is really done');
X#
X#	$! = 55;
X#	do syslog('info','problem was %m'); # %m == $! in syslog(3)
X
Xpackage syslog;
X
X$host = 'localhost' unless $host;	# set $syslog'host to change
X
Xdo '/usr/local/lib/perl/syslog.h'
X	|| die "syslog: Can't do syslog.h: ",($@||$!),"\n";
X
Xsub main'openlog {
X    ($ident, $logopt, $facility) = @_;  # package vars
X    $lo_pid = $logopt =~ /\bpid\b/;
X    $lo_ndelay = $logopt =~ /\bndelay\b/;
X    $lo_cons = $logopt =~ /\bncons\b/;
X    $lo_nowait = $logopt =~ /\bnowait\b/;
X    &connect if $lo_ndelay;
X} 
X
Xsub main'closelog {
X    $facility = $ident = '';
X    &disconnect;
X} 
X 
Xsub main'syslog {
X    local($priority) = shift;
X    local($mask) = shift;
X    local($message, $whoami);
X
X    &connect unless $connected;
X
X    $whoami = $ident;
X
X    die "syslog: expected both priority and mask" unless $mask && $priority;
X
X    $facility = "user" unless $facility;
X
X    if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
X	$whoami = $1;
X	$mask = $2;
X    } 
X    $whoami .= " [$$]" if $lo_pid;
X
X    $mask =~ s/%m/$!/g;
X    $mask .= "\n" unless $mask =~ /\n$/;
X    $message = sprintf ($mask, @_);
X
X    $whoami = sprintf ("%s %d",$ENV{'USER'}||$ENV{'LOGNAME'},$$) unless $whoami;
X
X    $sum = &xlate($priority) + &xlate($facility);
X    unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
X	if ($lo_cons) {
X	    if ($pid = fork) {
X		unless ($lo_nowait) {
X		    do {$died = wait;} until $died == $pid || $died < 0;
X		}
X	    }
X	    else {
X		open(CONS,">/dev/console");
X		print CONS "$<facility.$priority>$whoami: $message\n";
X		exit if defined $pid;		# if fork failed, we're parent
X		close CONS;
X	    }
X	}
X    }
X}
X
Xsub xlate {
X    local($name) = @_;
X    $name =~ y/a-z/A-Z/;
X    $name = "LOG_$name" unless $name =~ /^LOG_/;
X    $name = "syslog'$name";
X    &$name;
X}
X
Xsub connect {
X    $pat = 'S n C4 x8';
X
X    $af_unix = 1;
X    $af_inet = 2;
X
X    $stream = 1;
X    $datagram = 2;
X
X    ($name,$aliases,$proto) = getprotobyname('udp');
X    $udp = $proto;
X
X    ($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
X    $syslog = $port;
X
X    if (chop($myname = `hostname`)) {
X	($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
X	die "Can't lookup $myname\n" unless $name;
X	@bytes = unpack("C4",$addrs[0]);
X    }
X    else {
X	@bytes = (0,0,0,0);
X    }
X    $this = pack($pat, $af_inet, 0, @bytes);
X
X    if ($host =~ /^\d+\./) {
X	@bytes = split(/\./,$host);
X    }
X    else {
X	($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
X	die "Can't lookup $host\n" unless $name;
X	@bytes = unpack("C4",$addrs[0]);
X    }
X    $that = pack($pat,$af_inet,$syslog,@bytes);
X
X    socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
X    bind(SYSLOG,$this) || die "bind: $!\n";
X    connect(SYSLOG,$that) || die "connect: $!\n";
X
X    local($old) = select(SYSLOG); $| = 1; select($old);
X    $connected = 1;
X}
X
Xsub disconnect {
X    close SYSLOG;
X    $connected = 0;
X}
X
X1;
!STUFFY!FUNK!
echo ""
echo "End of kit"
: I do not append .signature, but someone might mail this.
exit