From: Daniel Barlow Date: Fri, 7 Feb 2003 17:11:38 +0000 (+0000) Subject: 0.7.12.28 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=10d2c05ea44ca0837091434fe2223c0c31687615;p=sbcl.git 0.7.12.28 Added WHN's port of Kevin Rosenberg's ACL-like toplevel as the contrib package SB-ACLREPL Tidied up some of the contrib infrastructure in pursuance of OAOO Renamefest: adopt standard SB- package prefixes for all contribs Contrib packages are now built by make-target-contrib.sh (called from make.sh) instead of being left to install.sh time --- diff --git a/NEWS b/NEWS index 37303aa..66ca016 100644 --- a/NEWS +++ b/NEWS @@ -1549,8 +1549,11 @@ changes in sbcl-0.7.13 relative to sbcl-0.7.12: * 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 diff --git a/contrib/STANDARDS b/contrib/STANDARDS index f5b9598..f344dc5 100644 --- a/contrib/STANDARDS +++ b/contrib/STANDARDS @@ -56,7 +56,7 @@ If the contrib package involves more than one file, you are encouraged 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 @@ -77,25 +77,21 @@ of the preceding. Document formats not available on typical 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. diff --git a/contrib/asdf/Makefile b/contrib/asdf/Makefile index 3067de6..caa7300 100644 --- a/contrib/asdf/Makefile +++ b/contrib/asdf/Makefile @@ -1,8 +1,5 @@ -asdf.fasl: asdf.lisp - $(SBCL) --eval '(compile-file "asdf")' , but please check the CVS version first. + +$Id$ diff --git a/contrib/sb-bsd-sockets/TODO b/contrib/sb-bsd-sockets/TODO new file mode 100644 index 0000000..90c82a3 --- /dev/null +++ b/contrib/sb-bsd-sockets/TODO @@ -0,0 +1,20 @@ + +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. diff --git a/contrib/sb-bsd-sockets/alien/get-h-errno.c b/contrib/sb-bsd-sockets/alien/get-h-errno.c new file mode 100755 index 0000000..a1d22a6 --- /dev/null +++ b/contrib/sb-bsd-sockets/alien/get-h-errno.c @@ -0,0 +1,6 @@ +#include + +int get_h_errno() +{ + return h_errno; +} diff --git a/contrib/sb-bsd-sockets/alien/undefs.c b/contrib/sb-bsd-sockets/alien/undefs.c new file mode 100644 index 0000000..fca6cde --- /dev/null +++ b/contrib/sb-bsd-sockets/alien/undefs.c @@ -0,0 +1,9 @@ +/* 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(); +} + diff --git a/contrib/sb-bsd-sockets/api-reference.html b/contrib/sb-bsd-sockets/api-reference.html new file mode 100644 index 0000000..09e3f04 --- /dev/null +++ b/contrib/sb-bsd-sockets/api-reference.html @@ -0,0 +1,188 @@ +db-sockets API Reference +

Package SOCKETS

+ +

+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. +

+ +

+

Contents

+

+

    +
  1. General concepts +
  2. Methods applicable to all sockets +
  3. Socket Options +
  4. Methods applicable to a particular subclass +
      +
    1. INET-SOCKET - Internet Protocol (TCP, UDP, raw) sockets +
    2. Methods on UNIX-SOCKET - Unix-domain sockets +
    +
  5. Name resolution (DNS, /etc/hosts, &c) +
+

+

General concepts

+

+

Most of the functions are modelled on the BSD socket API. BSD sockets +are widely supported, portably (well, fairly portably) +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 +

+

+

+

+

SOCKETs

+

+

Class: SOCKET +

Slots:

(socket-bind (s socket) &rest address)Generic Function
+

(socket-accept (socket socket))Method
+

Perform the accept(2) call, returning a newly-created connected socket +and the peer address as multiple values
+

(socket-connect (s socket) &rest address)Generic Function
+

(socket-peername (socket socket))Method
+

Return the socket's peer; depending on the address family this may return multiple values
+

(socket-name (socket socket))Method
+

Return the address (as vector of bytes) and port that the socket is bound to, as multiple values
+

(socket-receive (socket socket) buffer length &key oob peek waitall (element-type + 'character))Method
+

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
+

(socket-listen (socket socket) backlog)Method
+

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)
+

(socket-close (socket socket))Method
+

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
+

(socket-make-stream (socket socket) &rest args)Method
+

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.
+
+

Socket Options

+ +

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: SO_RCVLOWAT becomes +sockopt-receive-low-water and (setf +sockopt-receive-low-water). +|

(sockopt-reuse-address (socket socket) argument)Accessor
+

Return the value of the SO-REUSEADDR socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-keep-alive (socket socket) argument)Accessor
+

Return the value of the SO-KEEPALIVE socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-oob-inline (socket socket) argument)Accessor
+

