+++ /dev/null
-Frequently Asked Questions
-
-Q1) Is this the same thing as db-sockets
-
-A1) Basically, yes. It's hoped that bundling it as a contrib may make
-it easier for people to install.
-
-Q2) What are these test things? How do I run the tests?
-
-A2) Some of the tests get run automatically when the package is built
-- if the tests fail, the package is not installed. The rest of the
-tests depend on having Internet access which may not always be the
-case on a build machine, but you can run them by hand from the Lisp
-listener, if you want to:
-
-* (rt:do-tests)
-
-This uses the regression tester from the CMU AI repository to run the
-tests defined in tests.lisp. You should not get any test failures,
-unless -
-
-a) your "echo" services are disabled in inetd.conf -
-SIMPLE-TCP-CLIENT and SIMPLE-UDP-CLIENT both attempt to connect to the
-echo port.
-
-b) you're not on the internet - SIMPLE-HTTP-CLIENT attempts to connect to
-ww.telent.net, and other tests do DNS lookups for well-known hosts
-
-c) a.root-servers.net has moved IP address
-
-Q3) What's constants.lisp-temp?
-
-A3) Many of the structure offsets and symbolic constants vary between
-architectures and operating systems. To avoid a maintenance
-nightmare, we derive them automatically by creating and running a
-small C program. The C program is created by def-to-lisp.lisp
-with input from constants.lisp
-
-Some of the exciting stuff in bsd-sockets.asd writes a C program in
-/tmp, compiles it, and runs it. The output from this program becomes
-constants.lisp-temp
-
-Q4) Is this compatible with ACL? With CMUCL's internet.lisp?
-
-A4) No. This is a sufficiently low-level interface that either could
-be built on top of it, though. Actually, theq ACL-COMPAT library that
-comes with Portable Allegroserve may already have this.
+++ /dev/null
-SYSTEM=bsd-sockets
-
-all:
- $(MAKE) -C ../asdf
- echo "(asdf:operate 'asdf:load-op :$(SYSTEM))" | \
- $(SBCL) --eval '(load "../asdf/asdf")'
-
-test:
- true
-
-install: all
- tar cf - . | ( cd $(INSTALL_DIR) && tar xpvf - )
- ( cd $(SBCL_HOME)/systems && ln -fs ../$(SYSTEM)/$(SYSTEM).asd . )
+++ /dev/null
-Changes in 0.58 - Sun Jan 12 00:53:53 GMT 2003
-
-Fix db-sockets.asd so that it doesn't recompile alien.so every single
-time.
-
-Announce anon-cvs repo for people to get in-between versions
-
-MSG_NOSIGNAL is a linuxism, I'm told.
-
-Changes in 0.57 - Wed Sep 11 12:27:32 2002
-
-Fix for compilation bug reported by Andreas Fuchs. Don't use 0.56, it
-was a mistakenly uploaded file
-
-Changes in 0.55 - Tue Sep 10 23:42:27 2002
-
-Fix for a unix-domain sockets problem, courtesy of David Lichteblau
-
-Changes in 0.54 - Wed Mar 6 2002
-
-New version mostly due to new packaging format: this is now a
-vendor-neutral cclan (vn-cclan) package. See INSTALL file
-
-Fixed bug in af_file support.
-
-Changes in 0.53 - Thu Jan 31 2002
-
-By popular request (two people, at last count) this works in CMUCL again.
-Also, some documentation updates, a really silly bug in make-instance
-fixed, and support for the TCP_NODELAY socket option
-
-Changes in 0.52 - Tue Jan 8 2002
-
-Very few. This release was put out a few days after 0.5.1 because
-0.5.1 is less than 0.42, and various packaging tools tend to get
-confused to see version numbers go backwards.
-
-Changes in 0.5.1 - Mon Jan 7 2002
-
-Support for AF_FILE (formerly known as Unix-domain) sockets; both
-stream and datagram.
-
-MAKE-INET-SOCKET has been deprecated (but is still there). New code is
-encouraged to write (make-instance 'inet-socket ...) instead
-
-Fairly pervasive low-level changes to avoid leaking quite as much
-memory. May also have fixed a file descriptor leak in the process.
-
-Changes in 0.42
-
-Repackaged to be a debian-like package, and use
-common-lisp-controller, which required a reasonably large amount of
-thrashing around renaming files and so on.
-
-New function GET-HOST-BY-ADDRESS returns a HOST-ENT just like
-GET-HOST-BY-NAME does.
-
-Tested on SBCL 0.6.12.7.flaky1.1 (x86), SBCL 0.6.12.7 (Alpha),
-CMUCL 18c+ 2.5.2 (x86)
-
-Changes in 0.41 - Sun Jan 7 2001
-
-Cleanups in the tests for more intelligible failure messages
-
-SOCKET-ERROR conditions now inherit from ERROR not CONDITION - as
-otherwise IGNORE-ERROR doesn't ignore them, which is unexpected
-
-Tested on debian cmucl 2.4.19 , sbcl pre-0.6.9 snapshot of Nov 30 2000.
-
-The latter doesn't build without manual intervention:
-
- error in function SB-C::%DEFCONSTANT:
- The constant INET-ADDRESS-ANY is being redefined.
-
-(just continue)
-
-Changes in 0.4 - Mon Jul 3 2000
-
-Now works (passes tests) in
-
-- Solaris 2.6 SPARC (CMUCL 18b)
-- Debian x86 GNU/Linux (Debian CMUCL 2.4.19)
-- Debian x86 GNU/Linux (SBCL 0.6.5)
-
-Some CMUCL-on-FreeBSD changes (mostly involve commenting stuff out). Doesn't
-work, though (but might in SBCL/FreeBSD)
-
-The Solaris changes comprised disabling bits and fixing an
-endianness problem.
-
-
-Changes in 0.37 - Sat May 20 2000
-
-
-Changes from Martin Atzmueller to make it compile more cleanly in SBCL
-
-Changes in 0.36 - Thu May 11 2000
-
-Some documentation cleanups
-
-New functions NON-BLOCKING-MODE and (SETF NON-BLOCKING-MODE)
-
-EINTR now generates a INTERRUPTED-ERROR condition
-
-
-Changes in 0.35 - Mon May 1 2000
-
-
-MAKE-INET-SOCKET now can take a keyword for PROTOCOL: it lowercases
-the symbol's name, then looks it up using GET-PROTOCOL-BY-NAME
-
-A bad bug in the CMUCL code (which caused the EXTENSIONS package to
-disappear - oops...) was found and fixed
-
-
-Changes in 0.3 - Apr 17 2000
-
-Now works with SBCL (0.6.1, 0.6.2) in addition to CMUCL.
-
-Fixed to actually work with a READ-SEQUENCE implementation that does
-the right thing instead of the (suspected buggy) implementation in
-CMUCL. At least, the Hyperspec doesn't give me any particular cause
-for belief that READ-SEQUENCE can return before reading as much as the
-user asks it to, which is what we were using it for hitherto.
-
-The Makefile got a lot bigger. defs-to-lisp.lisp got a lot smaller.
-
-Standard make target creates "sockets-system.x86f" which contains all
-the code in a single file
-
-If you want to build it on SBCL you'll need a working defsystem for
-said platform first. This involves some fiddling around: first you
-need to get it from CLOCC on Sourceforge then you need to patch it
-with this diff. Unless you're looking at a version newer than 1.12, in
-which case they might have patched it already before you
+++ /dev/null
-o/~ Hey Mr Tambourine Man, play some -*- Text -*- for me o/~
-
-A semi-sane sockets interface for SBCL. Usually also works in CMUCL,
-but is rarely actually tested there so may require some massaging
-
-See INSTALL for prerequisites and build details
-
-It uses the regression tester from the CMU AI repository. This is
-bundled in the file rt.lisp which is unchanged except where I added a
-DEFPACKAGE form. The tests themselves are in tests.lisp, and can be
-run using the Makefile target intended for the purpose, or by
-evaluating (rt:do-tests). Note that one of the tests is an HTTP
-client that connects back to ww.telent.net; if this bothers your
-expectations of privacy, don't run it.
-
-There is an automatically generated API reference in
-api-reference.html which you can regenerate if you can figure out how
-doc.lisp works. You might find the examples in tests.lisp useful,
-too.
-
-Feedback, patches, development versions
-
-Instructions on how to access the CVS repository for db-sockets are
-at http://cvs.telent.net/
-
-If you find bugs or want to send patches for enhancements, by email to
-Daniel Barlow <dan@telent.net>, but please check the CVS version first.
-
-$Id$
+++ /dev/null
-
-Things To Do - Urgent! (with apologies to Douglas Adams)
-
-I probably have opinions about how to do most of these. Even if not,
-I almost certainly have opinions on how not to. Send me a proposal
-before spending serious amounts of time on it.
-
-- the rest of the functions. A socket-send that doesn't use streams
-would be a good one
-
-- the rest of the errors
-
-- the rest of the socket options: integer and boolean socket-level
-options are in but need odd ones, plus tcp, udp, ip
-
-- async name service lookups.
-
-- write tests for socket-name and socket-peername
-
-- documentation: see doc.lisp, but beware: it's grotty.
+++ /dev/null
-#include <netdb.h>
-
-int get_h_errno()
-{
- return h_errno;
-}
+++ /dev/null
-/* create a .o file with undefined references to all the C stuff we need
- * that cmucl hasn't already fouind for us. Not needed on Linux/i386
- * because it has dynamic loading anyway
- */
-
-void likewecare() {
- getprotobyname();
-}
-
+++ /dev/null
-<html><head><title>db-sockets API Reference</title></head><body>
-<h1>Package SOCKETS</h1>
-
-<P>
-A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD
-socket API for C and Graham Barr's IO::Socket classes for Perl.
-<P>
-We represent sockets as CLOS objects, and rename a lot of methods and
-arguments to fit Lisp style more closely.
-<P>
-
-<P>
-<h2>Contents</h2>
-<P>
-<ol>
-<li> General concepts
-<li> Methods applicable to all <a href="#socket">sockets</a>
-<li> <a href="#sockopt">Socket Options</a>
-<li> Methods applicable to a particular subclass
-<ol>
-<li> <a href="#internet">INET-SOCKET</a> - Internet Protocol (TCP, UDP, raw) sockets
-<li> Methods on <a href="#UNIX-SOCKET">UNIX-SOCKET</a> - Unix-domain sockets
-</ol>
-<li> <a href="#name-service">Name resolution</a> (DNS, /etc/hosts, &c)
-</ol>
-<P>
-<h2>General concepts</h2>
-<P>
-<p>Most of the functions are modelled on the BSD socket API. BSD sockets
-are widely supported, portably <i>(well, fairly portably)</i>
-available on a variety of systems, and documented. There are some
-differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly
-<P>
-<ul>
-<li> Where the C API would typically return -1 and set errno, db-sockets
-signals an error. All the errors are subclasses of SOCKET-CONDITION
-and generally correspond one for one with possible <tt>errno</tt> values
-<P>
-<li> We use multiple return values in many places where the C API would use p[ass-by-reference values
-<P>
-<li> We can often avoid supplying an explicit <i>length</i> argument to
-functions because we already know how long the argument is.
-<P>
-<li> IP addresses and ports are represented in slightly friendlier fashion
-than "network-endian integers". See the section on <a href="#internet"
->Internet domain</a> sockets for details.
-</ul>
-<P>
-<P>
-<hr> <h2>SOCKETs</h2>
-<P>
-<p><a name="SOCKET"><i>Class: </i><b>SOCKET</b></a>
-<p><b>Slots:</b><ul><li>FILE-DESCRIPTOR : </li>
-<li>FAMILY : </li>
-<li>PROTOCOL : </li>
-<li>TYPE : </li>
-<li>STREAM : </li>
-</ul><p><a name="SOCKET-BIND"><table width="100%"><tr><td width="80%">(socket-bind <i> (s <a href="#socket">socket</a>) &rest address</i>)</td><td align=right>Generic Function</td></tr></table>
-<p><a name="SOCKET-ACCEPT"><table width="100%"><tr><td width="80%">(socket-accept <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Perform the accept(2) call, returning a newly-created connected socket
-and the peer address as multiple values</blockquote>
-<p><a name="SOCKET-CONNECT"><table width="100%"><tr><td width="80%">(socket-connect <i> (s <a href="#socket">socket</a>) &rest address</i>)</td><td align=right>Generic Function</td></tr></table>
-<p><a name="SOCKET-PEERNAME"><table width="100%"><tr><td width="80%">(socket-peername <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Return the socket's peer; depending on the address family this may return multiple values</blockquote>
-<p><a name="SOCKET-NAME"><table width="100%"><tr><td width="80%">(socket-name <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Return the address (as vector of bytes) and port that the socket is bound to, as multiple values</blockquote>
-<p><a name="SOCKET-RECEIVE"><table width="100%"><tr><td width="80%">(socket-receive <i> (socket <a href="#socket">socket</a>) buffer length &key oob peek waitall (element-type
- 'character)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Read LENGTH octets from <a href="#SOCKET">SOCKET</a> into BUFFER (or a freshly-consed buffer if
-NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
-used, so at least one of these two arguments must be non-NIL. If
-BUFFER is supplied, it had better be of an element type one octet wide.
-Returns the buffer, its length, and the address of the peer
-that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
-so that the actual packet length is returned even if the buffer was too
-small</blockquote>
-<p><a name="SOCKET-LISTEN"><table width="100%"><tr><td width="80%">(socket-listen <i> (socket <a href="#socket">socket</a>) backlog</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Mark <a href="#SOCKET">SOCKET</a> as willing to accept incoming connections. BACKLOG
-defines the maximum length that the queue of pending connections may
-grow to before new connection attempts are refused. See also listen(2)</blockquote>
-<p><a name="SOCKET-CLOSE"><table width="100%"><tr><td width="80%">(socket-close <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Close <a href="#SOCKET">SOCKET</a>. May throw any kind of error that write(2) would have
-thrown. If <a href="#SOCKET-MAKE-STREAM">SOCKET-MAKE-STREAM</a> has been called, calls CLOSE on that
-stream instead</blockquote>
-<p><a name="SOCKET-MAKE-STREAM"><table width="100%"><tr><td width="80%">(socket-make-stream <i> (socket <a href="#socket">socket</a>) &rest args</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Find or create a STREAM that can be used for IO on <a href="#SOCKET">SOCKET</a> (which
-must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM.</blockquote>
-<hr>
-<H2> Socket Options </h2>
-<a name="sockopt"> </a>
-<p> A subset of socket options are supported, using a fairly
-general framework which should make it simple to add more as required
-- see sockopt.lisp for details. The name mapping from C is fairly
-straightforward: <tt>SO_RCVLOWAT</tt> becomes
-<tt>sockopt-receive-low-water</tt> and <tt>(setf
-sockopt-receive-low-water)</tt>.
-|<p><a name="SOCKOPT-REUSE-ADDRESS"><table width="100%"><tr><td width="80%">(sockopt-reuse-address <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-REUSEADDR socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-KEEP-ALIVE"><table width="100%"><tr><td width="80%">(sockopt-keep-alive <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-KEEPALIVE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-OOB-INLINE"><table width="100%"><tr><td width="80%">(sockopt-oob-inline <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-OOBINLINE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-BSD-COMPATIBLE"><table width="100%"><tr><td width="80%">(sockopt-bsd-compatible <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-BSDCOMPAT socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-PASS-CREDENTIALS"><table width="100%"><tr><td width="80%">(sockopt-pass-credentials <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-PASSCRED socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-DEBUG"><table width="100%"><tr><td width="80%">(sockopt-debug <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-DEBUG socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-DONT-ROUTE"><table width="100%"><tr><td width="80%">(sockopt-dont-route <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-DONTROUTE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-BROADCAST"><table width="100%"><tr><td width="80%">(sockopt-broadcast <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the SO-BROADCAST socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<p><a name="SOCKOPT-TCP-NODELAY"><table width="100%"><tr><td width="80%">(sockopt-tcp-nodelay <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
-<blockquote>Return the value of the TCP-NODELAY socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
-<hr> <h2>INET-domain sockets</h2>
-<P>
-<p>The TCP and UDP sockets that you know and love. Some representation issues:
-<ul>
-<li>These functions do not accept hostnames directly: see <a href="#name-service">name resolution</a>
-<li>Internet <b>addresses</b> are represented by vectors of <tt>(unsigned-byte 8)</tt> - viz. <tt>#(127 0 0 1)</tt>. <b>Ports</b> are just integers: <tt>6010</tt>. No conversion between network- and host-order data is needed from the user of this package.
-<li><b><i>socket addresses</i></b> are represented by the two values for <b>address</b> and <b>port</b>, so for example, <tt>(<a href="#SOCKET-CONNECT">socket-connect</a> s #(192.168.1.1) 80)</tt>
-</ul>
-<P>
-<p><a name="INET-SOCKET"><i>Class: </i><b>INET-SOCKET</b></a>
-<p><b>Slots:</b><ul><li>FAMILY : </li>
-</ul><p><a name="MAKE-INET-ADDRESS"><table width="100%"><tr><td width="80%">(make-inet-address <i> dotted-quads</i>)</td><td align=right>Function</td></tr></table>
-<blockquote>Return a vector of octets given a string DOTTED-QUADS in the format
-"127.0.0.1"</blockquote>
-<p><a name="GET-PROTOCOL-BY-NAME"><table width="100%"><tr><td width="80%">(get-protocol-by-name <i> name</i>)</td><td align=right>Function</td></tr></table>
-<blockquote>Returns the network protocol number associated with the string NAME,
-using getprotobyname(2) which typically looks in NIS or /etc/protocols</blockquote>
-<p><a name="MAKE-INET-SOCKET"><table width="100%"><tr><td width="80%">(make-inet-socket <i> type protocol</i>)</td><td align=right>Function</td></tr></table>
-<blockquote>Make an INET socket. Deprecated in favour of make-instance</blockquote>
-<hr> <h2>File-domain sockets</h2>
-<P>
-File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were
-renamed by POSIX presumably on the basis that they may be
-available on other systems too.
-<P>
-A file-domain socket address is a string, which is used to create a node
-in the local filesystem. This means of course that they cannot be used across
-a network.
-<P>
-|<p><a name="UNIX-SOCKET"><i>Class: </i><b>UNIX-SOCKET</b></a>
-<p><b>Slots:</b><ul><li>FAMILY : </li>
-</ul><hr> <a name="name-service"><h2>Name Service</h2></a>
-<P>
-<p>Presently name service is implemented by calling whatever
-gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS,
-or something completely different. Typically it's controlled by
-/etc/nsswitch.conf
-<P>
-<p> Direct links to the asynchronous resolver(3) routines would be nice to have
-eventually, so that we can do DNS lookups in parallel with other things
-<p><a name="HOST-ENT"><i>Class: </i><b>HOST-ENT</b></a>
-<p><b>Slots:</b><ul><li>NAME : </li>
-<li>ALIASES : </li>
-<li>ADDRESS-TYPE : </li>
-<li>ADDRESSES : </li>
-</ul><p><a name="HOST-ENT-ADDRESS"><table width="100%"><tr><td width="80%">(host-ent-address <i> (host-ent <a href="#host-ent">host-ent</a>)</i>)</td><td align=right>Method</td></tr></table>
-<p><a name="GET-HOST-BY-NAME"><table width="100%"><tr><td width="80%">(get-host-by-name <i> host-name</i>)</td><td align=right>Function</td></tr></table>
-<blockquote>Returns a <a href="#HOST-ENT">HOST-ENT</a> instance for HOST-NAME or throws some kind of condition.
-HOST-NAME may also be an IP address in dotted quad notation or some other
-weird stuff - see gethostbyname(3) for grisly details.</blockquote>
-<p><a name="GET-HOST-BY-ADDRESS"><table width="100%"><tr><td width="80%">(get-host-by-address <i> address</i>)</td><td align=right>Function</td></tr></table>
-<blockquote>Returns a <a href="#HOST-ENT">HOST-ENT</a> instance for ADDRESS, which should be a vector of
-(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
-grisly details.</blockquote>
-<p><a name="NAME-SERVICE-ERROR"><table width="100%"><tr><td width="80%">(name-service-error <i> where</i>)</td><td align=right>Function</td></tr></table>
-<hr><p><a name="NON-BLOCKING-MODE"><table width="100%"><tr><td width="80%">(non-blocking-mode <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
-<blockquote>Is <a href="#SOCKET">SOCKET</a> in non-blocking mode?</blockquote>
-<hr>
-<P>
-<H1>Tests</h1>
-<P>
-There should be at least one test for pretty much everything you can do
-with the package. In some places I've been more diligent than others; more
-tests gratefully accepted.
-<P>
-Tests are in the file <tt>tests.lisp</tt> and also make good examples.
-<P>
-|
-<h2>Unix-domain sockets</h2>
-<P>
-A fairly rudimentary test that connects to the syslog socket and sends a
-message. Priority 7 is kern.debug; you'll probably want to look at
-/etc/syslog.conf or local equivalent to find out where the message ended up
-|
\ No newline at end of file
+++ /dev/null
-(in-package :sockint)
-
-;;; borrowed from CMUCL manual, lightly ported
-
-(defun array-data-address (array)
- "Return the physical address of where the actual data of an array is
-stored.
-
-ARRAY must be a specialized array type - an array of one of these types:
-
- double-float
- single-float
- (unsigned-byte 32)
- (unsigned-byte 16)
- (unsigned-byte 8)
- (signed-byte 32)
- (signed-byte 16)
- (signed-byte 8)
-"
- (declare (type (or (array (signed-byte 8))
- (array base-char)
- simple-base-string
- (array (signed-byte 16))
- (array (signed-byte 32))
- (array (unsigned-byte 8))
- (array (unsigned-byte 16))
- (array (unsigned-byte 32))
- (array single-float)
- (array double-float))
- array)
- (optimize (speed 0) (debug 3) (safety 3)))
- ;; with-array-data will get us to the actual data. However, because
- ;; the array could have been displaced, we need to know where the
- ;; data starts.
-
- (let* ((type (car (multiple-value-list (array-element-type array))))
- (type-size
- (cond ((or (equal type '(signed-byte 8))
- (equal type 'cl::base-char)
- (equal type '(unsigned-byte 8)))
- 1)
- ((or (equal type '(signed-byte 16))
- (equal type '(unsigned-byte 16)))
- 2)
- ((or (equal type '(signed-byte 32))
- (equal type '(unsigned-byte 32)))
- 4)
- ((equal type 'single-float)
- 4)
- ((equal type 'double-float)
- 8)
- (t (error "Unknown specialized array element type")))))
- (with-array-data ((data array)
- (start)
- (end))
- (declare (ignore end))
- ;; DATA is a specialized simple-array. Memory is laid out like this:
- ;;
- ;; byte offset Value
- ;; 0 type code (e.g. 70 for double-float vector)
- ;; 4 FIXNUMIZE(number of elements in vector)
- ;; 8 1st element of vector
- ;; ... ...
- ;;
- (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data)))))
- (declare (type (unsigned-byte 32) addr)
- (optimize (speed 3) (safety 0)))
- (sb-sys:int-sap (the (unsigned-byte 32)
- (+ addr (* type-size start))))))))
-
-
-
+++ /dev/null
-;;; -*- Lisp -*-
-
-(defpackage #:bsd-sockets-system (:use #:asdf #:cl))
-(in-package #:bsd-sockets-system)
-
-;;; constants.lisp requires special treatment
-
-(defclass constants-file (cl-source-file) ())
-
-(defmethod perform ((op compile-op) (component constants-file))
- ;; we want to generate all our temporary files in the fasl directory
- ;; because that's where we have write permission. Can't use /tmp;
- ;; it's insecure (these files will later be owned by root)
- (let* ((output-file (car (output-files op component)))
- (filename (component-pathname component))
- (real-output-file
- (if (typep output-file 'logical-pathname)
- (translate-logical-pathname output-file)
- (pathname output-file)))
- (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
- (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
- (tmp-constants (merge-pathnames #p"constants.lisp-temp"
- real-output-file)))
- (princ (list filename output-file real-output-file
- tmp-c-source tmp-a-dot-out tmp-constants))
- (terpri)
- (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "BSD-SOCKETS-SYSTEM"))
- filename tmp-c-source :bsd-sockets-internal)
- (and
- (= (run-shell-command
- "/usr/bin/gcc -o ~S ~S" (namestring tmp-a-dot-out)
- (namestring tmp-c-source)) 0)
- (= (run-shell-command "~A >~A"
- (namestring tmp-a-dot-out)
- (namestring tmp-constants)) 0)
- (compile-file tmp-constants :output-file output-file))))
-
-
-;;; we also have a shared library with some .o files in it
-
-(defclass unix-dso (module) ())
-(defun unix-name (pathname)
- (namestring
- (typecase pathname
- (logical-pathname (translate-logical-pathname pathname))
- (t pathname))))
-
-(defmethod asdf::input-files ((operation compile-op) (dso unix-dso))
- (mapcar #'component-pathname (module-components dso)))
-
-(defmethod output-files ((operation compile-op) (dso unix-dso))
- (let ((dir (component-pathname dso)))
- (list
- (make-pathname :type "so"
- :name (car (last (pathname-directory dir)))
- :directory (butlast (pathname-directory dir))
- :defaults dir))))
-
-
-(defmethod perform :after ((operation compile-op) (dso unix-dso))
- (let ((dso-name (unix-name (car (output-files operation dso)))))
- (unless (zerop
- (run-shell-command
- "gcc -shared -o ~S ~{~S ~}"
- dso-name
- (mapcar #'unix-name
- (mapcan (lambda (c)
- (output-files operation c))
- (module-components dso)))))
- (error 'operation-error :operation operation :component dso))))
-
-;;; if this goes into the standard asdf, it could reasonably be extended
-;;; to allow cflags to be set somehow
-(defmethod output-files ((op compile-op) (c c-source-file))
- (list
- (make-pathname :type "o" :defaults
- (component-pathname c))))
-(defmethod perform ((op compile-op) (c c-source-file))
- (unless
- (= 0 (run-shell-command "/usr/bin/gcc -fPIC -o ~S -c ~S"
- (unix-name (car (output-files op c)))
- (unix-name (component-pathname c))))
- (error 'operation-error :operation op :component c)))
-
-(defmethod perform ((operation load-op) (c c-source-file))
- t)
-
-(defmethod perform ((o load-op) (c unix-dso))
- (let ((co (make-instance 'compile-op)))
- (let ((filename (car (output-files co c))))
- #+cmu (ext:load-foreign filename)
- #+sbcl (sb-alien:load-1-foreign filename))))
-
-(defsystem bsd-sockets
- :version "0.58"
- :components ((:file "defpackage" :depends-on ("rt"))
- (:file "split" :depends-on ("defpackage"))
- (:file "array-data" :depends-on ("defpackage"))
- (:unix-dso "alien"
- :components ((:c-source-file "undefs")
- (:c-source-file "get-h-errno")))
- (:file "malloc" :depends-on ("defpackage"))
- (:file "foreign-glue" :depends-on ("defpackage" "malloc"))
- (:constants-file "constants"
- :pathname "constants.lisp"
- :depends-on
- ("def-to-lisp" "defpackage" "foreign-glue"))
- (:file "sockets"
- :depends-on ("constants" "array-data"))
-
- (:file "sockopt" :depends-on ("sockets"))
- (:file "inet" :depends-on ("sockets" "split" "constants" ))
- (:file "unix" :depends-on ("sockets" "split" "constants" ))
- (:file "name-service" :depends-on ("sockets" "constants" "alien"))
- (:file "misc" :depends-on ("sockets" "constants"))
-
- (:file "rt")
- (:file "def-to-lisp")
- (:file "tests" :depends-on ("inet" "sockopt" "rt"))
-
- (:static-file "NEWS")
- (:static-file "INSTALL")
- (:static-file "README")
- (:static-file "index" :pathname "index.html")
- (:static-file "doc" :pathname "doc.lisp")
- (:static-file "TODO")))
-
+++ /dev/null
-;;; -*- Lisp -*-
-
-;;; This isn't really lisp, but it's definitely a source file. we
-;;; name it thus to avoid having to mess with the clc lpn translations
-
-;;; first, the headers necessary to find definitions of everything
-("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.h" "sys/un.h"
- "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h"
- "netdb.h" "errno.h" "netinet/tcp.h" "fcntl.h" )
-
-;;; then the stuff we're looking for
-((:integer af-inet "AF_INET" "IP Protocol family")
- (:integer af-unspec "AF_UNSPEC" "Unspecified.")
-#-solaris (:integer af-local "AF_LOCAL" "Local to host (pipes and file-domain).")
- (:integer af-unix "AF_UNIX" "Old BSD name for af-local. ")
-#-(or solaris freebsd) (:integer af-file "AF_FILE" "POSIX name for af-local. ")
-#+linux (:integer af-inet6 "AF_INET6" "IP version 6. ")
-#+linux (:integer af-route "AF_NETLINK" "Alias to emulate 4.4BSD ")
-
- (:integer sock-stream "SOCK_STREAM"
- "Sequenced, reliable, connection-based byte streams.")
- (:integer sock-dgram "SOCK_DGRAM"
- "Connectionless, unreliable datagrams of fixed maximum length.")
- (:integer sock-raw "SOCK_RAW"
- "Raw protocol interface.")
- (:integer sock-rdm "SOCK_RDM"
- "Reliably-delivered messages.")
- (:integer sock-seqpacket "SOCK_SEQPACKET"
- "Sequenced, reliable, connection-based, datagrams of fixed maximum length.")
-
- (:integer sol-socket "SOL_SOCKET")
-
- ;; some of these may be linux-specific
- (:integer so-debug "SO_DEBUG"
- "Enable debugging in underlying protocol modules")
- (:integer so-reuseaddr "SO_REUSEADDR" "Enable local address reuse")
- (:integer so-type "SO_TYPE") ;get only
- (:integer so-error "SO_ERROR") ;get only (also clears)
- (:integer so-dontroute "SO_DONTROUTE"
- "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address")
- (:integer so-broadcast "SO_BROADCAST" "Request permission to send broadcast datagrams")
- (:integer so-sndbuf "SO_SNDBUF")
-#+linux (:integer so-passcred "SO_PASSCRED")
- (:integer so-rcvbuf "SO_RCVBUF")
- (:integer so-keepalive "SO_KEEPALIVE"
- "Send periodic keepalives: if peer does not respond, we get SIGPIPE")
- (:integer so-oobinline "SO_OOBINLINE"
- "Put out-of-band data into the normal input queue when received")
- (:integer so-no-check 11)
-#+linux (:integer so-priority "SO_PRIORITY")
- (:integer so-linger "SO_LINGER"
- "For reliable streams, pause a while on closing when unsent messages are queued")
-#+linux (:integer so-bsdcompat "SO_BSDCOMPAT")
- (:integer so-sndlowat "SO_SNDLOWAT")
- (:integer so-rcvlowat "SO_RCVLOWAT")
- (:integer so-sndtimeo "SO_SNDTIMEO")
- (:integer so-rcvtimeo "SO_RCVTIMEO")
-
- (:integer tcp-nodelay "TCP_NODELAY")
- #+linux (:integer so-bindtodevice "SO_BINDTODEVICE")
- (:integer ifnamsiz "IFNAMSIZ")
-
- (:integer EADDRINUSE "EADDRINUSE")
- (:integer EAGAIN "EAGAIN")
- (:integer EBADF "EBADF")
- (:integer ECONNREFUSED "ECONNREFUSED")
- (:integer EINTR "EINTR")
- (:integer EINVAL "EINVAL")
- (:integer ENOBUFS "ENOBUFS")
- (:integer ENOMEM "ENOMEM")
- (:integer EOPNOTSUPP "EOPNOTSUPP")
- (:integer EPERM "EPERM")
- (:integer EPROTONOSUPPORT "EPROTONOSUPPORT")
- (:integer ESOCKTNOSUPPORT "ESOCKTNOSUPPORT")
- (:integer ENETUNREACH "ENETUNREACH")
-
- (:integer NETDB-INTERNAL "NETDB_INTERNAL" "See errno.")
- (:integer NETDB-SUCCESS "NETDB_SUCCESS" "No problem.")
- (:integer HOST-NOT-FOUND "HOST_NOT_FOUND" "Authoritative Answer Host not found.")
- (:integer TRY-AGAIN "TRY_AGAIN" "Non-Authoritative Host not found, or SERVERFAIL.")
- (:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
- (:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.")
- (:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.")
-
- (:integer O-NONBLOCK "O_NONBLOCK")
- (:integer f-getfl "F_GETFL")
- (:integer f-setfl "F_SETFL")
-
- #+linux (:integer msg-nosignal "MSG_NOSIGNAL")
- (:integer msg-oob "MSG_OOB")
- (:integer msg-peek "MSG_PEEK")
- (:integer msg-trunc "MSG_TRUNC")
- (:integer msg-waitall "MSG_WAITALL")
-
- #|
- ;;; stat is nothing to do with sockets, but I keep it around for testing
- ;;; the ffi glue
- (:structure stat ("struct stat"
- (t dev "dev_t" "st_dev")
- ((alien:integer 32) atime "time_t" "st_atime")))
- (:function stat ("stat" (integer 32)
- (file-name (* t))
- (buf (* t))))
- |#
- (:structure protoent ("struct protoent"
- ((* t) name "char *" "p_name")
- ((* (* t)) aliases "char **" "p_aliases")
- (integer proto "int" "p_proto")))
- (:function getprotobyname ("getprotobyname" (* t)
- (name c-string)))
- (:integer inaddr-any "INADDR_ANY")
- (:structure in-addr ("struct in_addr"
- ((array (unsigned 8) 4) addr "u_int32_t" "s_addr")))
- (:structure sockaddr-in ("struct sockaddr_in"
- (integer family "sa_family_t" "sin_family")
- ((array (unsigned 8) 2) port "u_int16_t" "sin_port")
- ((array (unsigned 8) 4) addr "struct in_addr" "sin_addr")))
- (:structure sockaddr-un ("struct sockaddr_un"
- (integer family "sa_family_t" "sun_family")
- ((array (unsigned 8) 108) path "char" "sun_path")))
- (:structure hostent ("struct hostent"
- ((* t) name "char *" "h_name")
- ((* c-string) aliases "char **" "h_aliases")
- (integer type "int" "h_addrtype")
- (integer length "int" "h_length")
- ((* (* (unsigned 8))) addresses "char **" "h_addr_list")))
- (:function socket ("socket" integer
- (domain integer)
- (type integer)
- (protocol integer)))
- (:function bind ("bind" integer
- (sockfd integer)
- (my-addr (* t))
- (addrlen integer)))
- (:function listen ("listen" integer
- (socket integer)
- (backlog integer)))
- (:function accept ("accept" integer
- (socket integer)
- (my-addr (* t))
- (addrlen integer :in-out)))
- (:function getpeername ("getpeername" integer
- (socket integer)
- (her-addr (* t))
- (addrlen integer :in-out)))
- (:function getsockname ("getsockname" integer
- (socket integer)
- (my-addr (* t))
- (addrlen integer :in-out)))
- (:function connect ("connect" integer
- (socket integer)
- (his-addr (* t))
- (addrlen integer )))
-
- (:function close ("close" integer
- (fd integer)))
- (:function recvfrom ("recvfrom" integer
- (socket integer)
- (buf (* t))
- (len integer)
- (flags integer)
- (sockaddr (* t))
- (socklen (* integer))))
- (:function gethostbyname ("gethostbyname" (* t ) (name c-string)))
- (:function gethostbyaddr ("gethostbyaddr" (* t )
- (addr (* t))
- (len integer)
- (af integer)))
- (:structure hostent ("struct hostent"
- ((* t) name "char *" "h_name")
- (integer length "int" "h_length")))
-
- (:function setsockopt ("setsockopt" integer
- (socket integer)
- (level integer)
- (optname integer)
- (optval (* t))
- (optlen integer)))
- (:function fcntl ("fcntl" integer
- (fd integer)
- (cmd integer)
- (arg integer)))
- (:function getsockopt ("getsockopt" integer
- (socket integer)
- (level integer)
- (optname integer)
- (optval (* t))
- (optlen integer :in-out))))
-)
+++ /dev/null
-(in-package :BSD-SOCKETS-INTERNAL)
-(defconstant size-of-int 4)
-(defconstant size-of-char 1)
-(defconstant size-of-long 4)
-(defconstant AF-INET 2 "IP Protocol family")
-(defconstant AF-UNSPEC 0 "Unspecified.")
-(defconstant AF-LOCAL 1 "Local to host (pipes and file-domain).")
-(defconstant AF-UNIX 1 "Old BSD name for af-local. ")
-(defconstant AF-FILE 1 "POSIX name for af-local. ")
-(defconstant AF-INET6 10 "IP version 6. ")
-(defconstant AF-ROUTE 16 "Alias to emulate 4.4BSD ")
-(defconstant SOCK-STREAM 1 "Sequenced, reliable, connection-based byte streams.")
-(defconstant SOCK-DGRAM 2 "Connectionless, unreliable datagrams of fixed maximum length.")
-(defconstant SOCK-RAW 3 "Raw protocol interface.")
-(defconstant SOCK-RDM 4 "Reliably-delivered messages.")
-(defconstant SOCK-SEQPACKET 5 "Sequenced, reliable, connection-based, datagrams of fixed maximum length.")
-(defconstant SOL-SOCKET 1 "NIL")
-(defconstant SO-DEBUG 1 "Enable debugging in underlying protocol modules")
-(defconstant SO-REUSEADDR 2 "Enable local address reuse")
-(defconstant SO-TYPE 3 "NIL")
-(defconstant SO-ERROR 4 "NIL")
-(defconstant SO-DONTROUTE 5 "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address")
-(defconstant SO-BROADCAST 6 "Request permission to send broadcast datagrams")
-(defconstant SO-SNDBUF 7 "NIL")
-(defconstant SO-PASSCRED 16 "NIL")
-(defconstant SO-RCVBUF 8 "NIL")
-(defconstant SO-KEEPALIVE 9 "Send periodic keepalives: if peer does not respond, we get SIGPIPE")
-(defconstant SO-OOBINLINE 10 "Put out-of-band data into the normal input queue when received")
-(defconstant SO-NO-CHECK 11 "NIL")
-(defconstant SO-PRIORITY 12 "NIL")
-(defconstant SO-LINGER 13 "For reliable streams, pause a while on closing when unsent messages are queued")
-(defconstant SO-BSDCOMPAT 14 "NIL")
-(defconstant SO-SNDLOWAT 19 "NIL")
-(defconstant SO-RCVLOWAT 18 "NIL")
-(defconstant SO-SNDTIMEO 21 "NIL")
-(defconstant SO-RCVTIMEO 20 "NIL")
-(defconstant TCP-NODELAY 1 "NIL")
-(defconstant SO-BINDTODEVICE 25 "NIL")
-(defconstant IFNAMSIZ 16 "NIL")
-(defconstant EADDRINUSE 98 "NIL")
-(defconstant EAGAIN 11 "NIL")
-(defconstant EBADF 9 "NIL")
-(defconstant ECONNREFUSED 111 "NIL")
-(defconstant EINTR 4 "NIL")
-(defconstant EINVAL 22 "NIL")
-(defconstant ENOBUFS 105 "NIL")
-(defconstant ENOMEM 12 "NIL")
-(defconstant EOPNOTSUPP 95 "NIL")
-(defconstant EPERM 1 "NIL")
-(defconstant EPROTONOSUPPORT 93 "NIL")
-(defconstant ESOCKTNOSUPPORT 94 "NIL")
-(defconstant ENETUNREACH 101 "NIL")
-(defconstant NETDB-INTERNAL -1 "See errno.")
-(defconstant NETDB-SUCCESS 0 "No problem.")
-(defconstant HOST-NOT-FOUND 1 "Authoritative Answer Host not found.")
-(defconstant TRY-AGAIN 2 "Non-Authoritative Host not found, or SERVERFAIL.")
-(defconstant NO-RECOVERY 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
-(defconstant NO-DATA 4 "Valid name, no data record of requested type.")
-(defconstant NO-ADDRESS 4 "No address, look for MX record.")
-(defconstant O-NONBLOCK 2048 "NIL")
-(defconstant F-GETFL 3 "NIL")
-(defconstant F-SETFL 4 "NIL")
-(defconstant MSG-NOSIGNAL 16384 "NIL")
-(defconstant MSG-OOB 1 "NIL")
-(defconstant MSG-PEEK 2 "NIL")
-(defconstant MSG-TRUNC 32 "NIL")
-(defconstant MSG-WAITALL 256 "NIL")
-(define-c-struct PROTOENT 12)
-(define-c-accessor PROTOENT-NAME PROTOENT (* T) 0 4)
-(define-c-accessor PROTOENT-ALIASES PROTOENT (* (* T)) 4 4)
-(define-c-accessor PROTOENT-PROTO PROTOENT INTEGER 8 4)
-(declaim (inline GETPROTOBYNAME))
-(def-foreign-routine ("getprotobyname" GETPROTOBYNAME ) (* T) (NAME
- C-STRING) )
-(defconstant INADDR-ANY 0 "NIL")
-(define-c-struct IN-ADDR 4)
-(define-c-accessor IN-ADDR-ADDR IN-ADDR (ARRAY (UNSIGNED 8) 4) 0 4)
-(define-c-struct SOCKADDR-IN 16)
-(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 0 2)
-(define-c-accessor SOCKADDR-IN-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
-(define-c-accessor SOCKADDR-IN-ADDR SOCKADDR-IN (ARRAY (UNSIGNED 8) 4) 4 4)
-(define-c-struct SOCKADDR-UN 110)
-(define-c-accessor SOCKADDR-UN-FAMILY SOCKADDR-UN INTEGER 0 2)
-(define-c-accessor SOCKADDR-UN-PATH SOCKADDR-UN (ARRAY (UNSIGNED 8) 108) 2 108)
-(define-c-struct HOSTENT 20)
-(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4)
-(define-c-accessor HOSTENT-ALIASES HOSTENT (* C-STRING) 4 4)
-(define-c-accessor HOSTENT-TYPE HOSTENT INTEGER 8 4)
-(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4)
-(define-c-accessor HOSTENT-ADDRESSES HOSTENT (* (* (UNSIGNED 8))) 16 4)
-(declaim (inline SOCKET))
-(def-foreign-routine ("socket" SOCKET ) INTEGER (DOMAIN INTEGER) (TYPE
- INTEGER) (PROTOCOL
- INTEGER) )
-(declaim (inline BIND))
-(def-foreign-routine ("bind" BIND ) INTEGER (SOCKFD INTEGER) (MY-ADDR
- (* T)) (ADDRLEN
- INTEGER) )
-(declaim (inline LISTEN))
-(def-foreign-routine ("listen" LISTEN ) INTEGER (SOCKET INTEGER) (BACKLOG
- INTEGER) )
-(declaim (inline ACCEPT))
-(def-foreign-routine ("accept" ACCEPT ) INTEGER (SOCKET INTEGER) (MY-ADDR
- (*
- T)) (ADDRLEN
- INTEGER
- :IN-OUT) )
-(declaim (inline GETPEERNAME))
-(def-foreign-routine ("getpeername" GETPEERNAME ) INTEGER (SOCKET
- INTEGER) (HER-ADDR
- (*
- T)) (ADDRLEN
- INTEGER
- :IN-OUT) )
-(declaim (inline GETSOCKNAME))
-(def-foreign-routine ("getsockname" GETSOCKNAME ) INTEGER (SOCKET
- INTEGER) (MY-ADDR
- (*
- T)) (ADDRLEN
- INTEGER
- :IN-OUT) )
-(declaim (inline CONNECT))
-(def-foreign-routine ("connect" CONNECT ) INTEGER (SOCKET INTEGER) (HIS-ADDR
- (*
- T)) (ADDRLEN
- INTEGER) )
-(declaim (inline CLOSE))
-(def-foreign-routine ("close" CLOSE ) INTEGER (FD INTEGER) )
-(declaim (inline RECVFROM))
-(def-foreign-routine ("recvfrom" RECVFROM ) INTEGER (SOCKET INTEGER) (BUF
- (*
- T)) (LEN
- INTEGER) (FLAGS
- INTEGER) (SOCKADDR
- (*
- T)) (SOCKLEN
- (*
- INTEGER)) )
-(declaim (inline GETHOSTBYNAME))
-(def-foreign-routine ("gethostbyname" GETHOSTBYNAME ) (* T) (NAME
- C-STRING) )
-(declaim (inline GETHOSTBYADDR))
-(def-foreign-routine ("gethostbyaddr" GETHOSTBYADDR ) (* T) (ADDR
- (* T)) (LEN
- INTEGER) (AF
- INTEGER) )
-(define-c-struct HOSTENT 20)
-(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4)
-(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4)
-(declaim (inline SETSOCKOPT))
-(def-foreign-routine ("setsockopt" SETSOCKOPT ) INTEGER (SOCKET
- INTEGER) (LEVEL
- INTEGER) (OPTNAME
- INTEGER) (OPTVAL
- (*
- T)) (OPTLEN
- INTEGER) )
-(declaim (inline FCNTL))
-(def-foreign-routine ("fcntl" FCNTL ) INTEGER (FD INTEGER) (CMD
- INTEGER) (ARG
- INTEGER) )
-(declaim (inline GETSOCKOPT))
-(def-foreign-routine ("getsockopt" GETSOCKOPT ) INTEGER (SOCKET
- INTEGER) (LEVEL
- INTEGER) (OPTNAME
- INTEGER) (OPTVAL
- (*
- T)) (OPTLEN
- INTEGER
- :IN-OUT) )
+++ /dev/null
-(in-package :BSD-SOCKETS-SYSTEM)
-(defvar *export-symbols* nil)
-
-(defun c-for-structure (stream lisp-name c-struct)
- (destructuring-bind (c-name &rest elements) c-struct
- (format stream "printf(\"(define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
- (dolist (e elements)
- (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
- (format stream "printf(\"(define-c-accessor ~A-~A ~A ~A \");~%"
- lisp-name lisp-el-name lisp-name lisp-type)
- ;; offset
- (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
- c-name c-el-name)
- ;; length
- (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
- c-name c-el-name)
- (format stream "printf(\")\\n\");~%")))))
-
-(defun c-for-function (stream lisp-name alien-defn)
- (destructuring-bind (c-name &rest definition) alien-defn
- (let ((*print-right-margin* nil))
- (format stream "printf(\"(declaim (inline ~A))\\n\");~%"
- lisp-name)
- (princ "printf(\"(def-foreign-routine (" stream)
- (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
- (princ lisp-name stream)
- (princ " ) " stream)
- (dolist (d definition)
- (write d :length nil
- :right-margin nil :stream stream)
- (princ " " stream))
- (format stream ")\\n\");")
- (terpri stream))))
-
-
-(defun print-c-source (stream headers definitions package-name)
- ;(format stream "#include \"struct.h\"~%")
- (let ((*print-right-margin* nil))
- (loop for i in headers
- do (format stream "#include <~A>~%" i))
- (format stream "main() { ~%
-printf(\"(in-package ~S)\\\n\");~%" package-name)
- (format stream "printf(\"(defconstant size-of-int %d)\\\n\",sizeof (int));~%")
- (format stream "printf(\"(defconstant size-of-char %d)\\\n\",sizeof (char));~%")
- (format stream "printf(\"(defconstant size-of-long %d)\\\n\",sizeof (long));~%")
- (dolist (def definitions)
- (destructuring-bind (type lispname cname &optional doc) def
- (cond ((eq type :integer)
- (format stream
- "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
- lispname doc cname))
- ((eq type :string)
- (format stream
- "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
- lispname doc cname))
- ((eq type :function)
- (c-for-function stream lispname cname))
- ((eq type :structure)
- (c-for-structure stream lispname cname))
- (t
- (format stream
- "printf(\";; Non hablo Espagnol, Monsieur~%")))))
- (format stream "exit(0);~%}")))
-
-(defun c-constants-extract (filename output-file package)
- (with-open-file (f output-file :direction :output)
- (with-open-file (i filename :direction :input)
- (let* ((headers (read i))
- (definitions (read i)))
- (print-c-source f headers definitions package)))))
+++ /dev/null
-(defpackage "BSD-SOCKETS-INTERNAL"
- (:nicknames "SOCKINT")
- (:shadow close listen)
- #+cmu (:shadowing-import-from "CL" with-array-data)
- #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data)
-
- #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL")
- #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL"))
-
-;;; SBCL changes a lot of package prefixes. To avoid littering the
-;;; code with conditionals, we use the SBCL package prefixes
-;;; throughout. This means that we need to create said packages
-;;; first, if we're using CMUCL
-
-;;; One thing that this exercise really has made clear is just how much
-;;; of the alien stuff is scattered around the cmucl package space
-;;; seemingly at random. Hmm.
-
-#+cmu
-(eval-when (:compile-toplevel :load-toplevel)
- (defun add-package-nickname (name nickname)
- (let ((p (find-package name)))
- (rename-package p (package-name p)
- (cons nickname (package-nicknames name)))))
- (add-package-nickname "EXT" "SB-EXT")
- (add-package-nickname "ALIEN" "SB-ALIEN")
- (add-package-nickname "UNIX" "SB-UNIX")
- (add-package-nickname "C-CALL" "SB-C-CALL")
- (add-package-nickname "KERNEL" "SB-KERNEL")
- (add-package-nickname "SYSTEM" "SB-SYS"))
-
-(defpackage "BSD-SOCKETS"
- (:export socket unix-socket inet-socket
- make-unix-socket make-inet-socket
- socket-bind socket-accept socket-connect
- socket-send socket-receive socket-recv
- socket-name socket-peername socket-listen
- socket-close socket-file-descriptor socket-make-stream
- get-protocol-by-name
-
- get-host-by-name get-host-by-address
- host-ent
- host-ent-addresses host-ent-address
- host-ent aliases host-ent-name
- name-service-error
- ;; not sure if these are really good names or not
- netdb-internal-error
- netdb-success-error
- host-not-found-error
- try-again-error
- no-recovery-error
-
- ;; all socket options are also exported, by code in
- ;; sockopt.lisp
-
- bad-file-descriptor-error
- address-in-use-error
- interrupted-error
- invalid-argument-error
- out-of-memory-error
- operation-not-supported-error
- operation-not-permitted-error
- protocol-not-supported-error
- socket-type-not-supported-error
- network-unreachable-error
-
- make-inet-address
-
- non-blocking-mode
- )
- (:use "COMMON-LISP" "BSD-SOCKETS-INTERNAL")
- (:documentation
- "
-
-A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD
-socket API for C and Graham Barr's IO::Socket classes for Perl.
-
-We represent sockets as CLOS objects, and rename a lot of methods and
-arguments to fit Lisp style more closely.
-
-"
- ))
-
-#||
-
-<h2>Contents</h2>
-
-<ol>
-<li> General concepts
-<li> Methods applicable to all <a href="#socket">sockets</a>
-<li> <a href="#sockopt">Socket Options</a>
-<li> Methods applicable to a particular subclass
-<ol>
-<li> <a href="#internet">INET-SOCKET</a> - Internet Protocol (TCP, UDP, raw) sockets
-<li> Methods on <a href="#UNIX-SOCKET">UNIX-SOCKET</a> - Unix-domain sockets
-</ol>
-<li> <a href="#name-service">Name resolution</a> (DNS, /etc/hosts, &c)
-</ol>
-
-<h2>General concepts</h2>
-
-<p>Most of the functions are modelled on the BSD socket API. BSD sockets
-are widely supported, portably <i>("portable" by Unix standards, at least)</i>
-available on a variety of systems, and documented. There are some
-differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly
-
-<ul>
-<li> Where the C API would typically return -1 and set errno, bsd-sockets
-signals an error. All the errors are subclasses of SOCKET-CONDITION
-and generally correspond one for one with possible <tt>errno</tt> values
-
-<li> We use multiple return values in many places where the C API would use p[ass-by-reference values
-
-<li> We can often avoid supplying an explicit <i>length</i> argument to
-functions because we already know how long the argument is.
-
-<li> IP addresses and ports are represented in slightly friendlier fashion
-than "network-endian integers". See the section on <a href="#internet"
->Internet domain</a> sockets for details.
-</ul>
-
-
-|#
+++ /dev/null
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext )))
-(in-package :db-doc)
-;;; turn water into wine ^W^W^W lisp into HTML
-
-#|
-OK. We need a design
-
-1) The aim is to document the current package, given a system.
-2) The assumption is that the system is loaded; this makes it easier to
-do cross-references and stuff
-3) We output HTML on *standard-output*
-4) Hyperlink wherever useful
-5) We're allowed to intern symbols all over the place if we like
-
-|#
-
-;;; note: break badly on multiple packages
-
-
-(defvar *symbols* nil
- "List of external symbols to print; derived from parsing DEFPACKAGE form")
-
-
-(defun worth-documenting-p (symbol)
- (and symbol
- (eql (symbol-package symbol) *package*)
- (or (ignore-errors (find-class symbol))
- (boundp symbol) (fboundp symbol))))
-
-(defun linkable-symbol-p (word)
- (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
- (eql c #\-))))
- (and (every #'symbol-char word)
- (some #'upper-case-p word)
- (worth-documenting-p (find-symbol word)))))
-
-(defun markup-word (w)
- (if (symbolp w) (setf w (princ-to-string w)))
- (cond ((linkable-symbol-p w)
- (format nil "<a href=\"#~A\">~A</a>"
- w w))
- ((and (> (length w) 0)
- (eql (elt w 0) #\_)
- (eql (elt w (1- (length w))) #\_))
- (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
- (t w)))
-(defun markup-space (w)
- (let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
- (if para
- (format nil "~A<P>~A"
- (subseq w 0 (1+ para))
- (markup-space (subseq w (1+ para) nil)))
- w)))
-
-(defun text-markup (text)
- (let ((start-word 0) (end-word 0))
- (labels ((read-word ()
- (setf end-word
- (position-if
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start start-word))
- (subseq text start-word end-word))
- (read-space ()
- (setf start-word
- (position-if-not
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start end-word ))
- (subseq text end-word start-word)))
- (with-output-to-string (o)
- (loop for inword = (read-word)
- do (princ (markup-word inword) o)
- while (and start-word end-word)
- do (princ (markup-space (read-space)) o)
- while (and start-word end-word))))))
-
-
-(defun do-defpackage (form stream)
- (setf *symbols* nil)
- (destructuring-bind (defn name &rest options) form
- (when (string-equal name (package-name *package*))
- (format stream "<h1>Package ~A</h1>~%" name)
- (when (documentation *package* t)
- (princ (text-markup (documentation *package* t))))
- (let ((exports (assoc :export options)))
- (when exports
- (setf *symbols* (mapcar #'symbol-name (cdr exports)))))
- 1)))
-
-(defun do-defclass (form stream)
- (destructuring-bind (defn name super slots &rest options) form
- (when (interesting-name-p name)
- (let ((class (find-class name)))
- (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
- name name)
- #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
- (mapcar (lambda (x) (text-markup (class-name x)))
- (mop:class-direct-superclasses class)))
- (if (documentation class 'type)
- (format stream "<blockquote>~A</blockquote>~%"
- (text-markup (documentation class 'type))))
- (when slots
- (princ "<p><b>Slots:</b><ul>" stream)
- (dolist (slot slots)
- (destructuring-bind
- (name &key reader writer accessor initarg initform type
- documentation)
- (if (consp slot) slot (list slot))
- (format stream "<li>~A : ~A</li>~%" name
- (if documentation (text-markup documentation) ""))))
- (princ "</ul>" stream))
- t))))
-
-
-(defun interesting-name-p (name)
- (cond ((consp name)
- (and (eql (car name) 'setf)
- (interesting-name-p (cadr name))))
- (t (member (symbol-name name) *symbols* :test #'string=))))
-
-(defun markup-lambdalist (l)
- (let (key-p)
- (loop for i in l
- if (eq '&key i) do (setf key-p t)
- end
- if (and (not key-p) (consp i))
- collect (list (car i) (markup-word (cadr i)))
- else collect i)))
-
-(defun do-defunlike (form label stream)
- (destructuring-bind (defn name lambdalist &optional doc &rest code) form
- (when (interesting-name-p name)
- (when (symbolp name)
- (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
- (format stream "<p><a name=\"~A\"><table width=\"100%\"><tr><td width=\"80%\">(~A <i>~A</i>)</td><td align=right>~A</td></tr></table>~%"
- name (string-downcase (princ-to-string name))
- (string-downcase
- (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
- label)
- (if (stringp doc)
- (format stream "<blockquote>~A</blockquote>~%"
- (text-markup doc)))
- t)))
-
-(defun do-defun (form stream) (do-defunlike form "Function" stream))
-(defun do-defmethod (form stream) (do-defunlike form "Method" stream))
-(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream))
-(defun do-boolean-sockopt (form stream)
- (destructuring-bind (type lisp-name level c-name) form
- (pushnew (symbol-name lisp-name) *symbols*)
-
- (do-defunlike `(defun ,lisp-name ((socket socket) argument)
- ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
- "Accessor" stream)))
-
-(defun do-form (form output-stream)
- (cond ((not (listp form)) nil)
- ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
- (do-boolean-sockopt form output-stream))
- ((eq (car form) 'defclass)
- (do-defclass form output-stream))
- ((eq (car form) 'eval-when)
- (do-form (third form) output-stream))
- ((eq (car form) 'defpackage)
- (do-defpackage form output-stream))
- ((eq (car form) 'defun)
- (do-defun form output-stream))
- ((eq (car form) 'defmethod)
- (do-defmethod form output-stream))
- ((eq (car form) 'defgeneric)
- (do-defgeneric form output-stream))
- (t nil)))
-
-(defun do-file (input-stream output-stream)
- "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
- (let ((eof-marker (gensym)))
- (if (< 0
- (loop for form = (read input-stream nil eof-marker)
- until (eq form eof-marker)
- if (do-form form output-stream)
- count 1 #| and
- do (princ "<hr width=\"20%\">" output-stream) |# ))
- (format output-stream "<hr>"
- ))))
-
-(defvar *standard-sharpsign-reader*
- (get-dispatch-macro-character #\# #\|))
-
-(defun document-system (system &key
- (output-stream *standard-output*)
- (package *package*))
- "Produce HTML documentation for all files defined in SYSTEM, covering
-symbols exported from PACKAGE"
- (let ((*package* (find-package package))
- (*readtable* (copy-readtable))
- (*standard-output* output-stream))
- (set-dispatch-macro-character
- #\# #\|
- (lambda (s c n)
- (if (eql (peek-char nil s t nil t) #\|)
- (princ
- (text-markup
- (coerce
- (loop with discard = (read-char s t nil t)
- ;initially (princ "<P>")
- for c = (read-char s t nil t)
- until (and (eql c #\|)
- (eql (peek-char nil s t nil t) #\#))
- collect c
- finally (read-char s t nil t))
- 'string)))
- (funcall *standard-sharpsign-reader* s c n))))
- (dolist (c (cclan:all-components 'db-sockets))
- (when (and (typep c 'cl-source-file)
- (not (typep c 'db-sockets-system::constants-file)))
- (with-open-file (in (component-pathname c) :direction :input)
- (do-file in *standard-output*))))))
-
-(defun start ()
- (with-open-file (*standard-output* "index.html" :direction :output)
- (format t "<html><head><title>SBCL BSD-Sockets API Reference</title></head><body>~%")
- (asdf:operate 'asdf:load-op 'bsd-sockets)
- (document-system 'bsd-sockets :package :bsd-sockets)))
-
-(start)
+++ /dev/null
-(in-package :bsd-sockets-internal)
-
-;;;; Foreign function glue. This is the only file in the distribution
-;;;; that's _intended_ to be vendor-specific. The macros defined here
-;;;; are called from constants.lisp, which was generated from constants.ccon
-;;;; by the C compiler as driven by that wacky def-to-lisp thing.
-
-;;;; of course, the whole thing is vendor-specific actually, due to
-;;;; the way we use cmucl alien types in constants.ccon as a cheap way
-;;;; of transforming C-world alues into Lisp-world values. But if
-;;;; anyone were to port that bit to their preferred implementation, they
-;;;; wouldn't need to port all the rest of the cmucl alien interface at
-;;;; the same time
-
-;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
-;;; C-CALL:C-STRING) (BUF (* T)) )
-
-;;; I can't help thinking this was originally going to do something a
-;;; lot more complex
-(defmacro def-foreign-routine
- (&whole it (c-name lisp-name) return-type &rest args)
- (declare (ignorable c-name lisp-name return-type args))
- `(def-alien-routine ,@(cdr it)))
-#|
-(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
-(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
-|#
-;;; define-c-accessor makes us a setter and a getter for changing
-;;; memory at the appropriate offset
-
-;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
-
-(defmacro define-c-accessor (el structure type offset length)
- (declare (ignore structure))
- (let* ((ty (cond
- ((eql type 'integer) `(,type ,(* 8 length)))
- ((eql (car type) '*) `(unsigned ,(* 8 length)))
- ((eql type 'c-string) `(unsigned ,(* 8 length)))
- ((eql (car type) 'array) (cadr type))))
- (sap-ref-? (intern (format nil "~ASAP-REF-~A"
- (if (member (car ty) '(INTEGER SIGNED))
- "SIGNED-" "")
- (cadr ty))
- (find-package "SB-SYS"))))
- (labels ((template (before after)
- `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
- (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
- (,before (,sap-ref-? sap index) ,after))))
- `(progn
- ;;(declaim (inline ,el (setf ,el)))
- (defun ,el (ptr &optional (index 0))
- ,(template 'prog1 nil))
- (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
- (defun (setf ,el) (newval ptr &optional (index 0))
- ,(template 'setf 'newval))))))
-
-
-;;; make memory allocator for appropriately-sized block of memory, and
-;;; a constant to tell us how big it was anyway
-(defmacro define-c-struct (name size)
- (labels ((p (x) (intern (concatenate 'string x (symbol-name name)))))
- `(progn
- (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
- :element-type '(unsigned-byte 8)))
- (defconstant ,(p "SIZE-OF-") ,size)
- (defun ,(p "FREE-" ) (p) (declare (ignore p))))))
-
-(defun foreign-nullp (c)
- "C is a pointer to 0?"
- (= 0 (sb-sys:sap-int (sb-alien:alien-sap c))))
-
-;;; this could be a lot faster if I cared enough to think about it
-(defun foreign-vector (pointer size length)
- "Compose a vector of the words found in foreign memory starting at
-POINTER. Each word is SIZE bytes long; LENGTH gives the number of
-elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO"
- (assert (= size 1))
- (let ((ptr
- (typecase pointer
- (sb-sys:system-area-pointer
- (sap-alien pointer (* (sb-alien:unsigned 8))))
- (t
- (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
- (result (make-array length :element-type '(unsigned-byte 8))))
- (loop for i from 0 to (1- length) by size
- do (setf (aref result i) (sb-alien:deref ptr i)))
- ;;(format t "~S~%" result)
- result))
+++ /dev/null
-(in-package :bsd-sockets)
-
-#|| <h2>INET-domain sockets</h2>
-
-<p>The TCP and UDP sockets that you know and love. Some representation issues:
-<ul>
-<li>These functions do not accept hostnames directly: see <a href="#name-service">name resolution</a>
-<li>Internet <b>addresses</b> are represented by vectors of <tt>(unsigned-byte 8)</tt> - viz. <tt>#(127 0 0 1)</tt>. <b>Ports</b> are just integers: <tt>6010</tt>. No conversion between network- and host-order data is needed from the user of this package.
-<li><b><i>socket addresses</i></b> are represented by the two values for <b>address</b> and <b>port</b>, so for example, <tt>(<a href="#SOCKET-CONNECT">socket-connect</a> s #(192.168.1.1) 80)</tt>
-</ul>
-
-|#
-
-;;; Our class and constructor
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass inet-socket (socket)
- ((family :initform sockint::AF-INET))))
-
-;;; XXX should we *...* this?
-(defparameter inet-address-any (vector 0 0 0 0))
-
-;;; binding a socket to an address and port. Doubt that anyone's
-;;; actually using this much, to be honest.
-
-(defun make-inet-address (dotted-quads)
- "Return a vector of octets given a string DOTTED-QUADS in the format
-\"127.0.0.1\""
- (coerce
- (mapcar #'parse-integer
- (split dotted-quads nil '(#\.)))
- 'vector))
-
-;;; getprotobyname only works in the internet domain, which is why this
-;;; is here
-(defun get-protocol-by-name (name) ;exported
- "Returns the network protocol number associated with the string NAME,
-using getprotobyname(2) which typically looks in NIS or /etc/protocols"
- ;; for extra brownie points, could return canonical protocol name
- ;; and aliases as extra values
- (let ((ent (sockint::foreign-vector (sockint::getprotobyname name) 1
- sockint::size-of-protoent)))
- (sockint::protoent-proto ent)))
-
-
-;;; sockaddr protocol
-;;; (1) sockaddrs are represented as the semi-foreign array-of-octets
-;;; thing
-;;; (2) a protocol provides make-sockaddr-for, size-of-sockaddr,
-;;; bits-of-sockaddr
-
-(defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address)))
- (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
- (when (and host port)
- ;; port and host are represented in C as "network-endian" unsigned
- ;; integers of various lengths. This is stupid. The value of the
- ;; integer doesn't matter (and will change depending on your
- ;; machine's endianness); what the bind(2) call is interested in
- ;; is the pattern of bytes within that integer.
-
- ;; We have no truck with such dreadful type punning. Octets to
- ;; octets, dust to dust.
-
- (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
- (setf (sockint::sockaddr-in-port sockaddr 0) (ldb (byte 8 8) port))
- (setf (sockint::sockaddr-in-port sockaddr 1) (ldb (byte 8 0) port))
-
- (setf (sockint::sockaddr-in-addr sockaddr 0) (elt host 0))
- (setf (sockint::sockaddr-in-addr sockaddr 1) (elt host 1))
- (setf (sockint::sockaddr-in-addr sockaddr 2) (elt host 2))
- (setf (sockint::sockaddr-in-addr sockaddr 3) (elt host 3)))
- sockaddr))
-
-(defmethod size-of-sockaddr ((socket inet-socket))
- sockint::size-of-sockaddr-in)
-
-(defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
- "Returns address and port of SOCKADDR as multiple values"
- (values
- (vector
- (sockint::sockaddr-in-addr sockaddr 0)
- (sockint::sockaddr-in-addr sockaddr 1)
- (sockint::sockaddr-in-addr sockaddr 2)
- (sockint::sockaddr-in-addr sockaddr 3))
- (+ (* 256 (sockint::sockaddr-in-port sockaddr 0))
- (sockint::sockaddr-in-port sockaddr 1))))
-
-
-(defun make-inet-socket (type protocol)
- "Make an INET socket. Deprecated in favour of make-instance"
- (make-instance 'inet-socket :type type :protocol protocol))
-
-
-
+++ /dev/null
-(in-package :bsd-sockets-internal)
-
-(defun malloc (size)
- "Allocate foreign memory in some way that allows the garbage collector to free it later. Note that memory allocated this way does not count as `consed' for the purposes of deciding when to gc, so explicitly calling EXT:GC occasionally would be a good idea if you use it a lot"
- ;; we can attach finalizers to any object, and they'll be called on
- ;; the next gc after the object no longer has references. We can't
- ;; however make the finalizer close over the object, or it'll never
- ;; have no references. I experimentally determined that (sap-alien
- ;; (alien-sap f)) is not EQ to f, so we can do it that way
- (let* ((memory (make-alien (unsigned 8) size))
- (alias (sap-alien (alien-sap memory)
- (* (unsigned 8)))))
- (sb-ext:finalize memory
- (lambda ()
- (free-alien alias)))))
-
+++ /dev/null
-(in-package :bsd-sockets)
-
-;;; Miscellaneous things, placed here until I can find a logically more
-;;; coherent place to put them
-
-;;; I don't want to provide a complete interface to unix file
-;;; operations, for example, but being about to set O_NONBLOCK on a
-;;; socket is a necessary operation.
-
-;;; XXX bad (sizeof (int) ==4 ) assumptions
-
-(defmethod non-blocking-mode ((socket socket))
- "Is SOCKET in non-blocking mode?"
- (let ((fd (socket-file-descriptor socket)))
- (sb-alien:with-alien ((arg integer))
- (> (logand
- (sockint::fcntl fd sockint::f-getfl arg)
- sockint::o-nonblock)
- 0))))
-
-(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket))
- "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P"
- (declare (optimize (speed 3)))
- (let* ((fd (socket-file-descriptor socket))
- (arg1 (the (signed-byte 32) (sockint::fcntl fd sockint::f-getfl 0)))
- (arg2
- (if non-blocking-p
- (logior arg1 sockint::o-nonblock)
- (logand (lognot sockint::o-nonblock) arg1))))
- (when (= (the (signed-byte 32) -1)
- (the (signed-byte 32)
- (sockint::fcntl fd sockint::f-setfl arg2)))
- (socket-error "fcntl"))
- non-blocking-p))
-
-
+++ /dev/null
-(in-package :bsd-sockets)
-#|| <a name="name-service"><h2>Name Service</h2></a>
-
-<p>Presently name service is implemented by calling whatever
-gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS,
-or something completely different. Typically it's controlled by
-/etc/nsswitch.conf
-
-<p> Direct links to the asynchronous resolver(3) routines would be nice to have
-eventually, so that we can do DNS lookups in parallel with other things
-|#
-
-(defclass host-ent ()
- ((name :initarg :name :accessor host-ent-name)
- (aliases :initarg :aliases :accessor host-ent-aliases)
- (address-type :initarg :type :accessor host-ent-address-type)
- ; presently always AF_INET
- (addresses :initarg :addresses :accessor host-ent-addresses)))
-
-(defmethod host-ent-address ((host-ent host-ent))
- (car (host-ent-addresses host-ent)))
-
-;(define-condition host-not-found-error (socket-error)) ; host unknown
-;(define-condition no-address-error (socket-error)) ; valid name but no IP address
-;(define-condition no-recovery-error (socket-error)) ; name server error
-;(define-condition try-again-error (socket-error)) ; temporary
-
-(defun get-host-by-name (host-name)
- "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition.
-HOST-NAME may also be an IP address in dotted quad notation or some other
-weird stuff - see gethostbyname(3) for grisly details."
- (let ((h (sockint::gethostbyname host-name)))
- (make-host-ent h)))
-
-(defun get-host-by-address (address)
- "Returns a HOST-ENT instance for ADDRESS, which should be a vector of
-(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
-grisly details."
- (let ((packed-addr (sockint::allocate-in-addr)))
- (loop for i from 0 to 3
- do (setf (sockint::in-addr-addr packed-addr i) (elt address i)))
- (make-host-ent
- (sb-sys:without-gcing
- (sockint::gethostbyaddr (sockint::array-data-address packed-addr)
- 4
- sockint::af-inet)))))
-
-(defun make-host-ent (h)
- (if (sockint::foreign-nullp h) (name-service-error "gethostbyname"))
- (let* ((local-h (sockint::foreign-vector h 1 sockint::size-of-hostent))
- (length (sockint::hostent-length local-h))
- (aliases
- (loop for i = 0 then (1+ i)
- for al = (sb-sys:sap-ref-sap
- (sb-sys:int-sap (sockint::hostent-aliases local-h))
- (* i 4))
- until (= (sb-sys:sap-int al) 0)
- collect (sb-c-call::%naturalize-c-string al)))
- (address0 (sb-sys:sap-ref-sap (sb-sys:int-sap (sockint::hostent-addresses local-h)) 0))
- (addresses
- (loop for i = 0 then (+ length i)
- for ad = (sb-sys:sap-ref-32 address0 i)
- while (> ad 0)
- collect
- (sockint::foreign-vector (sb-sys:sap+ address0 i) 1 length))))
- (make-instance 'host-ent
- :name (sb-c-call::%naturalize-c-string
- (sb-sys:int-sap (sockint::hostent-name local-h)))
- :type (sockint::hostent-type local-h)
- :aliases aliases
- :addresses addresses)))
-
-;;; The remainder is my fault - gw
-
-(defvar *name-service-errno* 0
- "The value of h_errno, after it's been fetched from Unix-land by calling
-GET-NAME-SERVICE-ERRNO")
-
-(defun name-service-error (where)
- (get-name-service-errno)
- ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.".
- ;; This special case treatment hasn't actually been tested yet.
- (if (= *name-service-errno* sockint::NETDB-INTERNAL)
- (socket-error where)
- (let ((condition
- (condition-for-name-service-errno *name-service-errno*)))
- (error condition :errno *name-service-errno* :syscall where))))
-
-(define-condition name-service-error (condition)
- ((errno :initform nil
- :initarg :errno
- :reader name-service-error-errno)
- (symbol :initform nil :initarg :symbol :reader name-service-error-symbol)
- (syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall))
- (:report (lambda (c s)
- (let ((num (name-service-error-errno c)))
- (format s "Name service error in \"~A\": ~A (~A)"
- (name-service-error-syscall c)
- (or (name-service-error-symbol c)
- (name-service-error-errno c))
- (get-name-service-error-message num))))))
-
-(defmacro define-name-service-condition (symbol name)
- `(progn
- (define-condition ,name (name-service-error)
- ((symbol :reader name-service-error-symbol :initform (quote ,symbol))))
- (push (cons ,symbol (quote ,name)) *conditions-for-name-service-errno*)))
-
-(defparameter *conditions-for-name-service-errno* nil)
-
-(define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error)
-(define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error)
-(define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error)
-(define-name-service-condition sockint::TRY-AGAIN try-again-error)
-(define-name-service-condition sockint::NO-RECOVERY no-recovery-error)
-;; this is the same as the next one
-;;(define-name-service-condition sockint::NO-DATA no-data-error)
-(define-name-service-condition sockint::NO-ADDRESS no-address-error)
-
-(defun condition-for-name-service-errno (err)
- (or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql))
- 'name-service))
-
-
-
-(defun get-name-service-errno ()
- (setf *name-service-errno*
- (sb-alien:alien-funcall
- (sb-alien:extern-alien "get_h_errno" (function integer)))))
-
-#-solaris
-(progn
- #+sbcl
- (sb-alien:define-alien-routine "hstrerror"
- sb-c-call:c-string
- (errno integer))
- #+cmu
- (alien:def-alien-routine "hstrerror"
- sb-c-call:c-string
- (errno integer))
- (defun get-name-service-error-message (num)
- (hstrerror num))
-)
-
+++ /dev/null
-;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
-
-#|----------------------------------------------------------------------------|
- | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
- | |
- | Permission to use, copy, modify, and distribute this software and its |
- | documentation for any purpose and without fee is hereby granted, provided |
- | that this copyright and permission notice appear in all copies and |
- | supporting documentation, and that the name of M.I.T. not be used in |
- | advertising or publicity pertaining to distribution of the software |
- | without specific, written prior permission. M.I.T. makes no |
- | representations about the suitability of this software for any purpose. |
- | It is provided "as is" without express or implied warranty. |
- | |
- | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
- | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
- | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
- | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
- | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
- | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
- | SOFTWARE. |
- |----------------------------------------------------------------------------|#
-
-;This is the December 19, 1990 version of the regression tester.
-\f
-(defpackage "RT"
- (:use "COMMON-LISP")
- (:export deftest get-test do-test rem-test
- rem-all-tests do-tests pending-tests
- continue-testing *test*
- *do-tests-when-defined*))
-(in-package :rt)
-(defvar *test* nil "Current test name")
-(defvar *do-tests-when-defined* nil)
-(defvar *entries* '(nil) "Test database")
-(defvar *in-test* nil "Used by TEST")
-(defvar *debug* nil "For debugging")
-
-(defstruct (entry (:conc-name nil)
- (:type list))
- pend name form)
-
-(defmacro vals (entry) `(cdddr ,entry))
-
-(defmacro defn (entry) `(cdr ,entry))
-
-(defun pending-tests ()
- (do ((l (cdr *entries*) (cdr l))
- (r nil))
- ((null l) (nreverse r))
- (when (pend (car l))
- (push (name (car l)) r))))
-
-(defun rem-all-tests ()
- (setq *entries* (list nil))
- nil)
-
-(defun rem-test (&optional (name *test*))
- (do ((l *entries* (cdr l)))
- ((null (cdr l)) nil)
- (when (equal (name (cadr l)) name)
- (setf (cdr l) (cddr l))
- (return name))))
-\f
-(defun get-test (&optional (name *test*))
- (defn (get-entry name)))
-
-(defun get-entry (name)
- (let ((entry (find name (cdr *entries*)
- :key #'name
- :test #'equal)))
- (when (null entry)
- (report-error t
- "~%No test with name ~:@(~S~)."
- name))
- entry))
-
-(defmacro deftest (name form &rest values)
- `(add-entry '(t ,name ,form .,values)))
-
-(defun add-entry (entry)
- (setq entry (copy-list entry))
- (do ((l *entries* (cdr l))) (nil)
- (when (null (cdr l))
- (setf (cdr l) (list entry))
- (return nil))
- (when (equal (name (cadr l))
- (name entry))
- (setf (cadr l) entry)
- (report-error nil
- "Redefining test ~@:(~S~)"
- (name entry))
- (return nil)))
- (when *do-tests-when-defined*
- (do-entry entry))
- (setq *test* (name entry)))
-
-(defun report-error (error? &rest args)
- (cond (*debug*
- (apply #'format t args)
- (if error? (throw '*debug* nil)))
- (error? (apply #'error args))
- (t (apply #'warn args))))
-\f
-(defun do-test (&optional (name *test*))
- (do-entry (get-entry name)))
-
-(defun do-entry (entry &optional
- (s *standard-output*))
- (catch '*in-test*
- (setq *test* (name entry))
- (setf (pend entry) t)
- (let* ((*in-test* t)
- (*break-on-warnings* t)
- (r (multiple-value-list
- (eval (form entry)))))
- (setf (pend entry)
- (not (equal r (vals entry))))
- (when (pend entry)
- (format s "~&Test ~:@(~S~) failed~
- ~%Form: ~S~
- ~%Expected value~P: ~
- ~{~S~^~%~17t~}~
- ~%Actual value~P: ~
- ~{~S~^~%~15t~}.~%"
- *test* (form entry)
- (length (vals entry))
- (vals entry)
- (length r) r))))
- (when (not (pend entry)) *test*))
-
-(defun continue-testing ()
- (if *in-test*
- (throw '*in-test* nil)
- (do-entries *standard-output*)))
-\f
-(defun do-tests (&optional
- (out *standard-output*))
- (dolist (entry (cdr *entries*))
- (setf (pend entry) t))
- (if (streamp out)
- (do-entries out)
- (with-open-file
- (stream out :direction :output)
- (do-entries stream))))
-
-(defun do-entries (s)
- (format s "~&Doing ~A pending test~:P ~
- of ~A tests total.~%"
- (count t (cdr *entries*)
- :key #'pend)
- (length (cdr *entries*)))
- (dolist (entry (cdr *entries*))
- (when (pend entry)
- (format s "~@[~<~%~:; ~:@(~S~)~>~]"
- (do-entry entry s))))
- (let ((pending (pending-tests)))
- (if (null pending)
- (format s "~&No tests failed.")
- (format s "~&~A out of ~A ~
- total tests failed: ~
- ~:@(~{~<~% ~1:;~S~>~
- ~^, ~}~)."
- (length pending)
- (length (cdr *entries*))
- pending))
- (null pending)))
+++ /dev/null
-(in-package "BSD-SOCKETS")
-
-;;;; Methods, classes, functions for sockets. Protocol-specific stuff
-;;;; is deferred to inet.lisp, unix.lisp, etc
-
-#|| <h2>SOCKETs</h2>
-
-|#
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
-(defclass socket ()
- ((file-descriptor :initarg :descriptor
- :reader socket-file-descriptor)
- (family :initform (error "No socket family") :reader socket-family)
- (protocol :initarg :protocol :reader socket-protocol)
- (type :initarg :type :reader socket-type)
- (stream))))
-
-(defmethod print-object ((object socket) stream)
- (print-unreadable-object (object stream :type t :identity t)
- (princ "descriptor " stream)
- (princ (slot-value object 'file-descriptor) stream)))
-
-
-(defmethod shared-initialize :after ((socket socket) slot-names
- &key protocol type
- &allow-other-keys)
- (let* ((proto-num
- (cond ((and protocol (keywordp protocol))
- (get-protocol-by-name (string-downcase (symbol-name protocol))))
- (protocol protocol)
- (t 0)))
- (fd (or (and (slot-boundp socket 'file-descriptor)
- (socket-file-descriptor socket))
- (sockint::socket (socket-family socket)
- (ecase type
- ((:datagram) sockint::sock-dgram)
- ((:stream) sockint::sock-stream))
- proto-num))))
- (if (= fd -1) (socket-error "socket"))
- (setf (slot-value socket 'file-descriptor) fd
- (slot-value socket 'protocol) proto-num
- (slot-value socket 'type) type)
- (sb-ext:finalize socket (lambda () (sockint::close fd)))))
-
-\f
-
-;; we deliberately redesign the "bind" interface: instead of passing a
-;; sockaddr_something as second arg, we pass the elements of one as
-;; multiple arguments.
-
-(defgeneric socket-bind (socket &rest address))
-(defmethod socket-bind ((socket socket)
- &rest address)
- "Bind SOCKET to ADDRESS, which may vary according to socket family. For
-the INET family, pass ADDRESS and PORT as two arguments; for FILE address
-family sockets, pass the filename string. See also bind(2)"
- (let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
- (if (= (sb-sys:without-gcing
- (sockint::bind (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
- (socket-error "bind"))))
-
-\f
-(defmethod socket-accept ((socket socket))
- "Perform the accept(2) call, returning a newly-created connected socket
-and the peer address as multiple values"
- (let* ((sockaddr (make-sockaddr-for socket))
- (fd (sb-sys:without-gcing
- (sockint::accept (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))))
- (apply #'values
- (if (= fd -1)
- (socket-error "accept")
- (let ((s (make-instance (class-of socket)
- :type (socket-type socket)
- :protocol (socket-protocol socket)
- :descriptor fd)))
- (sb-ext:finalize s (lambda () (sockint::close fd)))))
- (multiple-value-list (bits-of-sockaddr socket sockaddr)))))
-
-(defgeneric socket-connect (socket &rest address))
-(defmethod socket-connect ((socket socket) &rest peer)
- "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value"
- (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
- (if (= (sb-sys:without-gcing
- (sockint::connect (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
- (socket-error "connect") )))
-
-(defmethod socket-peername ((socket socket))
- "Return the socket's peer; depending on the address family this may return multiple values"
- (let* ((sockaddr (make-sockaddr-for socket)))
- (when (= (sb-sys:without-gcing
- (sockint::getpeername (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
- (socket-error "getpeername"))
- (bits-of-sockaddr socket sockaddr)))
-
-(defmethod socket-name ((socket socket))
- "Return the address (as vector of bytes) and port that the socket is bound to, as multiple values"
- (let* ((sockaddr (make-sockaddr-for socket)))
- (when (= (sb-sys:without-gcing
- (sockint::getsockname (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
- (socket-error "getsockname"))
- (bits-of-sockaddr socket sockaddr)))
-
-
-;;; There are a whole bunch of interesting things you can do with a
-;;; socket that don't really map onto "do stream io", especially in
-;;; CL which has no portable concept of a "short read". socket-receive
-;;; allows us to read from an unconnected socket into a buffer, and
-;;; to learn who the sender of the packet was
-
-(defmethod socket-receive ((socket socket) buffer length
- &key
- oob peek waitall
- (element-type 'character))
- "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
-NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
-used, so at least one of these two arguments must be non-NIL. If
-BUFFER is supplied, it had better be of an element type one octet wide.
-Returns the buffer, its length, and the address of the peer
-that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
-so that the actual packet length is returned even if the buffer was too
-small"
- (let ((flags
- (logior (if oob sockint::MSG-OOB 0)
- (if peek sockint::MSG-PEEK 0)
- (if waitall sockint::MSG-WAITALL 0)
- sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
- (if (eql (socket-type socket) :datagram)
- sockint::msg-TRUNC 0)))
- (sockaddr (make-sockaddr-for socket)))
- (unless (or buffer length)
- (error "Must supply at least one of BUFFER or LENGTH"))
- (unless buffer
- (setf buffer (make-array length :element-type element-type)))
- (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
- (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
- (sb-sys:without-gcing
- (let ((len
- (sockint::recvfrom (socket-file-descriptor socket)
- (sockint::array-data-address buffer)
- (or length (length buffer))
- flags
- (sockint::array-data-address sockaddr)
- (sb-alien:cast sa-len (* integer)))))
- (when (= len -1) (socket-error "recvfrom"))
- (apply #'values buffer len (multiple-value-list
- (bits-of-sockaddr socket sockaddr))))))))
-
-
-
-(defmethod socket-listen ((socket socket) backlog)
- "Mark SOCKET as willing to accept incoming connections. BACKLOG
-defines the maximum length that the queue of pending connections may
-grow to before new connection attempts are refused. See also listen(2)"
- (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
- (if (= r -1)
- (socket-error "listen"))))
-
-(defmethod socket-close ((socket socket))
- "Close SOCKET. May throw any kind of error that write(2) would have
-thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
-stream instead"
- ;; the close(2) manual page has all kinds of warning about not
- ;; checking the return value of close, on the grounds that an
- ;; earlier write(2) might have returned successfully w/o actually
- ;; writing the stuff to disk. It then goes on to define the only
- ;; possible error return as EBADF (fd isn't a valid open file
- ;; descriptor). Presumably this is an oversight and we could also
- ;; get anything that write(2) would have given us.
-
- ;; What we do: we catch EBADF. It should only ever happen if
- ;; (a) someone's closed the socket already (stream closing seems
- ;; to have this effect) or (b) the caller is messing around with
- ;; socket internals. That's not supported, dude
-
- (if (slot-boundp socket 'stream)
- (close (slot-value socket 'stream)) ;; closes socket as well
- (handler-case
- (if (= (sockint::close (socket-file-descriptor socket)) -1)
- (socket-error "close"))
- (bad-file-descriptor-error (c) (declare (ignore c)) nil)
- (:no-error (c) (declare (ignore c)) nil))))
-
-(defmethod socket-make-stream ((socket socket) &rest args)
- "Find or create a STREAM that can be used for IO on SOCKET (which
-must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM."
- (let ((stream
- (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
- (unless stream
- (setf stream (apply #'sb-sys:make-fd-stream
- (socket-file-descriptor socket) args))
- (setf (slot-value socket 'stream) stream)
- (sb-ext:cancel-finalization socket))
- stream))
-
-\f
-
-;;; Error handling
-
-(define-condition socket-error (error)
- ((errno :initform nil
- :initarg :errno
- :reader socket-error-errno)
- (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
- (syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall))
- (:report (lambda (c s)
- (let ((num (socket-error-errno c)))
- (format s "Socket error in \"~A\": ~A (~A)"
- (socket-error-syscall c)
- (or (socket-error-symbol c) (socket-error-errno c))
- #+cmu (sb-unix:get-unix-error-msg num)
- #+sbcl (sb-int:strerror num))))))
-
-;;; watch out for slightly hacky symbol punning: we use both the value
-;;; and the symbol-name of sockint::efoo
-
-(defmacro define-socket-condition (symbol name)
- `(progn
- (define-condition ,name (socket-error)
- ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
- (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
-
-(defparameter *conditions-for-errno* nil)
-;;; this needs the rest of the list adding to it, really. They also
-;;; need
-;;; - conditions to be exported in the DEFPACKAGE form
-;;; - symbols to be added to constants.ccon
-;;; I haven't yet thought of a non-kludgey way of keeping all this in
-;;; the same place
-(define-socket-condition sockint::EADDRINUSE address-in-use-error)
-(define-socket-condition sockint::EAGAIN interrupted-error)
-(define-socket-condition sockint::EBADF bad-file-descriptor-error)
-(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
-(define-socket-condition sockint::EINTR interrupted-error)
-(define-socket-condition sockint::EINVAL invalid-argument-error)
-(define-socket-condition sockint::ENOBUFS no-buffers-error)
-(define-socket-condition sockint::ENOMEM out-of-memory-error)
-(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
-(define-socket-condition sockint::EPERM operation-not-permitted-error)
-(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
-(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
-(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
-
-
-(defun condition-for-errno (err)
- (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
-
-#+cmu
-(defun socket-error (where)
- ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
- ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
- ;; to update the value that unix-errno looks at. On other CMUCL
- ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
- (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
- (let ((condition (condition-for-errno sb-unix:unix-errno)))
- (error condition :errno sb-unix:unix-errno :syscall where)))
-
-#+sbcl
-(defun socket-error (where)
- (let* ((errno (sb-unix::get-errno))
- (condition (condition-for-errno errno)))
- (error condition :errno errno :syscall where)))
-
-
-
+++ /dev/null
-(in-package :bsd-sockets)
-
-#||
-<H2> Socket Options </h2>
-<a name="sockopt"> </a>
-<p> A subset of socket options are supported, using a fairly
-general framework which should make it simple to add more as required
-- see sockopt.lisp for details. The name mapping from C is fairly
-straightforward: <tt>SO_RCVLOWAT</tt> becomes
-<tt>sockopt-receive-low-water</tt> and <tt>(setf
-sockopt-receive-low-water)</tt>.
-||#
-
-#|
-getsockopt(socket, level, int optname, void *optval, socklen_t *optlen)
-setsockopt(socket, level, int optname, void *optval, socklen_t optlen)
- ^ SOL_SOCKET or a protocol number
-
-In terms of providing a useful interface, we have to face up to the
-fact that most of these take different data types - some are integers,
-some are booleans, some are foreign struct instances, etc etc
-
-(define-socket-option lisp-name level number mangle-arg size mangle-return)
-
-macro-expands to two functions that define lisp-name and (setf ,lisp-name)
-and calls the functions mangle-arg and mangle-return on outgoing and incoming
-data resp.
-
-Parameters passed to the function thus defined (lisp-name)
-are all passed directly into mangle-arg. mangle-arg should return an
-alien pointer - this is passed unscathed to the foreign routine, so
-wants to have type (* t). Note that even for options that have
-integer arguments, this is still a pointer to said integer.
-
-size is the size of the buffer that the return of mangle-arg points
-to, and also of the buffer that we should allocate for getsockopt
-to write into.
-
-mangle-return is called with an alien buffer and should turn it into
-something that the caller will want.
-
-Code for options that not every system has should be conditionalised:
-
-(if (boundp 'sockint::IP_RECVIF)
- (define-socket-option so-receive-interface (getprotobyname "ip")
- sockint::IP_RECVIF ... ))
-
-
-|#
-
-(defmacro define-socket-option
- (lisp-name level number mangle-arg size mangle-return)
- (let ((find-level
- (if (numberp (eval level))
- level
- `(get-protocol-by-name ,(string-downcase (symbol-name level))))))
- `(progn
- (export ',lisp-name)
- (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket)))
- (sb-sys:without-gcing
- (let ((buf (make-array sockint::size-of-int
- :element-type '(unsigned-byte 8)
- :initial-element 0)))
- (if (= -1 (sockint::getsockopt
- fd ,find-level ,number (sockint::array-data-address buf) ,size))
- (socket-error "getsockopt")
- (,mangle-return buf ,size)))))
- (defun (setf ,lisp-name) (new-val socket
- &aux (fd (socket-file-descriptor socket)))
- (if (= -1
- (sb-sys:without-gcing
- (sockint::setsockopt
- fd ,find-level ,number (funcall (function ,mangle-arg) new-val ,size)
- ,size)))
- (socket-error "setsockopt"))))))
-
-;;; sockopts that have integer arguments
-
-(defun int-to-foreign (x size)
- ;; can't use with-alien, as the variables it creates only have
- ;; dynamic scope. can't use the passed-in size because sap-alien
- ;; is a macro and evaluates its second arg at read time
- (let* ((v (make-array size :element-type '(unsigned-byte 8)
- :initial-element 0))
- (d (sockint::array-data-address v))
- (alien (sb-alien:sap-alien
- d; (sb-sys:int-sap d)
- (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
- (setf (sb-alien:deref alien 0) x)
- alien))
-
-(defun buffer-to-int (x size)
- (declare (ignore size))
- (let ((alien (sb-alien:sap-alien
- (sockint::array-data-address x)
- (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
- (sb-alien:deref alien)))
-
-(defmacro define-socket-option-int (name level number)
- `(define-socket-option ,name ,level ,number
- int-to-foreign sockint::size-of-int buffer-to-int))
-
-(define-socket-option-int
- sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
-(define-socket-option-int
- sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat)
-(define-socket-option-int
- sockopt-type sockint::sol-socket sockint::so-type)
-(define-socket-option-int
- sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
-(define-socket-option-int
- sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
-(define-socket-option-int
- sockopt-priority sockint::sol-socket sockint::so-priority)
-
-;;; boolean options are integers really
-
-(defun bool-to-foreign (x size)
- (int-to-foreign (if x 1 0) size))
-
-(defun buffer-to-bool (x size)
- (not (= (buffer-to-int x size) 0)))
-
-(defmacro define-socket-option-bool (name level number)
- `(define-socket-option ,name ,level ,number
- bool-to-foreign sockint::size-of-int buffer-to-bool))
-
-(define-socket-option-bool
- sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
-(define-socket-option-bool
- sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
-(define-socket-option-bool
- sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
-(define-socket-option-bool
- sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat)
-(define-socket-option-bool
- sockopt-pass-credentials sockint::sol-socket sockint::so-passcred)
-(define-socket-option-bool
- sockopt-debug sockint::sol-socket sockint::so-debug)
-(define-socket-option-bool
- sockopt-dont-route sockint::sol-socket sockint::so-dontroute)
-(define-socket-option-bool
- sockopt-broadcast sockint::sol-socket sockint::so-broadcast)
-
-(define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay)
-
-(defun string-to-foreign (string size)
- (declare (ignore size))
- (let ((data (sockint::array-data-address string)))
- (sb-alien:sap-alien data (* t))))
-
-(defun buffer-to-string (x size)
- (declare (ignore size))
- (sb-c-call::%naturalize-c-string
- (sockint::array-data-address x)))
-
-(define-socket-option sockopt-bind-to-device sockint::sol-socket
- sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz
- buffer-to-string)
-
-;;; other kinds of socket option
-
-;;; so_peercred takes a ucre structure
-;;; so_linger struct linger {
-; int l_onoff; /* linger active */
-; int l_linger; /* how many seconds to linger for */
-; };
-
-#|
-
-(sockopt-reuse-address 2)
-
-(defun echo-server ()
- (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp"))))
- (setf (sockopt-reuse-address s) t)
- (setf (sockopt-bind-to-device s) "lo")
- (socket-bind s (make-inet-address "127.0.0.1") 3459)
- (socket-listen s 5)
- (dotimes (i 10)
- (let* ((s1 (socket-accept s))
- (stream (socket-make-stream s1 :input t :output t :buffering :none)))
- (let ((line (read-line stream)))
- (format t "got one ~A ~%" line)
- (format stream "~A~%" line))
- (close stream)))))
-
-NIL
-|#
-
+++ /dev/null
-(in-package :bsd-sockets)
-
-;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100
-;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de>
-
-(defun split (string &optional max (ws '(#\Space #\Tab)))
- "Split `string' along whitespace as defined by the sequence `ws'.
-The whitespace is elided from the result. The whole string will be
-split, unless `max' is a non-negative integer, in which case the
-string will be split into `max' tokens at most, the last one
-containing the whole rest of the given `string', if any."
- (flet ((is-ws (char) (find char ws)))
- (loop for start = (position-if-not #'is-ws string)
- then (position-if-not #'is-ws string :start index)
- for index = (and start
- (if (and max (= (1+ word-count) max))
- nil
- (position-if #'is-ws string :start start)))
- while start
- collect (subseq string start index)
- count 1 into word-count
- while index)))
-
+++ /dev/null
-(defpackage "BSD-SOCKETS-TEST"
- (:use "CL" "BSD-SOCKETS" "RT"))
-
-#||
-
-<H1>Tests</h1>
-
-There should be at least one test for pretty much everything you can do
-with the package. In some places I've been more diligent than others; more
-tests gratefully accepted.
-
-Tests are in the file <tt>tests.lisp</tt> and also make good examples.
-
-||#
-
-(in-package :bsd-sockets-test)
-
-;;; a real address
-(deftest make-inet-address
- (equalp (make-inet-address "127.0.0.1") #(127 0 0 1))
- t)
-;;; and an address with bit 8 set on some octets
-(deftest make-inet-address2
- (equalp (make-inet-address "242.1.211.3") #(242 1 211 3))
- t)
-
-(deftest make-inet-socket
- ;; make a socket
- (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
- (and (> (socket-file-descriptor s) 1) t))
- t)
-
-(deftest make-inet-socket-keyword
- ;; make a socket
- (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
- (and (> (socket-file-descriptor s) 1) t))
- t)
-
-(deftest make-inet-socket-wrong
- ;; fail to make a socket: check correct error return. There's no nice
- ;; way to check the condition stuff on its own, which is a shame
- (handler-case
- (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp"))
- ((or socket-type-not-supported-error protocol-not-supported-error) (c)
- (declare (ignorable c)) t)
- (:no-error nil))
- t)
-
-(deftest make-inet-socket-keyword-wrong
- ;; same again with keywords
- (handler-case
- (make-instance 'inet-socket :type :stream :protocol :udp)
- ((or protocol-not-supported-error socket-type-not-supported-error) (c)
- (declare (ignorable c)) t)
- (:no-error nil))
- t)
-
-
-(deftest non-block-socket
- (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
- (setf (non-blocking-mode s) t)
- (non-blocking-mode s))
- t)
-
-(defun do-gc-portably ()
- ;; cmucl on linux has generational gc with a keyword argument,
- ;; sbcl GC function takes same arguments no matter what collector is in
- ;; use
- #+(or sbcl gencgc) (SB-EXT:gc :full t)
- ;; other platforms have full gc or nothing
- #-(or sbcl gencgc) (sb-ext:gc))
-
-(deftest inet-socket-bind
- (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
- ;; Given the functions we've got so far, if you can think of a
- ;; better way to make sure the bind succeeded than trying it
- ;; twice, let me know
- ;; 1974 has no special significance, unless you're the same age as me
- (do-gc-portably) ;gc should clear out any old sockets bound to this port
- (socket-bind s (make-inet-address "127.0.0.1") 1974)
- (handler-case
- (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
- (socket-bind s2 (make-inet-address "127.0.0.1") 1974)
- nil)
- (address-in-use-error () t)))
- t)
-
-(deftest simple-sockopt-test
- ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in
- ;; the process that all the weird macros in sockopt happened right.
- (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
- (setf (sockopt-reuse-address s) t)
- (sockopt-reuse-address s))
- t)
-
-(defun read-buf-nonblock (buffer stream)
- "Like READ-SEQUENCE, but returns early if the full quantity of data isn't there to be read. Blocks if no input at all"
- (let ((eof (gensym)))
- (do ((i 0 (1+ i))
- (c (read-char stream nil eof)
- (read-char-no-hang stream nil eof)))
- ((or (>= i (length buffer)) (not c) (eq c eof)) i)
- (setf (elt buffer i) c))))
-
-;;; these require that the echo services are turned on in inetd
-
-(deftest simple-tcp-client
- (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
- (data (make-string 200)))
- (socket-connect s #(127 0 0 1) 7)
- (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
- (format stream "here is some text")
- (let ((data (subseq data 0 (read-buf-nonblock data stream))))
- (format t "~&Got ~S back from TCP echo server~%" data)
- (> (length data) 0))))
- t)
-
-(deftest simple-udp-client
- (let ((s (make-instance 'inet-socket :type :datagram :protocol (get-protocol-by-name "udp")))
- (data (make-string 200)))
- (format t "Socket type is ~A~%" (sockopt-type s))
- (socket-connect s #(127 0 0 1) 7)
- (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
- (format stream "here is some text")
- (let ((data (subseq data 0 (read-buf-nonblock data stream))))
- (format t "~&Got ~S back from UDP echo server~%" data)
- (> (length data) 0))))
- t)
-
-#||
-<h2>Unix-domain sockets</h2>
-
-A fairly rudimentary test that connects to the syslog socket and sends a
-message. Priority 7 is kern.debug; you'll probably want to look at
-/etc/syslog.conf or local equivalent to find out where the message ended up
-||#
-
-(deftest simple-unix-client
- (let ((s (make-instance 'unix-socket :type :datagram)))
- (format t "~A~%" s)
- (socket-connect s "/dev/log")
- (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
- (format stream
- "<7>bsd-sockets: Don't panic. We're testing unix-domain client code; this message can safely be ignored")
- t))
- t)
-
-
-;;; these require that the internet (or bits of it, atleast) is available
-
-(deftest get-host-by-name
- (equalp (car (host-ent-addresses (get-host-by-name "a.root-servers.net")))
- #(198 41 0 4))
- t)
-
-(deftest get-host-by-address
- (host-ent-name (get-host-by-address #(198 41 0 4)))
- "a.root-servers.net")
-
-(deftest get-host-by-name-wrong
- (handler-case
- (get-host-by-name "foo.tninkpad.telent.net")
- (NAME-SERVICE-ERROR () t)
- (:no-error nil))
- t)
-
-(defun http-stream (host port request)
- (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
- (socket-connect
- s (car (host-ent-addresses (get-host-by-name host))) port)
- (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
- (format stream "~A HTTP/1.0~%~%" request))
- s))
-
-(deftest simple-http-client-1
- (handler-case
- (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
- (let ((data (make-string 200)))
- (setf data (subseq data 0
- (read-buf-nonblock data
- (socket-make-stream s))))
- (princ data)
- (> (length data) 0)))
- (network-unreachable-error () 'network-unreachable))
- t)
-
-
-(deftest sockopt-receive-buffer
- ;; on Linux x86, the receive buffer size appears to be doubled in the
- ;; kernel: we set a size of x and then getsockopt() returns 2x.
- ;; This is why we compare with >= instead of =
- (handler-case
- (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
- (setf (sockopt-receive-buffer s) 1975)
- (let ((data (make-string 200)))
- (setf data (subseq data 0
- (read-buf-nonblock data
- (socket-make-stream s))))
- (and (> (length data) 0)
- (>= (sockopt-receive-buffer s) 1975))))
- (network-unreachable-error () 'network-unreachable))
- t)
-
-
-;;; we don't have an automatic test for some of this yet. There's no
-;;; simple way to run servers and have something automatically connect
-;;; to them as client, unless we spawn external programs. Then we
-;;; have to start telling people what external programs they should
-;;; have installed. Which, eventually, we will, but not just yet
-
-
-;;; to check with this: can display packets from multiple peers
-;;; peer address is shown correctly for each packet
-;;; packet length is correct
-;;; long (>500 byte) packets have the full length shown (doesn't work)
-
-(defun udp-server (port)
- (let ((s (make-instance 'inet-socket :type :datagram :protocol :udp)))
- (socket-bind s #(0 0 0 0) port)
- (loop
- (multiple-value-bind (buf len address port) (socket-receive s nil 500)
- (format t "Received ~A bytes from ~A:~A - ~A ~%"
- len address port (subseq buf 0 (min 10 len)))))))
-
-
+++ /dev/null
-(in-package :bsd-sockets)
-
-#|| <h2>File-domain sockets</h2>
-
-File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were
-renamed by POSIX presumably on the basis that they may be
-available on other systems too.
-
-A file-domain socket address is a string, which is used to create a node
-in the local filesystem. This means of course that they cannot be used across
-a network.
-
-||#
-
-(defclass unix-socket (socket)
- ((family :initform sockint::af-unix)))
-
-(defmethod make-sockaddr-for ((socket unix-socket) &optional sockaddr &rest address &aux (filename (first address)))
- (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un))))
- (setf (sockint::sockaddr-un-family sockaddr) sockint::af-unix)
- (when filename
- (loop for c across filename
- ;; XXX magic constant ew ew ew. should grovel this from
- ;; system headers
- for i from 0 to (min 107 (1- (length filename)))
- do (setf (sockint::sockaddr-un-path sockaddr i) (char-code c))
- finally
- (setf (sockint::sockaddr-un-path sockaddr (1+ i)) 0)))
- sockaddr))
-
-(defmethod size-of-sockaddr ((socket unix-socket))
- sockint::size-of-sockaddr-un)
-
-(defmethod bits-of-sockaddr ((socket unix-socket) sockaddr)
- "Returns filename of SOCKADDR"
- (let ((name (sb-c-call::%naturalize-c-string
- (sb-sys:sap+ (sockint::array-data-address sockaddr)
- sockint::offset-of-sockaddr-un-path))))
- (if (zerop (length name)) nil name)))
-
projects / sbcl.git / commitdiff