Article 9541 of comp.lang.perl:
Xref: feenix.metronet.com comp.lang.perl:9541
Path: feenix.metronet.com!news.ecn.bgu.edu!usenet.ins.cwru.edu!howland.reston.ans.net!math.ohio-state.edu!sdd.hp.com!sgiblab!idiom.berkeley.ca.us!idiom.berkeley.ca.us!not-for-mail
From: muir@idiom.berkeley.ca.us (David Muir Sharnoff)
Newsgroups: comp.lang.perl
Subject: Re: perl code to listen/connect/etc to unix domain sockets ..
Date: 7 Jan 1994 12:20:29 -0800
Organization: Idiom Consulting / Berkeley, CA  USA
Lines: 284
Message-ID: <2gkg6d$fmi@idiom.berkeley.ca.us>
References: <phone.757844874@cairo>
NNTP-Posting-Host: idiom.berkeley.ca.us
Keywords: perl, sockets, unix

In article <phone.757844874@cairo> phone@cairo.anu.edu.au (matthew green) writes:
>i'm after some perl code to work with unix domain sockets.

I played with this a couple of months ago:

-------------------------------------------------

#  Copyright (c) 1993 David Muir Sharnoff
#  License at bottom of file

package sockets;

# hardcoded constants, should work fine for BSD-based systems
$AF_UNIX = 1;
$AF_INET = 2;
$SOCK_STREAM = 1;
$SOCK_DGRAM  = 2;
$SOCKADDR_IP = 'S n a4 x8';
$SOCKADDR_UN = 'S a108';

#
# &socket is a function that creates, binds, and connects 
# sockets.
#
# Arguments:
# $S	- the name of the socket, eg 'SOC'.  Use <SOC> elsewhere.
# $type	- datagram (dgram) or stream.  
# $them	- the remote address (optional)
# $us	- the local address (optional)
#
# Both $us and $them are in a flexible format.  If they look like a 
# unix path (begins with /) then it is assumed you want a unix-domain
# socket.  Otherwise an IP socket is assumed.
#
# There is no default port number.   If you specify a $them IP address, 
# be sure to specify a port number.  
#
# IP $us and $them are in the format "$hostname/$port".  A symbolic
# port name will be looked up.
#

sub main'socket
{
	local($S,$type,$them,$us) = @_;
	local($t,$ip);

	if ("\L$type" eq 'stream' || "\L$type" eq 'tcp' || $type == $SOCK_STREAM) {
		$t = $SOCK_STREAM;
		$ip = 'tcp';
	} elsif ("\L$type" eq 'dgram' || "\L$type" eq 'udp' || $type == $SOCK_DGRAM) {	
		$t = $SOCK_DGRAM;
		$ip = 'udp'
	} else {
		die "could not figure out socket type: $type";
	}

	if (($them =~ m,^/,) || ($us =~ m,^/,)) {
		&unix_socket($S,$t,$them,$us);
	} else {
		&ip_socket($S,$t,$ip,$them,$us);
	}
}

sub unix_socket
{
	local($S,$type,$them,$us) = @_;
	local($us_struct,$them_struct);

	print "unix socket $type, $them, $us\n" if $debug;
	socket($S, $AF_UNIX, $t, 0) 
	    || die "socket: $!";

	if ($us) {
		$us_struct = pack($SOCKADDR_UN, $AF_UNIX, $us);
		bind($S, $us_struct) || die "bind unix socket $us: $!";
	}
	if ($them) {
		$them_struct = pack($SOCKADDR_UN, $AF_UNIX, $them);
		connect($S, $them_struct) || die "connect unix socket $them: $!";
	}
	select((select($S),$| = 1)[0]); # don't buffer output 
}

sub ip_socket
{
	local($S,$type,$protocol,$them,$us) = @_;

	local($their_port,$their_host);

	local($our_addr_struct) = &get_IP_addr_struct($protocol,$us);

	socket($S, $AF_INET, $t, &get_proto_number($protocol))
		|| die "socket: $!";

	print "us $protocol,$us,$them: ",&unpack_IP_addr_struct($our_addr_struct),"\n" if $debug;
	bind($S, $our_addr_struct) 
		|| die "bind $hostname,0: $!";

	if ($them) {
		local($their_addr_struct) = &get_IP_addr_struct($protocol,$them);
		print "them $protocol,$us,$them: ",&unpack_IP_addr_struct($their_addr_struct),"\n" if $debug;
		connect($S, $their_addr_struct) 
			|| die "connect $host: $!";
	}
	select((select($S),$| = 1)[0]); # don't buffer output 
}