Return the value of the SO-OOBINLINE socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-bsd-compatible (socket socket) argument)Accessor
+

Return the value of the SO-BSDCOMPAT socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-pass-credentials (socket socket) argument)Accessor
+

Return the value of the SO-PASSCRED socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-debug (socket socket) argument)Accessor
+

Return the value of the SO-DEBUG socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-dont-route (socket socket) argument)Accessor
+

Return the value of the SO-DONTROUTE socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-broadcast (socket socket) argument)Accessor
+

Return the value of the SO-BROADCAST socket option for SOCKET. This can also be updated with SETF.
+

(sockopt-tcp-nodelay (socket socket) argument)Accessor
+

Return the value of the TCP-NODELAY socket option for SOCKET. This can also be updated with SETF.
+

INET-domain sockets

+

+

The TCP and UDP sockets that you know and love. Some representation issues: +

+

+

Class: INET-SOCKET +

Slots:

(make-inet-address dotted-quads)Function
+

Return a vector of octets given a string DOTTED-QUADS in the format +"127.0.0.1"
+

(get-protocol-by-name name)Function
+

Returns the network protocol number associated with the string NAME, +using getprotobyname(2) which typically looks in NIS or /etc/protocols
+

(make-inet-socket type protocol)Function
+

Make an INET socket. Deprecated in favour of make-instance
+

File-domain sockets

+

+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. +

+|

Class: UNIX-SOCKET +

Slots:

Name Service

 +

+

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 +

+

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 +

Class: HOST-ENT +

Slots:

(host-ent-address (host-ent host-ent))Method
+

(get-host-by-name host-name)Function
+

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.
+

(get-host-by-address address)Function
+

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.
+

(name-service-error where)Function
+

(non-blocking-mode (socket socket))Method
+

Is SOCKET in non-blocking mode?
+
+

+

Tests

+

+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 tests.lisp and also make good examples. +

+| +

Unix-domain sockets

+

+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 diff --git a/contrib/sb-bsd-sockets/array-data.lisp b/contrib/sb-bsd-sockets/array-data.lisp new file mode 100644 index 0000000..8a53daa --- /dev/null +++ b/contrib/sb-bsd-sockets/array-data.lisp @@ -0,0 +1,72 @@ +(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)))))))) + + + diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp new file mode 100644 index 0000000..e792888 --- /dev/null +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -0,0 +1,189 @@ +;;; -*- 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)))) +) diff --git a/contrib/sb-bsd-sockets/def-to-lisp.lisp b/contrib/sb-bsd-sockets/def-to-lisp.lisp new file mode 100644 index 0000000..7940126 --- /dev/null +++ b/contrib/sb-bsd-sockets/def-to-lisp.lisp @@ -0,0 +1,70 @@ +(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))))) diff --git a/contrib/sb-bsd-sockets/defpackage.lisp b/contrib/sb-bsd-sockets/defpackage.lisp new file mode 100644 index 0000000..58e5270 --- /dev/null +++ b/contrib/sb-bsd-sockets/defpackage.lisp @@ -0,0 +1,123 @@ +(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. + +" + )) + +#|| + +

Contents

+ +
    +
  1. General concepts +
  2. Methods applicable to all sockets +
  3. Socket Options +
  4. Methods applicable to a particular subclass +
      +
    1. INET-SOCKET - Internet Protocol (TCP, UDP, raw) sockets +
    2. Methods on UNIX-SOCKET - Unix-domain sockets +
    +
  5. Name resolution (DNS, /etc/hosts, &c) +
+ +

General concepts

+ +

Most of the functions are modelled on the BSD socket API. BSD sockets +are widely supported, portably ("portable" by Unix standards, at least) +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 + +

+ + +|# diff --git a/contrib/sb-bsd-sockets/doc.lisp b/contrib/sb-bsd-sockets/doc.lisp new file mode 100644 index 0000000..3c85f3e --- /dev/null +++ b/contrib/sb-bsd-sockets/doc.lisp @@ -0,0 +1,225 @@ +(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" + w w)) + ((and (> (length w) 0) + (eql (elt w 0) #\_) + (eql (elt w (1- (length w))) #\_)) + (format nil "~A" (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

~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 "

Package ~A

~%" 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 "

Class: ~A~%" + name name) + #+nil (format stream "

Superclasses: ~{~A ~}~%" + (mapcar (lambda (x) (text-markup (class-name x))) + (mop:class-direct-superclasses class))) + (if (documentation class 'type) + (format stream "

~A
~%" + (text-markup (documentation class 'type)))) + (when slots + (princ "

Slots:

" 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 "

(~A ~A)~A
~%" + name (string-downcase (princ-to-string name)) + (string-downcase + (format nil "~{ ~A~}" (markup-lambdalist lambdalist))) + label) + (if (stringp doc) + (format stream "

~A
~%" + (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 "
" output-stream) |# )) + (format output-stream "
" + )))) + +(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 "

") + 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 "SBCL BSD-Sockets API Reference~%") + (asdf:operate 'asdf:load-op 'sb-bsd-sockets) + (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) + +(start) diff --git a/contrib/sb-bsd-sockets/foreign-glue.lisp b/contrib/sb-bsd-sockets/foreign-glue.lisp new file mode 100644 index 0000000..446b5d2 --- /dev/null +++ b/contrib/sb-bsd-sockets/foreign-glue.lisp @@ -0,0 +1,88 @@ +(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)) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp new file mode 100644 index 0000000..eeb2b25 --- /dev/null +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -0,0 +1,94 @@ +(in-package :sb-bsd-sockets) + +#||

INET-domain sockets

+ +

The TCP and UDP sockets that you know and love. Some representation issues: +

 + +|# + +;;; 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)) + + + diff --git a/contrib/sb-bsd-sockets/malloc.lisp b/contrib/sb-bsd-sockets/malloc.lisp new file mode 100644 index 0000000..0b6ca39 --- /dev/null +++ b/contrib/sb-bsd-sockets/malloc.lisp @@ -0,0 +1,16 @@ +(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))))) + diff --git a/contrib/sb-bsd-sockets/misc.lisp b/contrib/sb-bsd-sockets/misc.lisp new file mode 100644 index 0000000..6dd2bfb --- /dev/null +++ b/contrib/sb-bsd-sockets/misc.lisp @@ -0,0 +1,36 @@ +(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)) + + diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp new file mode 100644 index 0000000..5f03859 --- /dev/null +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -0,0 +1,144 @@ +(in-package :sb-bsd-sockets) +#||

Name Service

 + +

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 + +

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)) +) + diff --git a/contrib/sb-bsd-sockets/rt.lisp b/contrib/sb-bsd-sockets/rt.lisp new file mode 100644 index 0000000..ab7a79c --- /dev/null +++ b/contrib/sb-bsd-sockets/rt.lisp @@ -0,0 +1,167 @@ +;-*-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. + +(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)))) + +(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)))) + +(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*))) + +(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))) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd new file mode 100644 index 0000000..e259756 --- /dev/null +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -0,0 +1,127 @@ +;;; -*- 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"))) + diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp new file mode 100644 index 0000000..69834dc --- /dev/null +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -0,0 +1,279 @@ +(in-package "SB-BSD-SOCKETS") + +;;;; Methods, classes, functions for sockets. Protocol-specific stuff +;;;; is deferred to inet.lisp, unix.lisp, etc + +#||

