From: Daniel Barlow Date: Fri, 7 Feb 2003 17:14:28 +0000 (+0000) Subject: renamed to sb-bsd-sockets X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a78064c13bab180a663238979ae837210c5c9ff4;p=sbcl.git renamed to sb-bsd-sockets --- diff --git a/contrib/bsd-sockets/FAQ b/contrib/bsd-sockets/FAQ deleted file mode 100644 index d788eb2..0000000 --- a/contrib/bsd-sockets/FAQ +++ /dev/null @@ -1,47 +0,0 @@ -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. diff --git a/contrib/bsd-sockets/Makefile b/contrib/bsd-sockets/Makefile deleted file mode 100644 index 42a6e8e..0000000 --- a/contrib/bsd-sockets/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -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 . ) diff --git a/contrib/bsd-sockets/NEWS b/contrib/bsd-sockets/NEWS deleted file mode 100644 index c12398d..0000000 --- a/contrib/bsd-sockets/NEWS +++ /dev/null @@ -1,135 +0,0 @@ -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 diff --git a/contrib/bsd-sockets/README b/contrib/bsd-sockets/README deleted file mode 100644 index 91e4df8..0000000 --- a/contrib/bsd-sockets/README +++ /dev/null @@ -1,29 +0,0 @@ -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 , but please check the CVS version first. - -$Id$ diff --git a/contrib/bsd-sockets/TODO b/contrib/bsd-sockets/TODO deleted file mode 100644 index 90c82a3..0000000 --- a/contrib/bsd-sockets/TODO +++ /dev/null @@ -1,20 +0,0 @@ - -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/bsd-sockets/alien.so b/contrib/bsd-sockets/alien.so deleted file mode 100755 index 67790fb..0000000 Binary files a/contrib/bsd-sockets/alien.so and /dev/null differ diff --git a/contrib/bsd-sockets/alien/get-h-errno.c b/contrib/bsd-sockets/alien/get-h-errno.c deleted file mode 100755 index a1d22a6..0000000 --- a/contrib/bsd-sockets/alien/get-h-errno.c +++ /dev/null @@ -1,6 +0,0 @@ -#include - -int get_h_errno() -{ - return h_errno; -} diff --git a/contrib/bsd-sockets/alien/undefs.c b/contrib/bsd-sockets/alien/undefs.c deleted file mode 100644 index fca6cde..0000000 --- a/contrib/bsd-sockets/alien/undefs.c +++ /dev/null @@ -1,9 +0,0 @@ -/* 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/bsd-sockets/api-reference.html b/contrib/bsd-sockets/api-reference.html deleted file mode 100644 index 09e3f04..0000000 --- a/contrib/bsd-sockets/api-reference.html +++ /dev/null @@ -1,188 +0,0 @@ -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 -

