* REQUIRE and PROVIDE are now optionally capable of doing something
useful: see the documentation string for REQUIRE
* infrastructure for a managed SBCL contrib system: contributed
- modules in this release include a copy of the ASDF system definition
- facility, and an interface to the BSD Sockets API
+ modules in this release include
+ - the ASDF system definition facility
+ - an interface to the BSD Sockets API
+ - an ACL-like convenience interface to the repl
+ (thanks to Kevin Rosenberg)
planned incompatible changes in 0.7.x:
* (not done yet, but planned:) When the profiling interface settles
to use ASDF to build it and load it. A version of asdf is bundled as
an SBCL contrib, which knows to look in $SBCL_HOME/systems/ for asd
files - your install target should create an appropriate symlink there
-to the installed location of the system file. Look in bsd-sockets/Makefile
+to the installed location of the system file. Look in sb-bsd-sockets/Makefile
for an example of an asdf-using contrib
$(INSTALL_DIR) will have been created by the system before your
well-endowed-with-free-stuff Unix systems are discouraged. DocBook
is fine, as the SBCL manual is DocBook anyway ]
-[ install.sh should copy the documentation somewhere that the user can
-find it ]
+[ make install should copy the documentation somewhere that the user
+can find it ]
* Lisp-level requirements
-An sbcl contrib should not stamp on sbcl internals or redefine symbols
-in CL, CL-USER. Sometimes this is the only way to do something,
-though: individual cases will be considered on their merits. A
-package that hacks undocumented(sic) interfaces may be accepted for
-contrib, but it does not follow from that that the interface is now
-published or will be preserved in future SBCL versions - contrib
-authors are encouraged instead to submit patches to SBCL that provide
-clean documented APIs which reasonably can be preserved. If in doubt,
-seek consensus on the sbcl-devel list
+An sbcl contrib should attempt to avoid stamping on sbcl internals or
+redefining symbols in CL, CL-USER. Sometimes this is the only way to do
+something, though: individual cases will be considered on their
+merits. A package that hacks undocumented(sic) interfaces may be
+accepted for contrib, but it does not follow from that that the
+interface is now published or will be preserved in future SBCL
+versions - contrib authors are encouraged instead to submit patches to
+SBCL that provide clean documented APIs which reasonably can be
+preserved. If in doubt, seek consensus on the sbcl-devel list
A contrib must load into its own Lisp package(s) instead of polluting
CL-USER or one of the system packages. The Lisp package name should
-be chosen in some way that has reasonable expectation of being unique.
-[We could potentially keep a registry of contrib archive name =>
-package name(s)]
-
-
+begin with "SB-". Ask the sbcl-devel list for a suitable name.
-asdf.fasl: asdf.lisp
- $(SBCL) --eval '(compile-file "asdf")' </dev/null
+MODULE=asdf
+include ../vanilla-module.mk
-test:
+test::
true
-
-install: asdf.fasl
- cp $< $(INSTALL_DIR)
--- /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 -*-
+
+;;; 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 :SB-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 "SB-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 "SB-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" "SB-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 'sb-bsd-sockets)
+ (document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))
+
+(start)
--- /dev/null
+(in-package :sb-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 :sb-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 :sb-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 :sb-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 :sb-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
+;;; -*- Lisp -*-
+
+(defpackage #:sb-bsd-sockets-system (:use #:asdf #:cl))
+(in-package #:sb-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
+(in-package "SB-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 :sb-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 :sb-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 "SB-BSD-SOCKETS-TEST"
+ (:use "CL" "SB-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 :sb-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 :sb-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)))
+
--- /dev/null
+
+$(MODULE).fasl: $(MODULE).lisp
+ $(SBCL) --eval '(compile-file "$(MODULE)")' </dev/null
+
+test:: $(MODULE).fasl
+
+install: test
+ cp $(MODULE).fasl $(INSTALL_DIR)
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# probably want to run it by itself is if you're trying to
+# cross-compile the system or if you're doing some kind of
+# troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+SBCL="`pwd`/src/runtime/sbcl --noinform --core `pwd`/output/sbcl.core --userinit /dev/null --sysinit /dev/null --disable-debugger"
+SBCL_BUILDING_CONTRIB=1
+export SBCL SBCL_BUILDING_CONTRIB
+for i in contrib/*; do
+ test -d $i || continue;
+ # export INSTALL_DIR=$SBCL_HOME/`basename $i `
+ make -C $i test
+done
# SBCL_XC_HOST=<whatever> sh make-host-2.sh
# Copy output/cold-sbcl.core from the host system to the target system.
# On the target system:
-# sh make-host-2.sh
+# sh make-target-2.sh
+# sh make-target-contrib.sh
# Or, if you can set up the files somewhere shared (with NFS, AFS, or
# whatever) between the host machine and the target machine, the basic
# procedure above should still work, but you can skip the "copy" steps.
sh make-target-1.sh || exit 1
sh make-host-2.sh || exit 1
sh make-target-2.sh || exit 1
+sh make-target-contrib.sh || exit 1
date
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.12.27"
+"0.7.12.28"
projects / sbcl.git / commitdiff