#
# Create IP address structures.
#
# The first argument must be 'tcp', or 'udp'.
# The second argument is the host (`hostname` if null) to connect to.
# The third argument is the port to bind to.   Pass 0 if any will do.
#
# The return arguments are a protocol value that can use by socket()
# and a port address that can be used by bind().
# 
sub get_IP_addr_struct
{
	local($protocol,$host,$port) = @_;
	local($junk,$host_addr);

	if (! $port && ($host =~ s,([^/]+)/(.+),$1,)) {
		$port = $2;
	}
	$host = &hostname() 
		if ! $host;
	($junk,$junk,$junk,$junk,$host_addr) = gethostbyname($host);

	die "gethostbyname($host): $!" 
		unless $host_addr;

	if ($port =~ /[^\d]/) {
		($junk,$junk,$port) = getservbyname($port,$protocol);
		die "getservbyname($port,$protocol): $!"
			unless $port;
	}

	return pack($SOCKADDR_IP, $AF_INET, $port, $host_addr);
}

sub get_proto_number
{
	local($protocol) = @_;
	local($junk,$proto);

	($junk,$junk,$proto) = getprotobyname($protocol);

	die "getprotobyname($protocol): $!"
		unless $proto;
	
	return $proto;
}

sub hostname
{
	if (! $hostname) {
		chop($hostname = `hostname`);
		if (! $hostname) {
			chop($hostname = `uname -n`);
			if (! $hostname) {
				die "cannot determine hostname";
			}
		}
	}
	return $hostname;
}

#
# An extra...
#

sub unpack_IP_addr_struct
{
	local($addr) = @_;
	local($name,@junk);
	local($af,$port,$host) = unpack($SOCKADDR_IP,$addr);
	($name,@junk) = gethostbyaddr($host,$AF_INET);
	if ($name) {
		return $name;
	} else {
		local(@IP) = unpack('C4',$host);
		return join('.',@IP)."/$port";
	}
}

#############################################################################
#
#  Copyright (c) 1993 David Muir Sharnoff
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#  3. All advertising materials mentioning features or use of this software
#     must display the following acknowledgement:
#       This product includes software developed by the David Muir Sharnoff.
#  4. The name of David Sharnoff may not be used to endorse or promote products
#     derived from this software without specific prior written permission.
#
#  THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
# This copyright notice derrived from material copyrighted by the Regents
# of the University of California.
#
# Contributions accepted.
#
#############################################################################

1;

-------------------------------------------------

Here are some test routines that should show you how to use &socket().

$uport = ....

sub unix_stream_server
{
	&main'socket(ST,STREAM,"",$uport);
	listen(ST,5) || die "listen: $!";
	($their_addr = accept(NST,ST)) || die "accept: $!";
	if ($debug) {
		($junk,$their_path) = unpack($SOCKADDR_UN,$their_addr);
		print "Their address: $their_path\n";
	}
	select((select(NST),$| = 1)[0]); # don't buffer output
	print NST "Server here\n";
	$x = <NST>;
	print ($x eq "Client here\n" ? "ok 6\n" : "not ok 6\n");
	close(NST);
	close(ST);
	unlink($uport);
}

sub unix_stream_client
{
	&main'socket(CT,STREAM,$uport,"");
	$x = <CT>;
	print ($x eq "Server here\n" ? "ok 5\n" : "not ok 5\n");
	print CT "Client here\n";
	close(CT);
}

sub unix_dgram_server
{
	&main'socket(ST,DGRAM,"",$uport);
	$their_addr = recv(ST,$x,1024,0);
	if ($debug) {
		($junk,$their_path) = unpack($SOCKADDR_UN,$their_addr);
		print "Their address: $their_path\n";
	}
	print "their-addr: $their_addr\n" if $debug;
	print ($x eq "Client here\n" ? "ok 7\n" : "not ok 7\n");
	send(ST,"Server here\n",0,$their_addr);
	close(ST);
	unlink($uport);
}

sub unix_dgram_client
{
	&main'socket(CT,DGRAM,$uport,"/tmp/us2.$$");
	print CT "Client here\n";
	$x = <CT>;
	print ($x eq "Server here\n" ? "ok 8\n" : "not ok 8\n");
	close(CT);
	unlink("/tmp/us2.$$");
}