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: [email protected] (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: <[email protected]>
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

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.