news.utdallas.edu!hermes.chpc.utexas.edu!cs.utexas.edu!sun-barr!olivea!tymix!grimoire!mooring Thu Feb 25 18:32:10 CST 1993
Article: 1233 of comp.lang.perl
Xref: feenix.metronet.com comp.lang.perl:1233
Path: feenix.metronet.com!news.utdallas.edu!hermes.chpc.utexas.edu!cs.utexas.edu!sun-barr!olivea!tymix!grimoire!mooring
From: mooring@grimoire.tymnet.com (Ed Mooring)
Newsgroups: comp.lang.perl
#Subject: Re: socket-based server (not from inetd)
Message-ID: <3435@tymix.Tymnet.COM>
Date: 25 Feb 93 20:04:18 GMT
References: <1mimbd$ac3@milk.Warren.MENTORG.COM>
Sender: usenet@tymix.Tymnet.COM
Organization: BT Tymnet Bit Bucket Brigade
Lines: 170
Nntp-Posting-Host: grimoire

In article <1mimbd$ac3@milk.Warren.MENTORG.COM> tal@Warren.MENTORG.COM (Tom Limoncelli) writes:
>In the past people have posted code fragments that show how to write a
>perl program that is started via "inetd".
>
>I would like to develop a long-running daemon that accepts connections
>via sockets but never spawns.  (i.e. all connections are handled by one
>program, a lot like INN's innd).
>
>Does anyone have sample Perl code?  I'd rather not have to re-invent
>the wheel.
>
>Thanks in advance,
>Tom

Here's something I posted a while back that covers most of the
basics.  It listens to stdin and broadcasts what it gets to all
connected sockets.

#/usr/local/bin/perl -s

$pat = 'S n C4 x8';
$inet = 2;
$echo = 7;
$smtp = 25;
$nntp = 119;

die "Usage:  $0 port \n" unless @ARGV;
$this = pack($pat,$inet,$ARGV[0], 0,0,0,0);
#$this = pack($pat,$inet,2345, 0,0,0,0);

socket(LISTENER,2,1,6) || die "Socket $!\n";
bind(LISTENER,$this) || die "Bind $!\n";
listen(LISTENER,5) || die "Listen $!\n";

$readbits = $writebits = "\0" x 8;
# always read from standard input
vec($readbits,0,1) = 1;

# and look for new connections
#
vec($readbits,fileno(LISTENER),1) = 1;

$listener = fileno(LISTENER);

$0 = $0;
#
# prototype file name
#
$sockp = 'clientaa';

while (1)
{
    $rbits = $readbits;
    $wbits = $writebits;
    grep(vec($wbits,$_,1) = 1, keys %bcastpending);
    ($nfound, $timeleft) = select($rbits, $wbits, undef, 5);
    if ($nfound > 0)
    {
	#
	# we got a hit of some sort
	# first see if anything to write
	if ($wbits =~ /[^\0]/)
	{
	    $bstr = unpack('b*',$wbits);
	    for($fd = index($bstr,'1'); $fd >= 0; $fd = index($bstr,'1',$fd+1))
	    {
		# we just ignore errors here
		#
		$sock = $filenames[$fd];
		send($sock,$bcastdata,0);
		delete $bcastpending{$fd};
	    }
	}
	if ($rbits =~ /[^\0]/)
	{
	    $bstr = unpack('b*',$rbits);
	    for($fd = index($bstr,'1'); $fd >= 0; $fd = index($bstr,'1',$fd+1))
	    {
		if ($fd == 0)
		{
		    # deal with stdin
		    $incount = sysread(STDIN,$bcastdata,1024);
		    if ($incount == 0)
		    {
			# lost our connection
			die "EOF from source\n";
		    }
		    elsif ($incount < 0)
		    {
			# error
			die "Error from source($!)\n" if ($! !~ /Interrupted/);
		    }
		    grep($bcastpending{$_} = 1, keys %active);
		}
		elsif ($fd == $listener)
		{
		    # deal with cloning new socket
		    $newsock = $sockp++;
		    if ($addr = accept($newsock,LISTENER))
		    {
			#
			# see if we like this host
			#
			($fam,$port,$inetaddr) = unpack('SSL',$addr);
			if ($verbose)
			{
			    $hostname = gethostbyaddr($addr, 2);
			    printf "Connection from $hostname %x %d\n", $inetaddr, $port;
			}
			if ($inetaddr != 0x7f000001 && ($inetaddr & 0xffff0000) != 0x83920000)
			{
			    #
			    # not a tymnet host, bounce it.
			    #
			    close ($newsock);
			    if ($verbose)
			    {
				$hostname = gethostbyaddr($addr, 2);
				printf "Connection refused from $hostname %x %d\n", $inetaddr, $port;
			    }
			}

			#
			# set bit vectors for later use
			#
			vec($readbits,fileno($newsock),1) = 1;
			$bcastpending{fileno($newsock)} = 1 if length $bcastdata;
			$active{fileno($newsock)} = 1;
			$filenames[fileno($newsock)] = $newsock;
		    }
		    else
		    {
			die "Error on accept $!\n";
		    }
		}
		else
		{
		    # read data from socket and toss, check for eof
		    $sock = $filenames[$fd];
		    $incount = read($sock,$waste,1024);
		    if ($incount == 0)
		    {
			# lost our connection
			#
			# reset bit vectors
			#
			vec($readbits,$fd,1) = 0;
			$filenames[$fd] = '';
			delete $bcastpending{$fd};
			delete $active{$fd};
			close($sock);
		    }
		    elsif ($incount < 0)
		    {
			# error
			die "Error from socket($!)\n" if ($! !~ /Interrupted/);
		    }
		}
	    }
	}
    }
    elsif ($nfound < 0)
    {
	die "Error ($!) on select\n" unless $! =~ /Interrupted/;
    }
}
exit 0;

Regards,
Ed Mooring (mooring@tymix.tymnet.com 408-922-7504)