-

    -
  • 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 errno values -

    -

  • We use multiple return values in many places where the C API would use p[ass-by-reference values -

    -

  • We can often avoid supplying an explicit length argument to -functions because we already know how long the argument is. -

    -

  • IP addresses and ports are represented in slightly friendlier fashion -than "network-endian integers". See the section on Internet domain sockets for details. -
-

-

-

SOCKETs

-

-

Class: SOCKET -

Slots:

  • FILE-DESCRIPTOR :
    • -
  • FAMILY :
    • -
  • PROTOCOL :
    • -
  • TYPE :
    • -
  • STREAM :
    • -

(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: -

    -
  • These functions do not accept hostnames directly: see name resolution -
  • Internet addresses are represented by vectors of (unsigned-byte 8) - viz. #(127 0 0 1). Ports are just integers: 6010. No conversion between network- and host-order data is needed from the user of this package. -
  • socket addresses are represented by the two values for address and port, so for example, (socket-connect s #(192.168.1.1) 80) -
-

-

Class: INET-SOCKET -

Slots:

  • FAMILY :
    • -

(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:

  • FAMILY :
    • -

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:

  • NAME :
    • -
  • ALIASES :
    • -
  • ADDRESS-TYPE :
    • -
  • ADDRESSES :
    • -

(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/bsd-sockets/array-data.lisp b/contrib/bsd-sockets/array-data.lisp deleted file mode 100644 index 8a53daa..0000000 --- a/contrib/bsd-sockets/array-data.lisp +++ /dev/null @@ -1,72 +0,0 @@ -(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/bsd-sockets/bsd-sockets.asd b/contrib/bsd-sockets/bsd-sockets.asd deleted file mode 100644 index f968eb0..0000000 --- a/contrib/bsd-sockets/bsd-sockets.asd +++ /dev/null @@ -1,127 +0,0 @@ -;;; -*- Lisp -*- - -(defpackage #:bsd-sockets-system (:use #:asdf #:cl)) -(in-package #:bsd-sockets-system) - -;;; constants.lisp requires special treatment - -(defclass constants-file (cl-source-file) ()) - -(defmethod perform ((op compile-op) (component constants-file)) - ;; we want to generate all our temporary files in the fasl directory - ;; because that's where we have write permission. Can't use /tmp; - ;; it's insecure (these files will later be owned by root) - (let* ((output-file (car (output-files op component))) - (filename (component-pathname component)) - (real-output-file - (if (typep output-file 'logical-pathname) - (translate-logical-pathname output-file) - (pathname output-file))) - (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) - (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file)) - (tmp-constants (merge-pathnames #p"constants.lisp-temp" - real-output-file))) - (princ (list filename output-file real-output-file - tmp-c-source tmp-a-dot-out tmp-constants)) - (terpri) - (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "BSD-SOCKETS-SYSTEM")) - filename tmp-c-source :bsd-sockets-internal) - (and - (= (run-shell-command - "/usr/bin/gcc -o ~S ~S" (namestring tmp-a-dot-out) - (namestring tmp-c-source)) 0) - (= (run-shell-command "~A >~A" - (namestring tmp-a-dot-out) - (namestring tmp-constants)) 0) - (compile-file tmp-constants :output-file output-file)))) - - -;;; we also have a shared library with some .o files in it - -(defclass unix-dso (module) ()) -(defun unix-name (pathname) - (namestring - (typecase pathname - (logical-pathname (translate-logical-pathname pathname)) - (t pathname)))) - -(defmethod asdf::input-files ((operation compile-op) (dso unix-dso)) - (mapcar #'component-pathname (module-components dso))) - -(defmethod output-files ((operation compile-op) (dso unix-dso)) - (let ((dir (component-pathname dso))) - (list - (make-pathname :type "so" - :name (car (last (pathname-directory dir))) - :directory (butlast (pathname-directory dir)) - :defaults dir)))) - - -(defmethod perform :after ((operation compile-op) (dso unix-dso)) - (let ((dso-name (unix-name (car (output-files operation dso))))) - (unless (zerop - (run-shell-command - "gcc -shared -o ~S ~{~S ~}" - dso-name - (mapcar #'unix-name - (mapcan (lambda (c) - (output-files operation c)) - (module-components dso))))) - (error 'operation-error :operation operation :component dso)))) - -;;; if this goes into the standard asdf, it could reasonably be extended -;;; to allow cflags to be set somehow -(defmethod output-files ((op compile-op) (c c-source-file)) - (list - (make-pathname :type "o" :defaults - (component-pathname c)))) -(defmethod perform ((op compile-op) (c c-source-file)) - (unless - (= 0 (run-shell-command "/usr/bin/gcc -fPIC -o ~S -c ~S" - (unix-name (car (output-files op c))) - (unix-name (component-pathname c)))) - (error 'operation-error :operation op :component c))) - -(defmethod perform ((operation load-op) (c c-source-file)) - t) - -(defmethod perform ((o load-op) (c unix-dso)) - (let ((co (make-instance 'compile-op))) - (let ((filename (car (output-files co c)))) - #+cmu (ext:load-foreign filename) - #+sbcl (sb-alien:load-1-foreign filename)))) - -(defsystem bsd-sockets - :version "0.58" - :components ((:file "defpackage" :depends-on ("rt")) - (:file "split" :depends-on ("defpackage")) - (:file "array-data" :depends-on ("defpackage")) - (:unix-dso "alien" - :components ((:c-source-file "undefs") - (:c-source-file "get-h-errno"))) - (:file "malloc" :depends-on ("defpackage")) - (:file "foreign-glue" :depends-on ("defpackage" "malloc")) - (:constants-file "constants" - :pathname "constants.lisp" - :depends-on - ("def-to-lisp" "defpackage" "foreign-glue")) - (:file "sockets" - :depends-on ("constants" "array-data")) - - (:file "sockopt" :depends-on ("sockets")) - (:file "inet" :depends-on ("sockets" "split" "constants" )) - (:file "unix" :depends-on ("sockets" "split" "constants" )) - (:file "name-service" :depends-on ("sockets" "constants" "alien")) - (:file "misc" :depends-on ("sockets" "constants")) - - (:file "rt") - (:file "def-to-lisp") - (:file "tests" :depends-on ("inet" "sockopt" "rt")) - - (:static-file "NEWS") - (:static-file "INSTALL") - (:static-file "README") - (:static-file "index" :pathname "index.html") - (:static-file "doc" :pathname "doc.lisp") - (:static-file "TODO"))) - diff --git a/contrib/bsd-sockets/constants.lisp b/contrib/bsd-sockets/constants.lisp deleted file mode 100644 index e792888..0000000 --- a/contrib/bsd-sockets/constants.lisp +++ /dev/null @@ -1,189 +0,0 @@ -;;; -*- 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/bsd-sockets/constants.lisp-temp b/contrib/bsd-sockets/constants.lisp-temp deleted file mode 100644 index 1294c43..0000000 --- a/contrib/bsd-sockets/constants.lisp-temp +++ /dev/null @@ -1,170 +0,0 @@ -(in-package :BSD-SOCKETS-INTERNAL) -(defconstant size-of-int 4) -(defconstant size-of-char 1) -(defconstant size-of-long 4) -(defconstant AF-INET 2 "IP Protocol family") -(defconstant AF-UNSPEC 0 "Unspecified.") -(defconstant AF-LOCAL 1 "Local to host (pipes and file-domain).") -(defconstant AF-UNIX 1 "Old BSD name for af-local. ") -(defconstant AF-FILE 1 "POSIX name for af-local. ") -(defconstant AF-INET6 10 "IP version 6. ") -(defconstant AF-ROUTE 16 "Alias to emulate 4.4BSD ") -(defconstant SOCK-STREAM 1 "Sequenced, reliable, connection-based byte streams.") -(defconstant SOCK-DGRAM 2 "Connectionless, unreliable datagrams of fixed maximum length.") -(defconstant SOCK-RAW 3 "Raw protocol interface.") -(defconstant SOCK-RDM 4 "Reliably-delivered messages.") -(defconstant SOCK-SEQPACKET 5 "Sequenced, reliable, connection-based, datagrams of fixed maximum length.") -(defconstant SOL-SOCKET 1 "NIL") -(defconstant SO-DEBUG 1 "Enable debugging in underlying protocol modules") -(defconstant SO-REUSEADDR 2 "Enable local address reuse") -(defconstant SO-TYPE 3 "NIL") -(defconstant SO-ERROR 4 "NIL") -(defconstant SO-DONTROUTE 5 "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address") -(defconstant SO-BROADCAST 6 "Request permission to send broadcast datagrams") -(defconstant SO-SNDBUF 7 "NIL") -(defconstant SO-PASSCRED 16 "NIL") -(defconstant SO-RCVBUF 8 "NIL") -(defconstant SO-KEEPALIVE 9 "Send periodic keepalives: if peer does not respond, we get SIGPIPE") -(defconstant SO-OOBINLINE 10 "Put out-of-band data into the normal input queue when received") -(defconstant SO-NO-CHECK 11 "NIL") -(defconstant SO-PRIORITY 12 "NIL") -(defconstant SO-LINGER 13 "For reliable streams, pause a while on closing when unsent messages are queued") -(defconstant SO-BSDCOMPAT 14 "NIL") -(defconstant SO-SNDLOWAT 19 "NIL") -(defconstant SO-RCVLOWAT 18 "NIL") -(defconstant SO-SNDTIMEO 21 "NIL") -(defconstant SO-RCVTIMEO 20 "NIL") -(defconstant TCP-NODELAY 1 "NIL") -(defconstant SO-BINDTODEVICE 25 "NIL") -(defconstant IFNAMSIZ 16 "NIL") -(defconstant EADDRINUSE 98 "NIL") -(defconstant EAGAIN 11 "NIL") -(defconstant EBADF 9 "NIL") -(defconstant ECONNREFUSED 111 "NIL") -(defconstant EINTR 4 "NIL") -(defconstant EINVAL 22 "NIL") -(defconstant ENOBUFS 105 "NIL") -(defconstant ENOMEM 12 "NIL") -(defconstant EOPNOTSUPP 95 "NIL") -(defconstant EPERM 1 "NIL") -(defconstant EPROTONOSUPPORT 93 "NIL") -(defconstant ESOCKTNOSUPPORT 94 "NIL") -(defconstant ENETUNREACH 101 "NIL") -(defconstant NETDB-INTERNAL -1 "See errno.") -(defconstant NETDB-SUCCESS 0 "No problem.") -(defconstant HOST-NOT-FOUND 1 "Authoritative Answer Host not found.") -(defconstant TRY-AGAIN 2 "Non-Authoritative Host not found, or SERVERFAIL.") -(defconstant NO-RECOVERY 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.") -(defconstant NO-DATA 4 "Valid name, no data record of requested type.") -(defconstant NO-ADDRESS 4 "No address, look for MX record.") -(defconstant O-NONBLOCK 2048 "NIL") -(defconstant F-GETFL 3 "NIL") -(defconstant F-SETFL 4 "NIL") -(defconstant MSG-NOSIGNAL 16384 "NIL") -(defconstant MSG-OOB 1 "NIL") -(defconstant MSG-PEEK 2 "NIL") -(defconstant MSG-TRUNC 32 "NIL") -(defconstant MSG-WAITALL 256 "NIL") -(define-c-struct PROTOENT 12) -(define-c-accessor PROTOENT-NAME PROTOENT (* T) 0 4) -(define-c-accessor PROTOENT-ALIASES PROTOENT (* (* T)) 4 4) -(define-c-accessor PROTOENT-PROTO PROTOENT INTEGER 8 4) -(declaim (inline GETPROTOBYNAME)) -(def-foreign-routine ("getprotobyname" GETPROTOBYNAME ) (* T) (NAME - C-STRING) ) -(defconstant INADDR-ANY 0 "NIL") -(define-c-struct IN-ADDR 4) -(define-c-accessor IN-ADDR-ADDR IN-ADDR (ARRAY (UNSIGNED 8) 4) 0 4) -(define-c-struct SOCKADDR-IN 16) -(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 0 2) -(define-c-accessor SOCKADDR-IN-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) -(define-c-accessor SOCKADDR-IN-ADDR SOCKADDR-IN (ARRAY (UNSIGNED 8) 4) 4 4) -(define-c-struct SOCKADDR-UN 110) -(define-c-accessor SOCKADDR-UN-FAMILY SOCKADDR-UN INTEGER 0 2) -(define-c-accessor SOCKADDR-UN-PATH SOCKADDR-UN (ARRAY (UNSIGNED 8) 108) 2 108) -(define-c-struct HOSTENT 20) -(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4) -(define-c-accessor HOSTENT-ALIASES HOSTENT (* C-STRING) 4 4) -(define-c-accessor HOSTENT-TYPE HOSTENT INTEGER 8 4) -(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4) -(define-c-accessor HOSTENT-ADDRESSES HOSTENT (* (* (UNSIGNED 8))) 16 4) -(declaim (inline SOCKET)) -(def-foreign-routine ("socket" SOCKET ) INTEGER (DOMAIN INTEGER) (TYPE - INTEGER) (PROTOCOL - INTEGER) ) -(declaim (inline BIND)) -(def-foreign-routine ("bind" BIND ) INTEGER (SOCKFD INTEGER) (MY-ADDR - (* T)) (ADDRLEN - INTEGER) ) -(declaim (inline LISTEN)) -(def-foreign-routine ("listen" LISTEN ) INTEGER (SOCKET INTEGER) (BACKLOG - INTEGER) ) -(declaim (inline ACCEPT)) -(def-foreign-routine ("accept" ACCEPT ) INTEGER (SOCKET INTEGER) (MY-ADDR - (* - T)) (ADDRLEN - INTEGER - :IN-OUT) ) -(declaim (inline GETPEERNAME)) -(def-foreign-routine ("getpeername" GETPEERNAME ) INTEGER (SOCKET - INTEGER) (HER-ADDR - (* - T)) (ADDRLEN - INTEGER - :IN-OUT) ) -(declaim (inline GETSOCKNAME)) -(def-foreign-routine ("getsockname" GETSOCKNAME ) INTEGER (SOCKET - INTEGER) (MY-ADDR - (* - T)) (ADDRLEN - INTEGER - :IN-OUT) ) -(declaim (inline CONNECT)) -(def-foreign-routine ("connect" CONNECT ) INTEGER (SOCKET INTEGER) (HIS-ADDR - (* - T)) (ADDRLEN - INTEGER) ) -(declaim (inline CLOSE)) -(def-foreign-routine ("close" CLOSE ) INTEGER (FD INTEGER) ) -(declaim (inline RECVFROM)) -(def-foreign-routine ("recvfrom" RECVFROM ) INTEGER (SOCKET INTEGER) (BUF - (* - T)) (LEN - INTEGER) (FLAGS - INTEGER) (SOCKADDR - (* - T)) (SOCKLEN - (* - INTEGER)) ) -(declaim (inline GETHOSTBYNAME)) -(def-foreign-routine ("gethostbyname" GETHOSTBYNAME ) (* T) (NAME - C-STRING) ) -(declaim (inline GETHOSTBYADDR)) -(def-foreign-routine ("gethostbyaddr" GETHOSTBYADDR ) (* T) (ADDR - (* T)) (LEN - INTEGER) (AF - INTEGER) ) -(define-c-struct HOSTENT 20) -(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4) -(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4) -(declaim (inline SETSOCKOPT)) -(def-foreign-routine ("setsockopt" SETSOCKOPT ) INTEGER (SOCKET - INTEGER) (LEVEL - INTEGER) (OPTNAME - INTEGER) (OPTVAL - (* - T)) (OPTLEN - INTEGER) ) -(declaim (inline FCNTL)) -(def-foreign-routine ("fcntl" FCNTL ) INTEGER (FD INTEGER) (CMD - INTEGER) (ARG - INTEGER) ) -(declaim (inline GETSOCKOPT)) -(def-foreign-routine ("getsockopt" GETSOCKOPT ) INTEGER (SOCKET - INTEGER) (LEVEL - INTEGER) (OPTNAME - INTEGER) (OPTVAL - (* - T)) (OPTLEN - INTEGER - :IN-OUT) ) diff --git a/contrib/bsd-sockets/def-to-lisp.lisp b/contrib/bsd-sockets/def-to-lisp.lisp deleted file mode 100644 index a0317a1..0000000 --- a/contrib/bsd-sockets/def-to-lisp.lisp +++ /dev/null @@ -1,70 +0,0 @@ -(in-package :BSD-SOCKETS-SYSTEM) -(defvar *export-symbols* nil) - -(defun c-for-structure (stream lisp-name c-struct) - (destructuring-bind (c-name &rest elements) c-struct - (format stream "printf(\"(define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name) - (dolist (e elements) - (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e - (format stream "printf(\"(define-c-accessor ~A-~A ~A ~A \");~%" - lisp-name lisp-el-name lisp-name lisp-type) - ;; offset - (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%" - c-name c-el-name) - ;; length - (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%" - c-name c-el-name) - (format stream "printf(\")\\n\");~%"))))) - -(defun c-for-function (stream lisp-name alien-defn) - (destructuring-bind (c-name &rest definition) alien-defn - (let ((*print-right-margin* nil)) - (format stream "printf(\"(declaim (inline ~A))\\n\");~%" - lisp-name) - (princ "printf(\"(def-foreign-routine (" stream) - (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream) - (princ lisp-name stream) - (princ " ) " stream) - (dolist (d definition) - (write d :length nil - :right-margin nil :stream stream) - (princ " " stream)) - (format stream ")\\n\");") - (terpri stream)))) - - -(defun print-c-source (stream headers definitions package-name) - ;(format stream "#include \"struct.h\"~%") - (let ((*print-right-margin* nil)) - (loop for i in headers - do (format stream "#include <~A>~%" i)) - (format stream "main() { ~% -printf(\"(in-package ~S)\\\n\");~%" package-name) - (format stream "printf(\"(defconstant size-of-int %d)\\\n\",sizeof (int));~%") - (format stream "printf(\"(defconstant size-of-char %d)\\\n\",sizeof (char));~%") - (format stream "printf(\"(defconstant size-of-long %d)\\\n\",sizeof (long));~%") - (dolist (def definitions) - (destructuring-bind (type lispname cname &optional doc) def - (cond ((eq type :integer) - (format stream - "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%" - lispname doc cname)) - ((eq type :string) - (format stream - "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" - lispname doc cname)) - ((eq type :function) - (c-for-function stream lispname cname)) - ((eq type :structure) - (c-for-structure stream lispname cname)) - (t - (format stream - "printf(\";; Non hablo Espagnol, Monsieur~%"))))) - (format stream "exit(0);~%}"))) - -(defun c-constants-extract (filename output-file package) - (with-open-file (f output-file :direction :output) - (with-open-file (i filename :direction :input) - (let* ((headers (read i)) - (definitions (read i))) - (print-c-source f headers definitions package))))) diff --git a/contrib/bsd-sockets/defpackage.lisp b/contrib/bsd-sockets/defpackage.lisp deleted file mode 100644 index 8f21df3..0000000 --- a/contrib/bsd-sockets/defpackage.lisp +++ /dev/null @@ -1,123 +0,0 @@ -(defpackage "BSD-SOCKETS-INTERNAL" - (:nicknames "SOCKINT") - (:shadow close listen) - #+cmu (:shadowing-import-from "CL" with-array-data) - #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data) - - #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL") - #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL")) - -;;; SBCL changes a lot of package prefixes. To avoid littering the -;;; code with conditionals, we use the SBCL package prefixes -;;; throughout. This means that we need to create said packages -;;; first, if we're using CMUCL - -;;; One thing that this exercise really has made clear is just how much -;;; of the alien stuff is scattered around the cmucl package space -;;; seemingly at random. Hmm. - -#+cmu -(eval-when (:compile-toplevel :load-toplevel) - (defun add-package-nickname (name nickname) - (let ((p (find-package name))) - (rename-package p (package-name p) - (cons nickname (package-nicknames name))))) - (add-package-nickname "EXT" "SB-EXT") - (add-package-nickname "ALIEN" "SB-ALIEN") - (add-package-nickname "UNIX" "SB-UNIX") - (add-package-nickname "C-CALL" "SB-C-CALL") - (add-package-nickname "KERNEL" "SB-KERNEL") - (add-package-nickname "SYSTEM" "SB-SYS")) - -(defpackage "BSD-SOCKETS" - (:export socket unix-socket inet-socket - make-unix-socket make-inet-socket - socket-bind socket-accept socket-connect - socket-send socket-receive socket-recv - socket-name socket-peername socket-listen - socket-close socket-file-descriptor socket-make-stream - get-protocol-by-name - - get-host-by-name get-host-by-address - host-ent - host-ent-addresses host-ent-address - host-ent aliases host-ent-name - name-service-error - ;; not sure if these are really good names or not - netdb-internal-error - netdb-success-error - host-not-found-error - try-again-error - no-recovery-error - - ;; all socket options are also exported, by code in - ;; sockopt.lisp - - bad-file-descriptor-error - address-in-use-error - interrupted-error - invalid-argument-error - out-of-memory-error - operation-not-supported-error - operation-not-permitted-error - protocol-not-supported-error - socket-type-not-supported-error - network-unreachable-error - - make-inet-address - - non-blocking-mode - ) - (:use "COMMON-LISP" "BSD-SOCKETS-INTERNAL") - (:documentation - " - -A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD -socket API for C and Graham Barr's IO::Socket classes for Perl. - -We represent sockets as CLOS objects, and rename a lot of methods and -arguments to fit Lisp style more closely. - -" - )) - -#|| - -

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

    -
  • 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 errno values - -
  • We use multiple return values in many places where the C API would use p[ass-by-reference values - -
  • We can often avoid supplying an explicit length argument to -functions because we already know how long the argument is. - -
  • IP addresses and ports are represented in slightly friendlier fashion -than "network-endian integers". See the section on Internet domain sockets for details. -
- - -|# diff --git a/contrib/bsd-sockets/doc.lisp b/contrib/bsd-sockets/doc.lisp deleted file mode 100644 index 37cfe36..0000000 --- a/contrib/bsd-sockets/doc.lisp +++ /dev/null @@ -1,225 +0,0 @@ -(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) - (dolist (slot slots) - (destructuring-bind - (name &key reader writer accessor initarg initform type - documentation) - (if (consp slot) slot (list slot)) - (format stream "
  • ~A : ~A
    • ~%" name - (if documentation (text-markup documentation) "")))) - (princ "
" 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 'bsd-sockets) - (document-system 'bsd-sockets :package :bsd-sockets))) - -(start) diff --git a/contrib/bsd-sockets/foreign-glue.lisp b/contrib/bsd-sockets/foreign-glue.lisp deleted file mode 100644 index 0b4e08c..0000000 --- a/contrib/bsd-sockets/foreign-glue.lisp +++ /dev/null @@ -1,88 +0,0 @@ -(in-package :bsd-sockets-internal) - -;;;; Foreign function glue. This is the only file in the distribution -;;;; that's _intended_ to be vendor-specific. The macros defined here -;;;; are called from constants.lisp, which was generated from constants.ccon -;;;; by the C compiler as driven by that wacky def-to-lisp thing. - -;;;; of course, the whole thing is vendor-specific actually, due to -;;;; the way we use cmucl alien types in constants.ccon as a cheap way -;;;; of transforming C-world alues into Lisp-world values. But if -;;;; anyone were to port that bit to their preferred implementation, they -;;;; wouldn't need to port all the rest of the cmucl alien interface at -;;;; the same time - -;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME -;;; C-CALL:C-STRING) (BUF (* T)) ) - -;;; I can't help thinking this was originally going to do something a -;;; lot more complex -(defmacro def-foreign-routine - (&whole it (c-name lisp-name) return-type &rest args) - (declare (ignorable c-name lisp-name return-type args)) - `(def-alien-routine ,@(cdr it))) -#| -(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) -(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2) -|# -;;; define-c-accessor makes us a setter and a getter for changing -;;; memory at the appropriate offset - -;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4) - -(defmacro define-c-accessor (el structure type offset length) - (declare (ignore structure)) - (let* ((ty (cond - ((eql type 'integer) `(,type ,(* 8 length))) - ((eql (car type) '*) `(unsigned ,(* 8 length))) - ((eql type 'c-string) `(unsigned ,(* 8 length))) - ((eql (car type) 'array) (cadr type)))) - (sap-ref-? (intern (format nil "~ASAP-REF-~A" - (if (member (car ty) '(INTEGER SIGNED)) - "SIGNED-" "") - (cadr ty)) - (find-package "SB-SYS")))) - (labels ((template (before after) - `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr)))) - (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset))))) - (,before (,sap-ref-? sap index) ,after)))) - `(progn - ;;(declaim (inline ,el (setf ,el))) - (defun ,el (ptr &optional (index 0)) - ,(template 'prog1 nil)) - (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset) - (defun (setf ,el) (newval ptr &optional (index 0)) - ,(template 'setf 'newval)))))) - - -;;; make memory allocator for appropriately-sized block of memory, and -;;; a constant to tell us how big it was anyway -(defmacro define-c-struct (name size) - (labels ((p (x) (intern (concatenate 'string x (symbol-name name))))) - `(progn - (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0 - :element-type '(unsigned-byte 8))) - (defconstant ,(p "SIZE-OF-") ,size) - (defun ,(p "FREE-" ) (p) (declare (ignore p)))))) - -(defun foreign-nullp (c) - "C is a pointer to 0?" - (= 0 (sb-sys:sap-int (sb-alien:alien-sap c)))) - -;;; this could be a lot faster if I cared enough to think about it -(defun foreign-vector (pointer size length) - "Compose a vector of the words found in foreign memory starting at -POINTER. Each word is SIZE bytes long; LENGTH gives the number of -elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO" - (assert (= size 1)) - (let ((ptr - (typecase pointer - (sb-sys:system-area-pointer - (sap-alien pointer (* (sb-alien:unsigned 8)))) - (t - (sb-alien:cast pointer (* (sb-alien:unsigned 8)))))) - (result (make-array length :element-type '(unsigned-byte 8)))) - (loop for i from 0 to (1- length) by size - do (setf (aref result i) (sb-alien:deref ptr i))) - ;;(format t "~S~%" result) - result)) diff --git a/contrib/bsd-sockets/inet.lisp b/contrib/bsd-sockets/inet.lisp deleted file mode 100644 index 3cc0545..0000000 --- a/contrib/bsd-sockets/inet.lisp +++ /dev/null @@ -1,94 +0,0 @@ -(in-package :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/bsd-sockets/malloc.lisp b/contrib/bsd-sockets/malloc.lisp deleted file mode 100644 index 75921e7..0000000 --- a/contrib/bsd-sockets/malloc.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(in-package :bsd-sockets-internal) - -(defun malloc (size) - "Allocate foreign memory in some way that allows the garbage collector to free it later. Note that memory allocated this way does not count as `consed' for the purposes of deciding when to gc, so explicitly calling EXT:GC occasionally would be a good idea if you use it a lot" - ;; we can attach finalizers to any object, and they'll be called on - ;; the next gc after the object no longer has references. We can't - ;; however make the finalizer close over the object, or it'll never - ;; have no references. I experimentally determined that (sap-alien - ;; (alien-sap f)) is not EQ to f, so we can do it that way - (let* ((memory (make-alien (unsigned 8) size)) - (alias (sap-alien (alien-sap memory) - (* (unsigned 8))))) - (sb-ext:finalize memory - (lambda () - (free-alien alias))))) - diff --git a/contrib/bsd-sockets/misc.lisp b/contrib/bsd-sockets/misc.lisp deleted file mode 100644 index 254bd47..0000000 --- a/contrib/bsd-sockets/misc.lisp +++ /dev/null @@ -1,36 +0,0 @@ -(in-package :bsd-sockets) - -;;; Miscellaneous things, placed here until I can find a logically more -;;; coherent place to put them - -;;; I don't want to provide a complete interface to unix file -;;; operations, for example, but being about to set O_NONBLOCK on a -;;; socket is a necessary operation. - -;;; XXX bad (sizeof (int) ==4 ) assumptions - -(defmethod non-blocking-mode ((socket socket)) - "Is SOCKET in non-blocking mode?" - (let ((fd (socket-file-descriptor socket))) - (sb-alien:with-alien ((arg integer)) - (> (logand - (sockint::fcntl fd sockint::f-getfl arg) - sockint::o-nonblock) - 0)))) - -(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) - "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P" - (declare (optimize (speed 3))) - (let* ((fd (socket-file-descriptor socket)) - (arg1 (the (signed-byte 32) (sockint::fcntl fd sockint::f-getfl 0))) - (arg2 - (if non-blocking-p - (logior arg1 sockint::o-nonblock) - (logand (lognot sockint::o-nonblock) arg1)))) - (when (= (the (signed-byte 32) -1) - (the (signed-byte 32) - (sockint::fcntl fd sockint::f-setfl arg2))) - (socket-error "fcntl")) - non-blocking-p)) - - diff --git a/contrib/bsd-sockets/name-service.lisp b/contrib/bsd-sockets/name-service.lisp deleted file mode 100644 index 98e67fe..0000000 --- a/contrib/bsd-sockets/name-service.lisp +++ /dev/null @@ -1,144 +0,0 @@ -(in-package :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/bsd-sockets/rt.lisp b/contrib/bsd-sockets/rt.lisp deleted file mode 100644 index ab7a79c..0000000 --- a/contrib/bsd-sockets/rt.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;-*-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/bsd-sockets/sockets.lisp b/contrib/bsd-sockets/sockets.lisp deleted file mode 100644 index 630a73d..0000000 --- a/contrib/bsd-sockets/sockets.lisp +++ /dev/null @@ -1,279 +0,0 @@ -(in-package "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/bsd-sockets/sockopt.lisp b/contrib/bsd-sockets/sockopt.lisp deleted file mode 100644 index 4f7944e..0000000 --- a/contrib/bsd-sockets/sockopt.lisp +++ /dev/null @@ -1,189 +0,0 @@ -(in-package :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/bsd-sockets/split.lisp b/contrib/bsd-sockets/split.lisp deleted file mode 100644 index 2c0d17c..0000000 --- a/contrib/bsd-sockets/split.lisp +++ /dev/null @@ -1,23 +0,0 @@ -(in-package :bsd-sockets) - -;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100 -;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de> - -(defun split (string &optional max (ws '(#\Space #\Tab))) - "Split `string' along whitespace as defined by the sequence `ws'. -The whitespace is elided from the result. The whole string will be -split, unless `max' is a non-negative integer, in which case the -string will be split into `max' tokens at most, the last one -containing the whole rest of the given `string', if any." - (flet ((is-ws (char) (find char ws))) - (loop for start = (position-if-not #'is-ws string) - then (position-if-not #'is-ws string :start index) - for index = (and start - (if (and max (= (1+ word-count) max)) - nil - (position-if #'is-ws string :start start))) - while start - collect (subseq string start index) - count 1 into word-count - while index))) - diff --git a/contrib/bsd-sockets/tests.lisp b/contrib/bsd-sockets/tests.lisp deleted file mode 100644 index 347ddd1..0000000 --- a/contrib/bsd-sockets/tests.lisp +++ /dev/null @@ -1,225 +0,0 @@ -(defpackage "BSD-SOCKETS-TEST" - (:use "CL" "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 :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/bsd-sockets/unix.lisp b/contrib/bsd-sockets/unix.lisp deleted file mode 100644 index 61cf005..0000000 --- a/contrib/bsd-sockets/unix.lisp +++ /dev/null @@ -1,40 +0,0 @@ -(in-package :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))) -