Article 7068 of comp.lang.perl:
Xref: feenix.metronet.com comp.lang.perl:7068
Path: feenix.metronet.com!news.ecn.bgu.edu!usenet.ins.cwru.edu!agate!spool.mu.edu!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: Yet another friendly socket library + test code for Larry
Date: 21 Oct 1993 01:38:08 -0700
Organization: Idiom Consulting / Berkeley, CA
Lines: 394
Message-ID: <2a5hpg$v7@idiom.berkeley.ca.us>
NNTP-Posting-Host: idiom.berkeley.ca.us

I wanted to use udp sockets in perl and didn't see any nice
examples, so I made one.  In the process, I decided to make a 
library for creating all sorts of sockets.

To test it, I built a Larry-style .t file.  Everything works, 
except, I can't get return address from UNIX-domain sockets.

No change that -- it appears that there are anonymous 
unix domain sockets.  If you bind() a unix domain socket, and then
connect with it, the address is available to the process you 
connected to, but if you don't then it doesn't appear that 
a return address is available.   This wouldn't matter except that
it means that when you use datagrams you can't always reply!

Sockets.pl will make udp, tcp, unix-stream, and unix-dgram sockets.

Have fun!

-Dave

#!/bin/sh
# shar:	Shell Archiver  (v1.22)
#
#	Run the following text with /bin/sh to create:
#	  sockets.pl
#	  sockets.t
#
sed 's/^X//' << 'SHAR_EOF' > sockets.pl &&
X
X#  Copyright (c) 1993 David Muir Sharnoff
X#  License at bottom of file
X
Xpackage sockets;
X
X# hardcoded constants, should work fine for BSD-based systems
X$AF_UNIX = 1;
X$AF_INET = 2;
X$SOCK_STREAM = 1;
X$SOCK_DGRAM  = 2;
X$SOCKADDR_IP = 'S n a4 x8';
X$SOCKADDR_UN = 'S a108';
X
X#
X# &socket is a function that creates binds, and connects 
X# sockets.
X#
X# Arguments:
X# $S	- the name of the socket, eg 'SOC'.  Use <SOC> elsewhere.
X# $type	- datagram (dgram) or stream.  
X# $them	- the remote address (optional)
X# $us	- the local address (optional)
X#
X# Both $us and $them are in a flexible format.  If they look like a 
X# unix path (begins with /) then it is assumed you want a unix-domain
X# socket.  Otherwise an IP socket is assumed.
X#
X# There is no default port number.   If you specify a $them IP address, 
X# be sure to specify a port number.  
X#
X# IP $us and $them are in the format "$hostname/$port".  A symbolic
X# port name will be looked up.
X#
X
Xsub main'socket
X{
X	local($S,$type,$them,$us) = @_;
X	local($t,$ip);
X
X	if ("\L$type" eq 'stream' || "\L$type" eq 'tcp' || $type == $SOCK_STREAM) {
X		$t = $SOCK_STREAM;
X		$ip = 'tcp';
X	} elsif ("\L$type" eq 'dgram' || "\L$type" eq 'udp' || $type == $SOCK_DGRAM) {	
X		$t = $SOCK_DGRAM;
X		$ip = 'udp'
X	} else {
X		die "could not figure out socket type: $type";
X	}
X
X	if (($them =~ m,^/,) || ($us =~ m,^/,)) {
X		&unix_socket($S,$t,$them,$us);
X	} else {
X		&ip_socket($S,$t,$ip,$them,$us);
X	}
X}
X
Xsub unix_socket
X{
X	local($S,$type,$them,$us) = @_;
X	local($us_struct,$them_struct);
X
X	print "unix socket $type, $them, $us\n" if $debug;
X	socket($S, $AF_UNIX, $t, 0) 
X	    || die "socket: $!";
X
X	if ($us) {
X		$us_struct = pack($SOCKADDR_UN, $AF_UNIX, $us);
X		bind($S, $us_struct) || die "bind unix socket $us: $!";
X	}
X	if ($them) {
X		$them_struct = pack($SOCKADDR_UN, $AF_UNIX, $them);
X		connect($S, $them_struct) || die "connect unix socket $them: $!";
X	}
X	select((select($S),$| = 1)[0]); # don't buffer output 
X}
X
Xsub ip_socket
X{
X	local($S,$type,$protocol,$them,$us) = @_;
X
X	local($their_port,$their_host);
X
X	local($our_addr_struct) = &get_IP_addr_struct($protocol,$us);
X
X	socket($S, $AF_INET, $t, &get_proto_number($protocol))
X		|| die "socket: $!";
X
X	print "us $protocol,$us,$them: ",&unpack_IP_addr_struct($our_addr_struct),"\n" if $debug;
X	bind($S, $our_addr_struct) 
X		|| die "bind $hostname,0: $!";
X
X	if ($them) {
X		local($their_addr_struct) = &get_IP_addr_struct($protocol,$them);
X		print "them $protocol,$us,$them: ",&unpack_IP_addr_struct($their_addr_struct),"\n" if $debug;
X		connect($S, $their_addr_struct) 
X			|| die "connect $host: $!";
X	}
X	select((select($S),$| = 1)[0]); # don't buffer output 
X}
X
X#
X# Create IP address structures.
X#
X# The first argument must be 'tcp', or 'udp'.
X# The second argument is the host (`hostname` if null) to connect to.
X# The third argument is the port to bind to.   Pass 0 if any will do.
X#
X# The return arguments are a protocol value that can use by socket()
X# and a port address that can be used by bind().
X# 
Xsub get_IP_addr_struct
X{
X	local($protocol,$host,$port) = @_;
X	local($junk,$host_addr);
X
X	if (! $port && ($host =~ s,([^/]+)/(.+),$1,)) {
X		$port = $2;
X	}
X	$host = &hostname() 
X		if ! $host;
X	($junk,$junk,$junk,$junk,$host_addr) = gethostbyname($host);
X
X	die "gethostbyname($host): $!" 
X		unless $host_addr;
X
X	if ($port =~ /[^\d]/) {
X		($junk,$junk,$port) = getservbyname($port,$protocol);
X		die "getservbyname($port,$protocol): $!"
X			unless $port;
X	}
X
X	return pack($SOCKADDR_IP, $AF_INET, $port, $host_addr);
X}
X
Xsub get_proto_number
X{
X	local($protocol) = @_;
X	local($junk,$proto);
X
X	($junk,$junk,$proto) = getprotobyname($protocol);
X
X	die "getprotobyname($protocol): $!"
X		unless $proto;
X	
X	return $proto;
X}
X
Xsub hostname
X{
X	if (! $hostname) {
X		chop($hostname = `hostname`);
X		if (! $hostname) {
X			chop($hostname = `uname -n`);
X			if (! $hostname) {
X				die "cannot determine hostname";
X			}
X		}
X	}
X	return $hostname;
X}
X
X#
X# An extra...
X#
X
Xsub unpack_IP_addr_struct
X{
X	local($addr) = @_;
X	local($af,$port,$host) = unpack($SOCKADDR_IP,$addr);
X	local(@IP) = unpack('C4',$host);
X	return join('.',@IP)."/$port";
X}
X
X#############################################################################
X#
X#  Copyright (c) 1993 David Muir Sharnoff
X#  All rights reserved.
X#
X#  Redistribution and use in source and binary forms, with or without
X#  modification, are permitted provided that the following conditions
X#  are met:
X#  1. Redistributions of source code must retain the above copyright
X#     notice, this list of conditions and the following disclaimer.
X#  2. Redistributions in binary form must reproduce the above copyright
X#     notice, this list of conditions and the following disclaimer in the
X#     documentation and/or other materials provided with the distribution.
X#  3. All advertising materials mentioning features or use of this software
X#     must display the following acknowledgement:
X#       This product includes software developed by the David Muir Sharnoff.
X#  4. The name of David Sharnoff may not be used to endorse or promote products
X#     derived from this software without specific prior written permission.
X#
X#  THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
X#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
X#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
X#  ARE DISCLAIMED.  IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
X#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
X#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
X#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
X#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
X#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
X#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
X#  SUCH DAMAGE.
X#
X# This copyright notice derrived from material copyrighted by the Regents
X# of the University of California.
X#
X# Contributions accepted.
X#
X#############################################################################
SHAR_EOF
chmod 0644 sockets.pl || echo "restore of sockets.pl fails"
sed 's/^X//' << 'SHAR_EOF' > sockets.t &&
X#!/usr/local/bin/perl
X
Xpackage sockets;
X
X$debug = 0;
X
Xrequire "sockets.pl";
X
X$random_port = 8223;
X
X$uport = "/tmp/uss$$";
X$sready = "/tmp/sready$$";
X
X$h = &hostname();
X
X$| = 1;
X
X$sig{ALRM} = 'death';
Xsub death
X{
X	print "not ok 100\n";
X	die;
X}
X
Xif (fork()) {
X	alarm(200);
X	&tcp_server();
X	&udp_server();
X	&unix_stream_server();
X	&unix_dgram_server();
X	wait();
X} else {
X	alarm(200);
X	&tcp_client();
X	&udp_client();
X	&unix_stream_client();
X	&unix_dgram_client();
X}
X
Xsub udp_server
X{
X	&main'socket(ST,UDP,"","$h/$random_port");
X	symlink(".",$sready);
X	$their_addr = recv(ST,$x,1024,0);
X	print ($x eq "Client here\n" ? "ok 3\n" : "not ok 3\n");
X	send(ST,"Server here\n",0,$their_addr);
X	close(ST);
X}
X
Xsub udp_client
X{
X	1 while (! -l $sready);
X	unlink($sready);
X	
X	&main'socket(CT,UDP,"$h/$random_port","");
X	print CT "Client here\n";
X	$x = <CT>;
X	print ($x eq "Server here\n" ? "ok 4\n" : "not ok 4\n");
X	close(CT);
X}
X
Xsub tcp_server
X{
X	&main'socket(ST,TCP,"","$h/$random_port");
X	listen(ST,5) || die "listen: $!";
X	symlink(".",$sready);
X	($their_addr = accept(NST,ST)) || die "accept: $!";
X	print &unpack_IP_addr_struct($their_addr),"\n" if $debug;
X	select((select(NST),$| = 1)[0]); # don't buffer output
X	print NST "Server here\n";
X	$x = <NST>;
X	print ($x eq "Client here\n" ? "ok 2\n" : "not ok 2\n");
X	close(NST);
X	close(ST);
X}
X
Xsub tcp_client
X{
X	1 while (! -l $sready);
X	unlink($sready);
X	
X	&main'socket(CT,TCP,"$h/$random_port","");
X	$x = <CT>;
X	print ($x eq "Server here\n" ? "ok 1\n" : "not ok 1\n");
X	print CT "Client here\n";
X	close(CT);
X}
X
Xsub unix_stream_server
X{
X	&main'socket(ST,STREAM,"",$uport);
X	listen(ST,5) || die "listen: $!";
X	symlink(".",$sready);
X	($their_addr = accept(NST,ST)) || die "accept: $!";
X	if ($debug) {
X		($junk,$their_path) = unpack($SOCKADDR_UN,$their_addr);
X		print "Their address: $their_path\n";
X	}
X	select((select(NST),$| = 1)[0]); # don't buffer output
X	print NST "Server here\n";
X	$x = <NST>;
X	print ($x eq "Client here\n" ? "ok 6\n" : "not ok 6\n");
X	close(NST);
X	close(ST);
X	unlink($uport);
X}
X
Xsub unix_stream_client
X{
X	1 while (! -l $sready);
X	unlink($sready);
X
X	&main'socket(CT,STREAM,$uport,"");
X	$x = <CT>;
X	print ($x eq "Server here\n" ? "ok 5\n" : "not ok 5\n");
X	print CT "Client here\n";
X	close(CT);
X}
X
Xsub unix_dgram_server
X{
X	&main'socket(ST,DGRAM,"",$uport);
X	symlink(".",$sready);
X	$their_addr = recv(ST,$x,1024,0);
X	if ($debug) {
X		($junk,$their_path) = unpack($SOCKADDR_UN,$their_addr);
X		print "Their address: $their_path\n";
X	}
X	print "their-addr: $their_addr\n" if $debug;
X	print ($x eq "Client here\n" ? "ok 7\n" : "not ok 7\n");
X	send(ST,"Server here\n",0,$their_addr);
X	close(ST);
X	unlink($uport);
X}
X
Xsub unix_dgram_client
X{
X	1 while (! -l $sready);
X	unlink($sready);
X	
X	&main'socket(CT,DGRAM,$uport,"/tmp/us2.$$");
X	print CT "Client here\n";
X	$x = <CT>;
X	print ($x eq "Server here\n" ? "ok 8\n" : "not ok 8\n");
X	close(CT);
X	unlink("/tmp/us2.$$");
X}
X
SHAR_EOF
chmod 0755 sockets.t || echo "restore of sockets.t fails"
exit 0