SOCKETs

+ +|# + +(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))))) + + + +;; 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")))) + + +(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)) + + + +;;; 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))) + + + diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp new file mode 100644 index 0000000..2b89066 --- /dev/null +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -0,0 +1,189 @@ +(in-package :sb-bsd-sockets) + +#|| +

Socket Options

+ +

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: SO_RCVLOWAT becomes +sockopt-receive-low-water and (setf +sockopt-receive-low-water). +||# + +#| +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 +|# + diff --git a/contrib/sb-bsd-sockets/split.lisp b/contrib/sb-bsd-sockets/split.lisp new file mode 100644 index 0000000..fec708c --- /dev/null +++ b/contrib/sb-bsd-sockets/split.lisp @@ -0,0 +1,23 @@ +(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))) + diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp new file mode 100644 index 0000000..22512f5 --- /dev/null +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -0,0 +1,225 @@ +(defpackage "SB-BSD-SOCKETS-TEST" + (:use "CL" "SB-BSD-SOCKETS" "RT")) + +#|| + +

Tests

+ +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 tests.lisp 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) + +#|| +

Unix-domain sockets

+ +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))))))) + + diff --git a/contrib/sb-bsd-sockets/unix.lisp b/contrib/sb-bsd-sockets/unix.lisp new file mode 100644 index 0000000..bd9835d --- /dev/null +++ b/contrib/sb-bsd-sockets/unix.lisp @@ -0,0 +1,40 @@ +(in-package :sb-bsd-sockets) + +#||

File-domain sockets

+ +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))) + diff --git a/contrib/vanilla-module.mk b/contrib/vanilla-module.mk new file mode 100644 index 0000000..25efdd1 --- /dev/null +++ b/contrib/vanilla-module.mk @@ -0,0 +1,8 @@ + +$(MODULE).fasl: $(MODULE).lisp + $(SBCL) --eval '(compile-file "$(MODULE)")' 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. @@ -94,4 +95,5 @@ sh make-host-1.sh || exit 1 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 diff --git a/version.lisp-expr b/version.lisp-expr index 4525530..98410f1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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"