IF YOU HAVE A BINARY DISTRIBUTION:
-The two files that SBCL needs to run are sbcl and sbcl.core.
+The two files that SBCL needs to run, at minimum, are sbcl and sbcl.core.
They are in
src/runtime/sbcl
and
In order to get a usable system, you need to run sbcl in a way that
it can find sbcl.core. There are three ways for it to find
sbcl.core:
- 1. by default, in /usr/lib/sbcl.core or /usr/local/lib/sbcl.core
+
+ 1. by default, in /usr/lib/sbcl/sbcl.core or /usr/local/lib/sbcl/sbcl.core
2. by environment variable:
$ export SBCL_HOME=/foo/bar/
$ sbcl
So: the standard installation procedure is
1. Copy sbcl.core to /usr/lib or /usr/local/lib.
2. Copy sbcl to /usr/bin or /usr/local/bin.
- 3. Optionally copy sbcl.1 to /usr/man/man1 or /usr/local/man/man1.
-The script install.sh does these for you (choosing the /usr/local
-subdirectory in each case).
+ 3. Copy the contrib modules that you're using (if any) to the same place
+ as sbcl.core
+ 4. Optionally copy sbcl.1 to /usr/man/man1 or /usr/local/man/man1.
+
+The script install.sh does all of this for you, including compilation
+of all contrib modules it can find, and installation of all those that
+pass their tests. You should set the INSTALL_ROOT environment
+variable to /usr or /usr/local as appropriate before starting
+install.sh: e.g.
+
+ # INSTALL_ROOT=/usr/local sh install.sh
+
+or
+ $ INSTALL_ROOT=/home/me/sbcl sh install.sh
IF YOU HAVE A SOURCE DISTRIBUTION:
--- /dev/null
+Proposed contrib standard, version $Revision$
+
+The SBCL contrib mechanism is intended to provide a mechanism to
+manage code which does not form part of SBCL itself, but which is
+sufficiently closely associated with it that it would not be sensible
+to run it as a completely separate project. For example, alternative
+top-levels, foreign-function glue for calling out to libraries, editor
+support, etc. Portable ANSI code would not usually be considered for
+the contrib mechanism, unless it does something that is only useful in
+the context of SBCL.
+
+* Responsibilities
+
+The contrib directory is offered for code which is aimed primarily at
+SBCL users, and which has release cycles attuned with those of SBCL
+itself, but which the SBCL maintainers do not consider to be part of
+the core system. This being so, the primary responsibility for
+maintaining it remains with the provider of the system; the only
+commitment that SBCL maintainers make with respect to contrib code is
+to not install stale contrib code: a contrib that fails its test suite
+against a given version of SBCL will not be installed in that release.
+
+Note that despite leaving you the contrib maintainer with the
+responsibility of maintenance, we don't _necessarily_ (although we
+quite possibly would) offer you CVS access to the SBCL tree. This is
+because we can't do that without letting you write to the rest of the
+tree as well (at least as far as I know, at sourceforge).
+
+** Release cycle
+
+During the development cycle, changes to the core system may break
+contrib modules. This may indicate bugs in SBCL (which we will
+probably want to fix before release anyway) or that the contrib uses
+deprecated features or internal symbols.
+
+During the end-of-month freeze, core developers should avoid
+committing anything that breaks a previously working contrib module.
+Contrib maintainers should checkout the frozen SBCL version and
+submit patches where their contribs are broken.
+
+Contrib modules that still don't work at release time will not be
+installed.
+
+* Packaging
+
+Each contrib package lives in $ROOT/contrib/packagename, and will
+install into $(SBCL_HOME)/packagename
+
+A contrib package must contain a Makefile. This is to have three targets
+
+all: # do whatever compilation is necessary
+test: # run the package tests
+install: # copy all necessary files into $(INSTALL_DIR)
+
+If the contrib package involves more than one file, you are encouraged
+to use ASDF to build it and load it. A version of asdf is bundled as
+an SBCL contrib, which knows to look in $SBCL_HOME/systems/ for asd
+files - your install target should create an appropriate symlink there
+to the installed location of the system file. Look in bsd-sockets/Makefile
+for an example of an asdf-using contrib
+
+$(INSTALL_DIR) will have been created by the system before your
+install target is called. You do not need to make it yourself.
+
+* Tests
+
+You must provide a 'test' target in your package Makefile. This will
+be called to test whether your package is OK for installation, so if
+you have used SBCL internal interfaces or similar, this would be a
+good place to test that they still exist, etc.
+
+* Documentation
+
+[ Would be at least nice. My tendency is to say plain text or HTML,
+and optionally your choice of source format which can generate either
+of the preceding. Document formats not available on typical
+well-endowed-with-free-stuff Unix systems are discouraged. DocBook
+is fine, as the SBCL manual is DocBook anyway ]
+
+[ install.sh should copy the documentation somewhere that the user can
+find it ]
+
+* Lisp-level requirements
+
+An sbcl contrib should not stamp on sbcl internals or redefine symbols
+in CL, CL-USER. Sometimes this is the only way to do something,
+though: individual cases will be considered on their merits. A
+package that hacks undocumented(sic) interfaces may be accepted for
+contrib, but it does not follow from that that the interface is now
+published or will be preserved in future SBCL versions - contrib
+authors are encouraged instead to submit patches to SBCL that provide
+clean documented APIs which reasonably can be preserved. If in doubt,
+seek consensus on the sbcl-devel list
+
+A contrib must load into its own Lisp package(s) instead of polluting
+CL-USER or one of the system packages. The Lisp package name should
+be chosen in some way that has reasonable expectation of being unique.
+[We could potentially keep a registry of contrib archive name =>
+package name(s)]
+
+
--- /dev/null
+asdf.fasl: asdf.lisp
+ $(SBCL) --eval '(compile-file "asdf")' </dev/null
+
+test:
+ true
+
+install: asdf.fasl
+ cp $< $(INSTALL_DIR)
--- /dev/null
+;;; This is asdf: Another System Definition Facility. $Revision$
+;;;
+;;; Feedback, bug reports, and patches are all welcome: please mail to
+;;; <cclan-list@lists.sf.net>. But note first that the canonical
+;;; source for asdf is presently the cCLan CVS repository at
+;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
+;;;
+;;; If you obtained this copy from anywhere else, and you experience
+;;; trouble using it, or find bugs, you may want to check at the
+;;; location above for a more recent version (and for documentation
+;;; and test files, if your copy came without them) before reporting
+;;; bugs. There are usually two "supported" revisions - the CVS HEAD
+;;; is the latest development version, whereas the revision tagged
+;;; RELEASE may be slightly older but is considered `stable'
+
+;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; the problem with writing a defsystem replacement is bootstrapping:
+;;; we can't use defsystem to compile it. Hence, all in one file
+
+(defpackage #:asdf
+ (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
+ #:system-definition-pathname #:find-component ; miscellaneous
+
+ #:compile-op #:load-op #:load-source-op #:test-system-version
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
+
+ #:output-files #:perform ; operation methods
+ #:operation-done-p #:explain
+
+ #:component #:source-file
+ #:c-source-file #:cl-source-file #:java-source-file
+ #:static-file
+ #:doc-file
+ #:html-file
+ #:text-file
+ #:source-file-type
+ #:module ; components
+ #:system
+ #:unix-dso
+
+ #:module-components ; component accessors
+ #:component-pathname
+ #:component-relative-pathname
+ #:component-name
+ #:component-version
+ #:component-parent
+ #:component-property
+
+ #:component-depends-on
+
+ ;#:*component-parent-pathname*
+ #:*central-registry* ; variables
+
+ #:operation-error #:compile-failed #:compile-warned #:compile-error
+ #:system-definition-error
+ #:missing-component
+ #:missing-dependency
+ #:circular-dependency ; errors
+ )
+ (:use :cl))
+
+#+nil
+(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
+
+
+(in-package #:asdf)
+
+(defvar *asdf-revision* (let* ((v "$\Revision: 1.57 $")
+ (colon (position #\: v))
+ (dot (position #\. v)))
+ (and v colon dot
+ (list (parse-integer v :start (1+ colon)
+ :junk-allowed t)
+ (parse-integer v :start (1+ dot)
+ :junk-allowed t)))))
+
+(defvar *compile-file-warnings-behaviour* :warn)
+(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utility stuff
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test)) (if it ,then ,else)))
+
+(defun pathname-sans-name+type (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME and TYPE components"
+ (make-pathname :name nil :type nil :defaults pathname))
+
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; classes, condiitons
+
+(define-condition system-definition-error (error) ()
+ ;; [this use of :report should be redundant, but unfortunately it's not.
+ ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
+ ;; over print-object; this is always conditions::%print-condition for
+ ;; condition objects, which in turn does inheritance of :report options at
+ ;; run-time. fortunately, inheritance means we only need this kludge here in
+ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
+ #+cmu (:report print-object))
+
+(define-condition formatted-system-definition-error (system-definition-error)
+ ((format-control :initarg :format-control :reader format-control)
+ (format-arguments :initarg :format-arguments :reader format-arguments))
+ (:report (lambda (c s)
+ (apply #'format s (format-control c) (format-arguments c)))))
+
+(define-condition circular-dependency (system-definition-error)
+ ((components :initarg :components :reader circular-dependency-components)))
+
+(define-condition missing-component (system-definition-error)
+ ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
+ (version :initform nil :reader missing-version :initarg :version)
+ (parent :initform nil :reader missing-parent :initarg :parent)))
+
+(define-condition missing-dependency (missing-component)
+ ((required-by :initarg :required-by :reader missing-required-by)))
+
+(define-condition operation-error (error)
+ ((component :reader error-component :initarg :component)
+ (operation :reader error-operation :initarg :operation))
+ (:report (lambda (c s)
+ (format s "Erred while invoking ~A on ~A"
+ (error-operation c) (error-component c)))))
+(define-condition compile-error (operation-error) ())
+(define-condition compile-failed (compile-error) ())
+(define-condition compile-warned (compile-error) ())
+
+(defclass component ()
+ ((name :type string :accessor component-name :initarg :name :documentation
+ "Component name, restricted to portable pathname characters")
+ (version :accessor component-version :initarg :version)
+ (in-order-to :initform nil :initarg :in-order-to)
+ ;;; XXX crap name
+ (do-first :initform nil :initarg :do-first)
+ ;; methods defined using the "inline" style inside a defsystem form:
+ ;; need to store them somewhere so we can delete them when the system
+ ;; is re-evaluated
+ (inline-methods :accessor component-inline-methods :initform nil)
+ (parent :initarg :parent :initform nil :reader component-parent)
+ ;; no direct accessor for pathname, we do this as a method to allow
+ ;; it to default in funky ways if not supplied
+ (relative-pathname :initarg :pathname)
+ (operation-times :initform (make-hash-table )
+ :accessor component-operation-times)
+ ;; XXX we should provide some atomic interface for updating the
+ ;; component properties
+ (properties :accessor component-properties :initarg :properties
+ :initform nil)))
+
+;;;; methods: conditions
+
+(defmethod print-object ((c missing-dependency) s)
+ (call-next-method)
+ (format s ", required by ~A" (missing-required-by c)))
+
+(defun sysdef-error (format &rest arguments)
+ (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
+
+;;;; methods: components
+
+(defmethod print-object ((c missing-component) s)
+ (format s "Component ~S not found" (missing-requires c))
+ (when (missing-version c)
+ (format s " or does not match version ~A" (missing-version c)))
+ (when (missing-parent c)
+ (format s " in ~A" (component-name (missing-parent c)))))
+
+(defgeneric component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defmethod component-system ((component component))
+ (aif (component-parent component)
+ (component-system it)
+ component))
+
+(defmethod print-object ((c component) stream)
+ (print-unreadable-object (c stream :type t :identity t)
+ (ignore-errors
+ (prin1 (component-name c) stream))))
+
+(defclass module (component)
+ ((components :initform nil :accessor module-components :initarg :components)
+ ;; what to do if we can't satisfy a dependency of one of this module's
+ ;; components. This allows a limited form of conditional processing
+ (if-component-dep-fails :initform :fail
+ :accessor module-if-component-dep-fails
+ :initarg :if-component-dep-fails)
+ (default-component-class :accessor module-default-component-class
+ :initform 'cl-source-file :initarg :default-component-class)))
+
+(defgeneric component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defun component-parent-pathname (component)
+ (aif (component-parent component)
+ (component-pathname it)
+ *default-pathname-defaults*))
+
+(defgeneric component-relative-pathname (component)
+ (:documentation "Extracts the relative pathname applicable for a particular component."))
+
+(defmethod component-relative-pathname ((component module))
+ (or (slot-value component 'relative-pathname)
+ (make-pathname
+ :directory `(:relative ,(component-name component))
+ :host (pathname-host (component-parent-pathname component)))))
+
+(defmethod component-pathname ((component component))
+ (let ((*default-pathname-defaults* (component-parent-pathname component)))
+ (merge-pathnames (component-relative-pathname component))))
+
+(defgeneric component-property (component property))
+
+(defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties))))
+
+(defgeneric (setf component-property) (new-value component property))
+
+(defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties))))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties))))))
+
+
+
+(defclass system (module)
+ ((description :accessor system-description :initarg :description)
+ (long-description :accessor long-description :initarg :long-description)
+ (author :accessor system-author :initarg :author)
+ (maintainer :accessor system-maintainer :initarg :maintainer)
+ (licence :accessor system-licence :initarg :licence)))
+
+;;; version-satisfies
+
+;;; with apologies to christophe rhodes ...
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ (flet ((is-ws (char) (find char ws)))
+ (nreverse
+ (let ((list nil) (start 0) (words 0) end)
+ (loop
+ (when (and max (>= words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
+
+(defgeneric version-satisfies (component version))
+
+(defmethod version-satisfies ((c component) version)
+ (unless (and version (slot-boundp c 'version))
+ (return-from version-satisfies t))
+ (let ((x (mapcar #'parse-integer
+ (split (component-version c) nil '(#\.))))
+ (y (mapcar #'parse-integer
+ (split version nil '(#\.)))))
+ (labels ((bigger (x y)
+ (cond ((not y) t)
+ ((not x) nil)
+ ((> (car x) (car y)) t)
+ ((= (car x) (car y))
+ (bigger (cdr x) (cdr y))))))
+ (and (= (car x) (car y))
+ (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding systems
+
+(defvar *defined-systems* (make-hash-table :test 'equal))
+(defun coerce-name (name)
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "Invalid component designator ~A" name))))
+
+(defun system-definition-pathname (system)
+ (some (lambda (x) (funcall x system))
+ *system-definition-search-functions*))
+
+(defun sysdef-central-registry-search (system)
+ (let ((name (coerce-name system)))
+ (block nil
+ (dolist (dir *central-registry*)
+ (let* ((defaults (eval dir))
+ (file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local))))
+ (if (and file (probe-file file))
+ (return file)))))))
+
+
+(defvar *central-registry*
+ '(*default-pathname-defaults*
+ #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
+ #+nil "telent:asdf;systems;"))
+
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions*
+ '(sysdef-central-registry-search))
+
+(defun find-system (name &optional (error-p t))
+ (let* ((name (coerce-name name))
+ (in-memory (gethash name *defined-systems*))
+ (on-disk (system-definition-pathname name)))
+ (when (and on-disk
+ (or (not in-memory)
+ (< (car in-memory) (file-write-date on-disk))))
+ (let ((*package* (make-package (gensym (package-name #.*package*))
+ :use '(:cl :asdf))))
+ (format t ";;; Loading system definition from ~A into ~A~%"
+ on-disk *package*)
+ (load on-disk)))
+ (let ((in-memory (gethash name *defined-systems*)))
+ (if in-memory
+ (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
+ (cdr in-memory))
+ (if error-p (error 'missing-component :requires name))))))
+
+(defun register-system (name system)
+ (format t "Registering ~A as ~A ~%" system name)
+ (setf (gethash (coerce-name name) *defined-systems*)
+ (cons (get-universal-time) system)))
+
+(defun system-registered-p (name)
+ (gethash (coerce-name name) *defined-systems*))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding components
+
+(defgeneric find-component (module name &optional version)
+ (:documentation "Finds the component with name NAME present in the
+MODULE module; if MODULE is nil, then the component is assumed to be a
+system."))
+
+(defmethod find-component ((module module) name &optional version)
+ (if (slot-boundp module 'components)
+ (let ((m (find name (module-components module)
+ :test #'equal :key #'component-name)))
+ (if (and m (version-satisfies m version)) m))))
+
+
+;;; a component with no parent is a system
+(defmethod find-component ((module (eql nil)) name &optional version)
+ (let ((m (find-system name nil)))
+ (if (and m (version-satisfies m version)) m)))
+
+;;; component subclasses
+
+(defclass source-file (component) ())
+
+(defclass cl-source-file (source-file) ())
+(defclass c-source-file (source-file) ())
+(defclass java-source-file (source-file) ())
+(defclass static-file (source-file) ())
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file) ())
+
+(defgeneric source-file-type (component system))
+(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
+(defmethod source-file-type ((c c-source-file) (s module)) "c")
+(defmethod source-file-type ((c java-source-file) (s module)) "java")
+(defmethod source-file-type ((c html-file) (s module)) "html")
+(defmethod source-file-type ((c static-file) (s module)) nil)
+
+(defmethod component-relative-pathname ((component source-file))
+ (let ((*default-pathname-defaults* (component-parent-pathname component)))
+ (or (slot-value component 'relative-pathname)
+ (make-pathname :name (component-name component)
+ :type
+ (source-file-type component
+ (component-system component))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; operations
+
+;;; one of these is instantiated whenever (operate ) is called
+
+(defclass operation ()
+ ((forced-p :initform nil :initarg :force :accessor operation-forced-p )
+ (original-initargs :initform nil :initarg :original-initargs
+ :accessor operation-original-initargs)
+ (visited-nodes :initform nil :accessor operation-visited-nodes)
+ (visiting-nodes :initform nil :accessor operation-visiting-nodes)
+ (parent :initform nil :initarg :parent :accessor operation-parent)))
+
+(defmethod shared-initialize :after ((operation operation) slot-names
+ &key force
+ &allow-other-keys)
+ (declare (ignore slot-names force))
+ ;; empty method to disable initarg validity checking
+ )
+
+(defgeneric perform (operation component))
+(defgeneric operation-done-p (operation component))
+(defgeneric explain (operation component))
+(defgeneric output-files (operation component))
+(defgeneric input-files (operation component))
+
+(defun node-for (o c)
+ (cons (class-name (class-of o)) c))
+
+(defgeneric operation-ancestor (operation)
+ (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
+
+(defmethod operation-ancestor ((operation operation))
+ (aif (operation-parent operation)
+ (operation-ancestor it)
+ operation))
+
+(defun make-sub-operation (o type)
+ (let ((args (operation-original-initargs o)))
+ (apply #'make-instance type :parent o :original-initargs args args)))
+
+(defgeneric visit-component (operation component data))
+
+(defmethod visit-component ((o operation) (c component) data)
+ (unless (component-visited-p o c)
+ (push (cons (node-for o c) data)
+ (operation-visited-nodes (operation-ancestor o)))))
+
+(defgeneric component-visited-p (operation component))
+
+(defmethod component-visited-p ((o operation) (c component))
+ (assoc (node-for o c)
+ (operation-visited-nodes (operation-ancestor o))
+ :test 'equal))
+
+(defgeneric (setf visiting-component) (new-value operation component))
+
+(defmethod (setf visiting-component) (new-value operation component)
+ ;; MCL complains about unused lexical variables
+ (declare (ignorable new-value operation component)))
+
+(defmethod (setf visiting-component) (new-value (o operation) (c component))
+ (let ((node (node-for o c))
+ (a (operation-ancestor o)))
+ (if new-value
+ (pushnew node (operation-visiting-nodes a) :test 'equal)
+ (setf (operation-visiting-nodes a)
+ (remove node (operation-visiting-nodes a) :test 'equal)))))
+
+(defgeneric component-visiting-p (operation component))
+
+(defmethod component-visiting-p ((o operation) (c component))
+ (let ((node (cons o c)))
+ (member node (operation-visiting-nodes (operation-ancestor o))
+ :test 'equal)))
+
+(defgeneric component-depends-on (operation component))
+
+(defmethod component-depends-on ((o operation) (c component))
+ (cdr (assoc (class-name (class-of o))
+ (slot-value c 'in-order-to))))
+
+(defmethod component-self-dependencies ((o operation) (c component))
+ (let ((all-deps (component-depends-on o c)))
+ (remove-if-not (lambda (x)
+ (member (component-name c) (cdr x) :test #'string=))
+ all-deps)))
+
+(defmethod input-files ((operation operation) (c component))
+ (let ((parent (component-parent c))
+ (self-deps (component-self-dependencies operation c)))
+ (if self-deps
+ (mapcan (lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
+ self-deps)
+ ;; no previous operations needed? I guess we work with the
+ ;; original source file, then
+ (list (component-pathname c)))))
+
+(defmethod input-files ((operation operation) (c module)) nil)
+
+(defmethod operation-done-p ((o operation) (c component))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c)))
+ (cond ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much
+ t)
+ ((not out-files)
+ (let ((op-done
+ (gethash (type-of o)
+ (component-operation-times c))))
+ (and op-done
+ (>= op-done
+ (or (apply #'max
+ (mapcar #'file-write-date in-files)) 0)))))
+ ((not in-files) nil)
+ (t
+ (and
+ (every #'probe-file out-files)
+ (> (apply #'min (mapcar #'file-write-date out-files))
+ (apply #'max (mapcar #'file-write-date in-files)) ))))))
+
+;;; So you look at this code and think "why isn't it a bunch of
+;;; methods". And the answer is, because standard method combination
+;;; runs :before methods most->least-specific, which is back to front
+;;; for our purposes. And CLISP doesn't have non-standard method
+;;; combinations, so let's keep it simple and aspire to portability
+
+(defgeneric traverse (operation component))
+(defmethod traverse ((operation operation) (c component))
+ (let ((forced nil))
+ (labels ((do-one-dep (required-op required-c required-v)
+ (let ((op (if (subtypep (type-of operation) required-op)
+ operation
+ (make-sub-operation operation required-op)))
+ (dep-c (or (find-component
+ (component-parent c)
+ ;; XXX tacky. really we should build the
+ ;; in-order-to slot with canonicalized
+ ;; names instead of coercing this late
+ (coerce-name required-c) required-v)
+ (error 'missing-dependency :required-by c
+ :version required-v
+ :requires required-c))))
+ (traverse op dep-c)))
+ (do-dep (op dep)
+ (cond ((eq op 'feature)
+ (or (member (car dep) *features*)
+ (error 'missing-dependency :required-by c
+ :requires (car dep) :version nil)))
+ (t
+ (dolist (d dep)
+ (cond ((consp d)
+ (assert (string-equal
+ (symbol-name (first d))
+ "VERSION"))
+ (appendf forced
+ (do-one-dep op (second d) (third d))))
+ (t
+ (appendf forced (do-one-dep op d nil)))))))))
+ (aif (component-visited-p operation c)
+ (return-from traverse
+ (if (cdr it) (list (cons 'pruned-op c)) nil)))
+ ;; dependencies
+ (if (component-visiting-p operation c)
+ (error 'circular-dependency :components (list c)))
+ (setf (visiting-component operation c) t)
+ (loop for (required-op . deps) in (component-depends-on operation c)
+ do (do-dep required-op deps))
+ ;; constituent bits
+ (let ((module-ops
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ (error nil))
+ (loop for kid in (module-components c)
+ do (handler-case
+ (appendf forced (traverse operation kid ))
+ (missing-dependency (condition)
+ (if (eq (module-if-component-dep-fails c) :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c) :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ (when (or forced module-ops
+ (operation-forced-p (operation-ancestor operation))
+ (not (operation-done-p operation c)))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (slot-value c 'do-first)))))
+ (loop for (required-op . deps) in do-first
+ do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c))))))
+ (setf (visiting-component operation c) nil)
+ (visit-component operation c (and forced t))
+ forced)))
+
+
+(defmethod perform ((operation operation) (c source-file))
+ (sysdef-error
+ "Required method PERFORM not implemented for operation ~A, component ~A"
+ (class-of operation) (class-of c)))
+
+(defmethod perform ((operation operation) (c module))
+ nil)
+
+(defmethod explain ((operation operation) (component component))
+ (format *trace-output* "~&;;; ~A on ~A~%"
+ operation component))
+
+;;; compile-op
+
+(defclass compile-op (operation)
+ ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
+ (on-warnings :initarg :on-warnings :accessor operation-on-warnings
+ :initform *compile-file-warnings-behaviour*)
+ (on-failure :initarg :on-failure :accessor operation-on-failure
+ :initform *compile-file-failure-behaviour*)))
+
+(defmethod perform :before ((operation compile-op) (c source-file))
+ (map nil #'ensure-directories-exist (output-files operation c)))
+
+(defmethod perform :after ((operation operation) (c component))
+ (setf (gethash (type-of operation) (component-operation-times c))
+ (get-universal-time)))
+
+;;; perform is required to check output-files to find out where to put
+;;; its answers, in case it has been overridden for site policy
+(defmethod perform ((operation compile-op) (c cl-source-file))
+ (let ((source-file (component-pathname c))
+ (output-file (car (output-files operation c))))
+ (multiple-value-bind (output warnings-p failure-p)
+ (compile-file source-file
+ :output-file output-file)
+ ;(declare (ignore output))
+ (when warnings-p
+ (case (operation-on-warnings operation)
+ (:warn (warn "COMPILE-FILE warned while performing ~A on ~A"
+ c operation))
+ (:error (error 'compile-warned :component c :operation operation))
+ (:ignore nil)))
+ (when failure-p
+ (case (operation-on-failure operation)
+ (:warn (warn "COMPILE-FILE failed while performing ~A on ~A"
+ c operation))
+ (:error (error 'compile-failed :component c :operation operation))
+ (:ignore nil)))
+ (unless output
+ (error 'compile-error :component c :operation operation)))))
+
+(defmethod output-files ((operation compile-op) (c cl-source-file))
+ (list (compile-file-pathname (component-pathname c))))
+
+(defmethod perform ((operation compile-op) (c static-file))
+ nil)
+
+(defmethod output-files ((operation compile-op) (c static-file))
+ nil)
+
+;;; load-op
+
+(defclass load-op (operation) ())
+
+(defmethod perform ((o load-op) (c cl-source-file))
+ (mapcar #'load (input-files o c)))
+
+(defmethod perform ((operation load-op) (c static-file))
+ nil)
+(defmethod operation-done-p ((operation load-op) (c static-file))
+ t)
+
+(defmethod output-files ((o operation) (c component))
+ nil)
+
+(defmethod component-depends-on ((operation load-op) (c component))
+ (cons (list 'compile-op (component-name c))
+ (call-next-method)))
+
+;;; load-source-op
+
+(defclass load-source-op (operation) ())
+
+(defmethod perform ((o load-source-op) (c cl-source-file))
+ (load (component-pathname c)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; invoking operations
+
+(defun operate (operation-class system &rest args)
+ (let* ((op (apply #'make-instance operation-class
+ :original-initargs args args))
+ (system (if (typep system 'component) system (find-system system)))
+ (steps (traverse op system)))
+ (with-compilation-unit ()
+ (loop for (op . component) in steps do
+ (loop
+ (restart-case
+ (progn (perform op component)
+ (return))
+ (retry-component ())
+ (skip-component () (return))))))))
+
+(defun oos (&rest args)
+ "Alias of OPERATE function"
+ (apply #'operate args))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; syntax
+
+(defun remove-keyword (key arglist)
+ (labels ((aux (key arglist)
+ (cond ((null arglist) nil)
+ ((eq key (car arglist)) (cddr arglist))
+ (t (cons (car arglist) (cons (cadr arglist)
+ (remove-keyword
+ key (cddr arglist))))))))
+ (aux key arglist)))
+
+(defmacro defsystem (name &body options)
+ (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+ (let ((component-options (remove-keyword :class options)))
+ `(progn
+ ;; system must be registered before we parse the body, otherwise
+ ;; we recur when trying to find an existing system of the same name
+ ;; to reuse options (e.g. pathname) from
+ (let ((s (system-registered-p ',name)))
+ (cond ((and s (eq (type-of (cdr s)) ',class))
+ (setf (car s) (get-universal-time)))
+ (s
+ #+clisp
+ (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
+ #-clisp
+ (change-class (cdr s) ',class))
+ (t
+ (register-system (quote ,name)
+ (make-instance ',class :name ',name)))))
+ (parse-component-form nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ (or ,pathname
+ (pathname-sans-name+type
+ (resolve-symlinks *load-truename*))
+ *default-pathname-defaults*)
+ ',component-options))))))
+
+
+(defun class-for-type (parent type)
+ (let ((class (find-class
+ (or (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type) #.*package*)) nil)))
+ (or class
+ (and (eq type :file)
+ (or (module-default-component-class parent)
+ (find-class 'cl-source-file)))
+ (sysdef-error "Don't recognize component type ~A" type))))
+
+(defun maybe-add-tree (tree op1 op2 c)
+ "Add the node C at /OP1/OP2 in TREE, unless it's there already.
+Returns the new tree (which probably shares structure with the old one)"
+ (let ((first-op-tree (assoc op1 tree)))
+ (if first-op-tree
+ (progn
+ (aif (assoc op2 (cdr first-op-tree))
+ (if (find c (cdr it))
+ nil
+ (setf (cdr it) (cons c (cdr it))))
+ (setf (cdr first-op-tree)
+ (acons op2 (list c) (cdr first-op-tree))))
+ tree)
+ (acons op1 (list (list op2 c)) tree))))
+
+(defun union-of-dependencies (&rest deps)
+ (let ((new-tree nil))
+ (dolist (dep deps)
+ (dolist (op-tree dep)
+ (dolist (op (cdr op-tree))
+ (dolist (c (cdr op))
+ (setf new-tree
+ (maybe-add-tree new-tree (car op-tree) (car op) c))))))
+ new-tree))
+
+
+(defun remove-keys (key-names args)
+ (loop for ( name val ) on args by #'cddr
+ unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ append (list name val)))
+
+(defun parse-component-form (parent options)
+ (destructuring-bind
+ (type name &rest rest &key
+ ;; the following list of keywords is reproduced below in the
+ ;; remove-keys form. important to keep them in sync
+ components pathname default-component-class
+ perform explain output-files operation-done-p
+ depends-on serialize in-order-to
+ ;; list ends
+ &allow-other-keys) options
+ (declare (ignore serialize))
+ ;; XXX add dependencies for serialized subcomponents
+ (let* ((other-args (remove-keys
+ '(components pathname default-component-class
+ perform explain output-files operation-done-p
+ depends-on serialize in-order-to)
+ rest))
+ (ret
+ (or (find-component parent name)
+ (make-instance (class-for-type parent type)))))
+ (apply #'reinitialize-instance
+ ret
+ :name (coerce-name name)
+ :pathname pathname
+ :parent parent
+ :in-order-to (union-of-dependencies
+ in-order-to
+ `((compile-op (compile-op ,@depends-on))
+ (load-op (load-op ,@depends-on))))
+ :do-first `((compile-op (load-op ,@depends-on)))
+ other-args)
+ (when (typep ret 'module)
+ (setf (module-default-component-class ret)
+ (or default-component-class
+ (and (typep parent 'module)
+ (module-default-component-class parent)))))
+ (when components
+ (setf (module-components ret)
+ (mapcar (lambda (x) (parse-component-form ret x)) components)))
+ (loop for (n v) in `((perform ,perform) (explain ,explain)
+ (output-files ,output-files)
+ (operation-done-p ,operation-done-p))
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m) (remove-method (symbol-function n) m))
+ (component-inline-methods ret))
+ when v
+ do (destructuring-bind (op qual (o c) &body body) v
+ (pushnew
+ (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret))))
+ ret)))
+
+
+(defun resolve-symlinks (path)
+ #-allegro (truename path)
+ #+allegro (excl:pathname-resolve-symbolic-links path)
+ )
+
+;;; optional extras
+
+;;; run-shell-command functions for other lisp implementations will be
+;;; gratefully accepted, if they do the same thing. If the docstring
+;;; is ambiguous, send a bug report
+
+(defun run-shell-command (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*. Returns the shell's exit code."
+ (let ((command (apply #'format nil control-string args)))
+ (format *trace-output* "; $ ~A~%" command)
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *trace-output*))
+
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *trace-output*))
+
+ #+allegro
+ (excl:run-shell-command command :input nil :output *trace-output*)
+
+ #+lispworks
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :output-stream *trace-output*)
+
+ #+clisp ;XXX not exactly *trace-output*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+
+ #+openmcl
+ (nth-value 1
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output *trace-output*
+ :wait t)))
+
+ #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+ (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ ))
+
+(pushnew :asdf *features*)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
+ (pushnew :sbcl-hooks-require *features*)))
+
+#+(and sbcl sbcl-hooks-require)
+(progn
+ (defun module-provide-asdf (name)
+ (asdf:operate 'asdf:load-op name)
+ (provide name))
+
+ (pushnew
+ (merge-pathnames "systems/"
+ (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ *central-registry*)
+
+ (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
--- /dev/null
+Frequently Asked Questions
+
+Q1) Is this the same thing as db-sockets
+
+A1) Basically, yes. It's hoped that bundling it as a contrib may make
+it easier for people to install.
+
+Q2) What are these test things? How do I run the tests?
+
+A2) Some of the tests get run automatically when the package is built
+- if the tests fail, the package is not installed. The rest of the
+tests depend on having Internet access which may not always be the
+case on a build machine, but you can run them by hand from the Lisp
+listener, if you want to:
+
+* (rt:do-tests)
+
+This uses the regression tester from the CMU AI repository to run the
+tests defined in tests.lisp. You should not get any test failures,
+unless -
+
+a) your "echo" services are disabled in inetd.conf -
+SIMPLE-TCP-CLIENT and SIMPLE-UDP-CLIENT both attempt to connect to the
+echo port.
+
+b) you're not on the internet - SIMPLE-HTTP-CLIENT attempts to connect to
+ww.telent.net, and other tests do DNS lookups for well-known hosts
+
+c) a.root-servers.net has moved IP address
+
+Q3) What's constants.lisp-temp?
+
+A3) Many of the structure offsets and symbolic constants vary between
+architectures and operating systems. To avoid a maintenance
+nightmare, we derive them automatically by creating and running a
+small C program. The C program is created by def-to-lisp.lisp
+with input from constants.lisp
+
+Some of the exciting stuff in bsd-sockets.asd writes a C program in
+/tmp, compiles it, and runs it. The output from this program becomes
+constants.lisp-temp
+
+Q4) Is this compatible with ACL? With CMUCL's internet.lisp?
+
+A4) No. This is a sufficiently low-level interface that either could
+be built on top of it, though. Actually, theq ACL-COMPAT library that
+comes with Portable Allegroserve may already have this.
--- /dev/null
+SYSTEM=bsd-sockets
+
+all:
+ $(MAKE) -C ../asdf
+ echo "(asdf:operate 'asdf:load-op :$(SYSTEM))" | \
+ $(SBCL) --eval '(load "../asdf/asdf")'
+
+test:
+ true
+
+install: all
+ tar cf - . | ( cd $(INSTALL_DIR) && tar xpvf - )
+ ( cd $(SBCL_HOME)/systems && ln -fs ../$(SYSTEM)/$(SYSTEM).asd . )
--- /dev/null
+Changes in 0.58 - Sun Jan 12 00:53:53 GMT 2003
+
+Fix db-sockets.asd so that it doesn't recompile alien.so every single
+time.
+
+Announce anon-cvs repo for people to get in-between versions
+
+MSG_NOSIGNAL is a linuxism, I'm told.
+
+Changes in 0.57 - Wed Sep 11 12:27:32 2002
+
+Fix for compilation bug reported by Andreas Fuchs. Don't use 0.56, it
+was a mistakenly uploaded file
+
+Changes in 0.55 - Tue Sep 10 23:42:27 2002
+
+Fix for a unix-domain sockets problem, courtesy of David Lichteblau
+
+Changes in 0.54 - Wed Mar 6 2002
+
+New version mostly due to new packaging format: this is now a
+vendor-neutral cclan (vn-cclan) package. See INSTALL file
+
+Fixed bug in af_file support.
+
+Changes in 0.53 - Thu Jan 31 2002
+
+By popular request (two people, at last count) this works in CMUCL again.
+Also, some documentation updates, a really silly bug in make-instance
+fixed, and support for the TCP_NODELAY socket option
+
+Changes in 0.52 - Tue Jan 8 2002
+
+Very few. This release was put out a few days after 0.5.1 because
+0.5.1 is less than 0.42, and various packaging tools tend to get
+confused to see version numbers go backwards.
+
+Changes in 0.5.1 - Mon Jan 7 2002
+
+Support for AF_FILE (formerly known as Unix-domain) sockets; both
+stream and datagram.
+
+MAKE-INET-SOCKET has been deprecated (but is still there). New code is
+encouraged to write (make-instance 'inet-socket ...) instead
+
+Fairly pervasive low-level changes to avoid leaking quite as much
+memory. May also have fixed a file descriptor leak in the process.
+
+Changes in 0.42
+
+Repackaged to be a debian-like package, and use
+common-lisp-controller, which required a reasonably large amount of
+thrashing around renaming files and so on.
+
+New function GET-HOST-BY-ADDRESS returns a HOST-ENT just like
+GET-HOST-BY-NAME does.
+
+Tested on SBCL 0.6.12.7.flaky1.1 (x86), SBCL 0.6.12.7 (Alpha),
+CMUCL 18c+ 2.5.2 (x86)
+
+Changes in 0.41 - Sun Jan 7 2001
+
+Cleanups in the tests for more intelligible failure messages
+
+SOCKET-ERROR conditions now inherit from ERROR not CONDITION - as
+otherwise IGNORE-ERROR doesn't ignore them, which is unexpected
+
+Tested on debian cmucl 2.4.19 , sbcl pre-0.6.9 snapshot of Nov 30 2000.
+
+The latter doesn't build without manual intervention:
+
+ error in function SB-C::%DEFCONSTANT:
+ The constant INET-ADDRESS-ANY is being redefined.
+
+(just continue)
+
+Changes in 0.4 - Mon Jul 3 2000
+
+Now works (passes tests) in
+
+- Solaris 2.6 SPARC (CMUCL 18b)
+- Debian x86 GNU/Linux (Debian CMUCL 2.4.19)
+- Debian x86 GNU/Linux (SBCL 0.6.5)
+
+Some CMUCL-on-FreeBSD changes (mostly involve commenting stuff out). Doesn't
+work, though (but might in SBCL/FreeBSD)
+
+The Solaris changes comprised disabling bits and fixing an
+endianness problem.
+
+
+Changes in 0.37 - Sat May 20 2000
+
+
+Changes from Martin Atzmueller to make it compile more cleanly in SBCL
+
+Changes in 0.36 - Thu May 11 2000
+
+Some documentation cleanups
+
+New functions NON-BLOCKING-MODE and (SETF NON-BLOCKING-MODE)
+
+EINTR now generates a INTERRUPTED-ERROR condition
+
+
+Changes in 0.35 - Mon May 1 2000
+
+
+MAKE-INET-SOCKET now can take a keyword for PROTOCOL: it lowercases
+the symbol's name, then looks it up using GET-PROTOCOL-BY-NAME
+
+A bad bug in the CMUCL code (which caused the EXTENSIONS package to
+disappear - oops...) was found and fixed
+
+
+Changes in 0.3 - Apr 17 2000
+
+Now works with SBCL (0.6.1, 0.6.2) in addition to CMUCL.
+
+Fixed to actually work with a READ-SEQUENCE implementation that does
+the right thing instead of the (suspected buggy) implementation in
+CMUCL. At least, the Hyperspec doesn't give me any particular cause
+for belief that READ-SEQUENCE can return before reading as much as the
+user asks it to, which is what we were using it for hitherto.
+
+The Makefile got a lot bigger. defs-to-lisp.lisp got a lot smaller.
+
+Standard make target creates "sockets-system.x86f" which contains all
+the code in a single file
+
+If you want to build it on SBCL you'll need a working defsystem for
+said platform first. This involves some fiddling around: first you
+need to get it from CLOCC on Sourceforge then you need to patch it
+with this diff. Unless you're looking at a version newer than 1.12, in
+which case they might have patched it already before you
--- /dev/null
+o/~ Hey Mr Tambourine Man, play some -*- Text -*- for me o/~
+
+A semi-sane sockets interface for SBCL. Usually also works in CMUCL,
+but is rarely actually tested there so may require some massaging
+
+See INSTALL for prerequisites and build details
+
+It uses the regression tester from the CMU AI repository. This is
+bundled in the file rt.lisp which is unchanged except where I added a
+DEFPACKAGE form. The tests themselves are in tests.lisp, and can be
+run using the Makefile target intended for the purpose, or by
+evaluating (rt:do-tests). Note that one of the tests is an HTTP
+client that connects back to ww.telent.net; if this bothers your
+expectations of privacy, don't run it.
+
+There is an automatically generated API reference in
+api-reference.html which you can regenerate if you can figure out how
+doc.lisp works. You might find the examples in tests.lisp useful,
+too.
+
+Feedback, patches, development versions
+
+Instructions on how to access the CVS repository for db-sockets are
+at http://cvs.telent.net/
+
+If you find bugs or want to send patches for enhancements, by email to
+Daniel Barlow <dan@telent.net>, but please check the CVS version first.
+
+$Id$
--- /dev/null
+
+Things To Do - Urgent! (with apologies to Douglas Adams)
+
+I probably have opinions about how to do most of these. Even if not,
+I almost certainly have opinions on how not to. Send me a proposal
+before spending serious amounts of time on it.
+
+- the rest of the functions. A socket-send that doesn't use streams
+would be a good one
+
+- the rest of the errors
+
+- the rest of the socket options: integer and boolean socket-level
+options are in but need odd ones, plus tcp, udp, ip
+
+- async name service lookups.
+
+- write tests for socket-name and socket-peername
+
+- documentation: see doc.lisp, but beware: it's grotty.
--- /dev/null
+#include <netdb.h>
+
+int get_h_errno()
+{
+ return h_errno;
+}
--- /dev/null
+/* create a .o file with undefined references to all the C stuff we need
+ * that cmucl hasn't already fouind for us. Not needed on Linux/i386
+ * because it has dynamic loading anyway
+ */
+
+void likewecare() {
+ getprotobyname();
+}
+
--- /dev/null
+<html><head><title>db-sockets API Reference</title></head><body>
+<h1>Package SOCKETS</h1>
+
+<P>
+A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD
+socket API for C and Graham Barr's IO::Socket classes for Perl.
+<P>
+We represent sockets as CLOS objects, and rename a lot of methods and
+arguments to fit Lisp style more closely.
+<P>
+
+<P>
+<h2>Contents</h2>
+<P>
+<ol>
+<li> General concepts
+<li> Methods applicable to all <a href="#socket">sockets</a>
+<li> <a href="#sockopt">Socket Options</a>
+<li> Methods applicable to a particular subclass
+<ol>
+<li> <a href="#internet">INET-SOCKET</a> - Internet Protocol (TCP, UDP, raw) sockets
+<li> Methods on <a href="#UNIX-SOCKET">UNIX-SOCKET</a> - Unix-domain sockets
+</ol>
+<li> <a href="#name-service">Name resolution</a> (DNS, /etc/hosts, &c)
+</ol>
+<P>
+<h2>General concepts</h2>
+<P>
+<p>Most of the functions are modelled on the BSD socket API. BSD sockets
+are widely supported, portably <i>(well, fairly portably)</i>
+available on a variety of systems, and documented. There are some
+differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly
+<P>
+<ul>
+<li> Where the C API would typically return -1 and set errno, db-sockets
+signals an error. All the errors are subclasses of SOCKET-CONDITION
+and generally correspond one for one with possible <tt>errno</tt> values
+<P>
+<li> We use multiple return values in many places where the C API would use p[ass-by-reference values
+<P>
+<li> We can often avoid supplying an explicit <i>length</i> argument to
+functions because we already know how long the argument is.
+<P>
+<li> IP addresses and ports are represented in slightly friendlier fashion
+than "network-endian integers". See the section on <a href="#internet"
+>Internet domain</a> sockets for details.
+</ul>
+<P>
+<P>
+<hr> <h2>SOCKETs</h2>
+<P>
+<p><a name="SOCKET"><i>Class: </i><b>SOCKET</b></a>
+<p><b>Slots:</b><ul><li>FILE-DESCRIPTOR : </li>
+<li>FAMILY : </li>
+<li>PROTOCOL : </li>
+<li>TYPE : </li>
+<li>STREAM : </li>
+</ul><p><a name="SOCKET-BIND"><table width="100%"><tr><td width="80%">(socket-bind <i> (s <a href="#socket">socket</a>) &rest address</i>)</td><td align=right>Generic Function</td></tr></table>
+<p><a name="SOCKET-ACCEPT"><table width="100%"><tr><td width="80%">(socket-accept <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Perform the accept(2) call, returning a newly-created connected socket
+and the peer address as multiple values</blockquote>
+<p><a name="SOCKET-CONNECT"><table width="100%"><tr><td width="80%">(socket-connect <i> (s <a href="#socket">socket</a>) &rest address</i>)</td><td align=right>Generic Function</td></tr></table>
+<p><a name="SOCKET-PEERNAME"><table width="100%"><tr><td width="80%">(socket-peername <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Return the socket's peer; depending on the address family this may return multiple values</blockquote>
+<p><a name="SOCKET-NAME"><table width="100%"><tr><td width="80%">(socket-name <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Return the address (as vector of bytes) and port that the socket is bound to, as multiple values</blockquote>
+<p><a name="SOCKET-RECEIVE"><table width="100%"><tr><td width="80%">(socket-receive <i> (socket <a href="#socket">socket</a>) buffer length &key oob peek waitall (element-type
+ 'character)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Read LENGTH octets from <a href="#SOCKET">SOCKET</a> into BUFFER (or a freshly-consed buffer if
+NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
+used, so at least one of these two arguments must be non-NIL. If
+BUFFER is supplied, it had better be of an element type one octet wide.
+Returns the buffer, its length, and the address of the peer
+that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
+so that the actual packet length is returned even if the buffer was too
+small</blockquote>
+<p><a name="SOCKET-LISTEN"><table width="100%"><tr><td width="80%">(socket-listen <i> (socket <a href="#socket">socket</a>) backlog</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Mark <a href="#SOCKET">SOCKET</a> as willing to accept incoming connections. BACKLOG
+defines the maximum length that the queue of pending connections may
+grow to before new connection attempts are refused. See also listen(2)</blockquote>
+<p><a name="SOCKET-CLOSE"><table width="100%"><tr><td width="80%">(socket-close <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Close <a href="#SOCKET">SOCKET</a>. May throw any kind of error that write(2) would have
+thrown. If <a href="#SOCKET-MAKE-STREAM">SOCKET-MAKE-STREAM</a> has been called, calls CLOSE on that
+stream instead</blockquote>
+<p><a name="SOCKET-MAKE-STREAM"><table width="100%"><tr><td width="80%">(socket-make-stream <i> (socket <a href="#socket">socket</a>) &rest args</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Find or create a STREAM that can be used for IO on <a href="#SOCKET">SOCKET</a> (which
+must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM.</blockquote>
+<hr>
+<H2> Socket Options </h2>
+<a name="sockopt"> </a>
+<p> A subset of socket options are supported, using a fairly
+general framework which should make it simple to add more as required
+- see sockopt.lisp for details. The name mapping from C is fairly
+straightforward: <tt>SO_RCVLOWAT</tt> becomes
+<tt>sockopt-receive-low-water</tt> and <tt>(setf
+sockopt-receive-low-water)</tt>.
+|<p><a name="SOCKOPT-REUSE-ADDRESS"><table width="100%"><tr><td width="80%">(sockopt-reuse-address <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-REUSEADDR socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-KEEP-ALIVE"><table width="100%"><tr><td width="80%">(sockopt-keep-alive <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-KEEPALIVE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-OOB-INLINE"><table width="100%"><tr><td width="80%">(sockopt-oob-inline <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-OOBINLINE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-BSD-COMPATIBLE"><table width="100%"><tr><td width="80%">(sockopt-bsd-compatible <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-BSDCOMPAT socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-PASS-CREDENTIALS"><table width="100%"><tr><td width="80%">(sockopt-pass-credentials <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-PASSCRED socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-DEBUG"><table width="100%"><tr><td width="80%">(sockopt-debug <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-DEBUG socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-DONT-ROUTE"><table width="100%"><tr><td width="80%">(sockopt-dont-route <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-DONTROUTE socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-BROADCAST"><table width="100%"><tr><td width="80%">(sockopt-broadcast <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the SO-BROADCAST socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<p><a name="SOCKOPT-TCP-NODELAY"><table width="100%"><tr><td width="80%">(sockopt-tcp-nodelay <i> (socket <a href="#socket">socket</a>) argument</i>)</td><td align=right>Accessor</td></tr></table>
+<blockquote>Return the value of the TCP-NODELAY socket option for <a href="#SOCKET">SOCKET</a>. This can also be updated with SETF.</blockquote>
+<hr> <h2>INET-domain sockets</h2>
+<P>
+<p>The TCP and UDP sockets that you know and love. Some representation issues:
+<ul>
+<li>These functions do not accept hostnames directly: see <a href="#name-service">name resolution</a>
+<li>Internet <b>addresses</b> are represented by vectors of <tt>(unsigned-byte 8)</tt> - viz. <tt>#(127 0 0 1)</tt>. <b>Ports</b> are just integers: <tt>6010</tt>. No conversion between network- and host-order data is needed from the user of this package.
+<li><b><i>socket addresses</i></b> are represented by the two values for <b>address</b> and <b>port</b>, so for example, <tt>(<a href="#SOCKET-CONNECT">socket-connect</a> s #(192.168.1.1) 80)</tt>
+</ul>
+<P>
+<p><a name="INET-SOCKET"><i>Class: </i><b>INET-SOCKET</b></a>
+<p><b>Slots:</b><ul><li>FAMILY : </li>
+</ul><p><a name="MAKE-INET-ADDRESS"><table width="100%"><tr><td width="80%">(make-inet-address <i> dotted-quads</i>)</td><td align=right>Function</td></tr></table>
+<blockquote>Return a vector of octets given a string DOTTED-QUADS in the format
+"127.0.0.1"</blockquote>
+<p><a name="GET-PROTOCOL-BY-NAME"><table width="100%"><tr><td width="80%">(get-protocol-by-name <i> name</i>)</td><td align=right>Function</td></tr></table>
+<blockquote>Returns the network protocol number associated with the string NAME,
+using getprotobyname(2) which typically looks in NIS or /etc/protocols</blockquote>
+<p><a name="MAKE-INET-SOCKET"><table width="100%"><tr><td width="80%">(make-inet-socket <i> type protocol</i>)</td><td align=right>Function</td></tr></table>
+<blockquote>Make an INET socket. Deprecated in favour of make-instance</blockquote>
+<hr> <h2>File-domain sockets</h2>
+<P>
+File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were
+renamed by POSIX presumably on the basis that they may be
+available on other systems too.
+<P>
+A file-domain socket address is a string, which is used to create a node
+in the local filesystem. This means of course that they cannot be used across
+a network.
+<P>
+|<p><a name="UNIX-SOCKET"><i>Class: </i><b>UNIX-SOCKET</b></a>
+<p><b>Slots:</b><ul><li>FAMILY : </li>
+</ul><hr> <a name="name-service"><h2>Name Service</h2></a>
+<P>
+<p>Presently name service is implemented by calling whatever
+gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS,
+or something completely different. Typically it's controlled by
+/etc/nsswitch.conf
+<P>
+<p> Direct links to the asynchronous resolver(3) routines would be nice to have
+eventually, so that we can do DNS lookups in parallel with other things
+<p><a name="HOST-ENT"><i>Class: </i><b>HOST-ENT</b></a>
+<p><b>Slots:</b><ul><li>NAME : </li>
+<li>ALIASES : </li>
+<li>ADDRESS-TYPE : </li>
+<li>ADDRESSES : </li>
+</ul><p><a name="HOST-ENT-ADDRESS"><table width="100%"><tr><td width="80%">(host-ent-address <i> (host-ent <a href="#host-ent">host-ent</a>)</i>)</td><td align=right>Method</td></tr></table>
+<p><a name="GET-HOST-BY-NAME"><table width="100%"><tr><td width="80%">(get-host-by-name <i> host-name</i>)</td><td align=right>Function</td></tr></table>
+<blockquote>Returns a <a href="#HOST-ENT">HOST-ENT</a> instance for HOST-NAME or throws some kind of condition.
+HOST-NAME may also be an IP address in dotted quad notation or some other
+weird stuff - see gethostbyname(3) for grisly details.</blockquote>
+<p><a name="GET-HOST-BY-ADDRESS"><table width="100%"><tr><td width="80%">(get-host-by-address <i> address</i>)</td><td align=right>Function</td></tr></table>
+<blockquote>Returns a <a href="#HOST-ENT">HOST-ENT</a> instance for ADDRESS, which should be a vector of
+(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
+grisly details.</blockquote>
+<p><a name="NAME-SERVICE-ERROR"><table width="100%"><tr><td width="80%">(name-service-error <i> where</i>)</td><td align=right>Function</td></tr></table>
+<hr><p><a name="NON-BLOCKING-MODE"><table width="100%"><tr><td width="80%">(non-blocking-mode <i> (socket <a href="#socket">socket</a>)</i>)</td><td align=right>Method</td></tr></table>
+<blockquote>Is <a href="#SOCKET">SOCKET</a> in non-blocking mode?</blockquote>
+<hr>
+<P>
+<H1>Tests</h1>
+<P>
+There should be at least one test for pretty much everything you can do
+with the package. In some places I've been more diligent than others; more
+tests gratefully accepted.
+<P>
+Tests are in the file <tt>tests.lisp</tt> and also make good examples.
+<P>
+|
+<h2>Unix-domain sockets</h2>
+<P>
+A fairly rudimentary test that connects to the syslog socket and sends a
+message. Priority 7 is kern.debug; you'll probably want to look at
+/etc/syslog.conf or local equivalent to find out where the message ended up
+|
\ No newline at end of file
--- /dev/null
+(in-package :sockint)
+
+;;; borrowed from CMUCL manual, lightly ported
+
+(defun array-data-address (array)
+ "Return the physical address of where the actual data of an array is
+stored.
+
+ARRAY must be a specialized array type - an array of one of these types:
+
+ double-float
+ single-float
+ (unsigned-byte 32)
+ (unsigned-byte 16)
+ (unsigned-byte 8)
+ (signed-byte 32)
+ (signed-byte 16)
+ (signed-byte 8)
+"
+ (declare (type (or (array (signed-byte 8))
+ (array base-char)
+ simple-base-string
+ (array (signed-byte 16))
+ (array (signed-byte 32))
+ (array (unsigned-byte 8))
+ (array (unsigned-byte 16))
+ (array (unsigned-byte 32))
+ (array single-float)
+ (array double-float))
+ array)
+ (optimize (speed 0) (debug 3) (safety 3)))
+ ;; with-array-data will get us to the actual data. However, because
+ ;; the array could have been displaced, we need to know where the
+ ;; data starts.
+
+ (let* ((type (car (multiple-value-list (array-element-type array))))
+ (type-size
+ (cond ((or (equal type '(signed-byte 8))
+ (equal type 'cl::base-char)
+ (equal type '(unsigned-byte 8)))
+ 1)
+ ((or (equal type '(signed-byte 16))
+ (equal type '(unsigned-byte 16)))
+ 2)
+ ((or (equal type '(signed-byte 32))
+ (equal type '(unsigned-byte 32)))
+ 4)
+ ((equal type 'single-float)
+ 4)
+ ((equal type 'double-float)
+ 8)
+ (t (error "Unknown specialized array element type")))))
+ (with-array-data ((data array)
+ (start)
+ (end))
+ (declare (ignore end))
+ ;; DATA is a specialized simple-array. Memory is laid out like this:
+ ;;
+ ;; byte offset Value
+ ;; 0 type code (e.g. 70 for double-float vector)
+ ;; 4 FIXNUMIZE(number of elements in vector)
+ ;; 8 1st element of vector
+ ;; ... ...
+ ;;
+ (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data)))))
+ (declare (type (unsigned-byte 32) addr)
+ (optimize (speed 3) (safety 0)))
+ (sb-sys:int-sap (the (unsigned-byte 32)
+ (+ addr (* type-size start))))))))
+
+
+
--- /dev/null
+;;; -*- Lisp -*-
+
+(defpackage #:bsd-sockets-system (:use #:asdf #:cl))
+(in-package #:bsd-sockets-system)
+
+;;; constants.lisp requires special treatment
+
+(defclass constants-file (cl-source-file) ())
+
+(defmethod perform ((op compile-op) (component constants-file))
+ ;; we want to generate all our temporary files in the fasl directory
+ ;; because that's where we have write permission. Can't use /tmp;
+ ;; it's insecure (these files will later be owned by root)
+ (let* ((output-file (car (output-files op component)))
+ (filename (component-pathname component))
+ (real-output-file
+ (if (typep output-file 'logical-pathname)
+ (translate-logical-pathname output-file)
+ (pathname output-file)))
+ (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
+ (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
+ (tmp-constants (merge-pathnames #p"constants.lisp-temp"
+ real-output-file)))
+ (princ (list filename output-file real-output-file
+ tmp-c-source tmp-a-dot-out tmp-constants))
+ (terpri)
+ (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "BSD-SOCKETS-SYSTEM"))
+ filename tmp-c-source :bsd-sockets-internal)
+ (and
+ (= (run-shell-command
+ "/usr/bin/gcc -o ~S ~S" (namestring tmp-a-dot-out)
+ (namestring tmp-c-source)) 0)
+ (= (run-shell-command "~A >~A"
+ (namestring tmp-a-dot-out)
+ (namestring tmp-constants)) 0)
+ (compile-file tmp-constants :output-file output-file))))
+
+
+;;; we also have a shared library with some .o files in it
+
+(defclass unix-dso (module) ())
+(defun unix-name (pathname)
+ (namestring
+ (typecase pathname
+ (logical-pathname (translate-logical-pathname pathname))
+ (t pathname))))
+
+(defmethod asdf::input-files ((operation compile-op) (dso unix-dso))
+ (mapcar #'component-pathname (module-components dso)))
+
+(defmethod output-files ((operation compile-op) (dso unix-dso))
+ (let ((dir (component-pathname dso)))
+ (list
+ (make-pathname :type "so"
+ :name (car (last (pathname-directory dir)))
+ :directory (butlast (pathname-directory dir))
+ :defaults dir))))
+
+
+(defmethod perform :after ((operation compile-op) (dso unix-dso))
+ (let ((dso-name (unix-name (car (output-files operation dso)))))
+ (unless (zerop
+ (run-shell-command
+ "gcc -shared -o ~S ~{~S ~}"
+ dso-name
+ (mapcar #'unix-name
+ (mapcan (lambda (c)
+ (output-files operation c))
+ (module-components dso)))))
+ (error 'operation-error :operation operation :component dso))))
+
+;;; if this goes into the standard asdf, it could reasonably be extended
+;;; to allow cflags to be set somehow
+(defmethod output-files ((op compile-op) (c c-source-file))
+ (list
+ (make-pathname :type "o" :defaults
+ (component-pathname c))))
+(defmethod perform ((op compile-op) (c c-source-file))
+ (unless
+ (= 0 (run-shell-command "/usr/bin/gcc -fPIC -o ~S -c ~S"
+ (unix-name (car (output-files op c)))
+ (unix-name (component-pathname c))))
+ (error 'operation-error :operation op :component c)))
+
+(defmethod perform ((operation load-op) (c c-source-file))
+ t)
+
+(defmethod perform ((o load-op) (c unix-dso))
+ (let ((co (make-instance 'compile-op)))
+ (let ((filename (car (output-files co c))))
+ #+cmu (ext:load-foreign filename)
+ #+sbcl (sb-alien:load-1-foreign filename))))
+
+(defsystem bsd-sockets
+ :version "0.58"
+ :components ((:file "defpackage" :depends-on ("rt"))
+ (:file "split" :depends-on ("defpackage"))
+ (:file "array-data" :depends-on ("defpackage"))
+ (:unix-dso "alien"
+ :components ((:c-source-file "undefs")
+ (:c-source-file "get-h-errno")))
+ (:file "malloc" :depends-on ("defpackage"))
+ (:file "foreign-glue" :depends-on ("defpackage" "malloc"))
+ (:constants-file "constants"
+ :pathname "constants.lisp"
+ :depends-on
+ ("def-to-lisp" "defpackage" "foreign-glue"))
+ (:file "sockets"
+ :depends-on ("constants" "array-data"))
+
+ (:file "sockopt" :depends-on ("sockets"))
+ (:file "inet" :depends-on ("sockets" "split" "constants" ))
+ (:file "unix" :depends-on ("sockets" "split" "constants" ))
+ (:file "name-service" :depends-on ("sockets" "constants" "alien"))
+ (:file "misc" :depends-on ("sockets" "constants"))
+
+ (:file "rt")
+ (:file "def-to-lisp")
+ (:file "tests" :depends-on ("inet" "sockopt" "rt"))
+
+ (:static-file "NEWS")
+ (:static-file "INSTALL")
+ (:static-file "README")
+ (:static-file "index" :pathname "index.html")
+ (:static-file "doc" :pathname "doc.lisp")
+ (:static-file "TODO")))
+
--- /dev/null
+;;; -*- Lisp -*-
+
+;;; This isn't really lisp, but it's definitely a source file. we
+;;; name it thus to avoid having to mess with the clc lpn translations
+
+;;; first, the headers necessary to find definitions of everything
+("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.h" "sys/un.h"
+ "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h"
+ "netdb.h" "errno.h" "netinet/tcp.h" "fcntl.h" )
+
+;;; then the stuff we're looking for
+((:integer af-inet "AF_INET" "IP Protocol family")
+ (:integer af-unspec "AF_UNSPEC" "Unspecified.")
+#-solaris (:integer af-local "AF_LOCAL" "Local to host (pipes and file-domain).")
+ (:integer af-unix "AF_UNIX" "Old BSD name for af-local. ")
+#-(or solaris freebsd) (:integer af-file "AF_FILE" "POSIX name for af-local. ")
+#+linux (:integer af-inet6 "AF_INET6" "IP version 6. ")
+#+linux (:integer af-route "AF_NETLINK" "Alias to emulate 4.4BSD ")
+
+ (:integer sock-stream "SOCK_STREAM"
+ "Sequenced, reliable, connection-based byte streams.")
+ (:integer sock-dgram "SOCK_DGRAM"
+ "Connectionless, unreliable datagrams of fixed maximum length.")
+ (:integer sock-raw "SOCK_RAW"
+ "Raw protocol interface.")
+ (:integer sock-rdm "SOCK_RDM"
+ "Reliably-delivered messages.")
+ (:integer sock-seqpacket "SOCK_SEQPACKET"
+ "Sequenced, reliable, connection-based, datagrams of fixed maximum length.")
+
+ (:integer sol-socket "SOL_SOCKET")
+
+ ;; some of these may be linux-specific
+ (:integer so-debug "SO_DEBUG"
+ "Enable debugging in underlying protocol modules")
+ (:integer so-reuseaddr "SO_REUSEADDR" "Enable local address reuse")
+ (:integer so-type "SO_TYPE") ;get only
+ (:integer so-error "SO_ERROR") ;get only (also clears)
+ (:integer so-dontroute "SO_DONTROUTE"
+ "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address")
+ (:integer so-broadcast "SO_BROADCAST" "Request permission to send broadcast datagrams")
+ (:integer so-sndbuf "SO_SNDBUF")
+#+linux (:integer so-passcred "SO_PASSCRED")
+ (:integer so-rcvbuf "SO_RCVBUF")
+ (:integer so-keepalive "SO_KEEPALIVE"
+ "Send periodic keepalives: if peer does not respond, we get SIGPIPE")
+ (:integer so-oobinline "SO_OOBINLINE"
+ "Put out-of-band data into the normal input queue when received")
+ (:integer so-no-check 11)
+#+linux (:integer so-priority "SO_PRIORITY")
+ (:integer so-linger "SO_LINGER"
+ "For reliable streams, pause a while on closing when unsent messages are queued")
+#+linux (:integer so-bsdcompat "SO_BSDCOMPAT")
+ (:integer so-sndlowat "SO_SNDLOWAT")
+ (:integer so-rcvlowat "SO_RCVLOWAT")
+ (:integer so-sndtimeo "SO_SNDTIMEO")
+ (:integer so-rcvtimeo "SO_RCVTIMEO")
+
+ (:integer tcp-nodelay "TCP_NODELAY")
+ #+linux (:integer so-bindtodevice "SO_BINDTODEVICE")
+ (:integer ifnamsiz "IFNAMSIZ")
+
+ (:integer EADDRINUSE "EADDRINUSE")
+ (:integer EAGAIN "EAGAIN")
+ (:integer EBADF "EBADF")
+ (:integer ECONNREFUSED "ECONNREFUSED")
+ (:integer EINTR "EINTR")
+ (:integer EINVAL "EINVAL")
+ (:integer ENOBUFS "ENOBUFS")
+ (:integer ENOMEM "ENOMEM")
+ (:integer EOPNOTSUPP "EOPNOTSUPP")
+ (:integer EPERM "EPERM")
+ (:integer EPROTONOSUPPORT "EPROTONOSUPPORT")
+ (:integer ESOCKTNOSUPPORT "ESOCKTNOSUPPORT")
+ (:integer ENETUNREACH "ENETUNREACH")
+
+ (:integer NETDB-INTERNAL "NETDB_INTERNAL" "See errno.")
+ (:integer NETDB-SUCCESS "NETDB_SUCCESS" "No problem.")
+ (:integer HOST-NOT-FOUND "HOST_NOT_FOUND" "Authoritative Answer Host not found.")
+ (:integer TRY-AGAIN "TRY_AGAIN" "Non-Authoritative Host not found, or SERVERFAIL.")
+ (:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
+ (:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.")
+ (:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.")
+
+ (:integer O-NONBLOCK "O_NONBLOCK")
+ (:integer f-getfl "F_GETFL")
+ (:integer f-setfl "F_SETFL")
+
+ #+linux (:integer msg-nosignal "MSG_NOSIGNAL")
+ (:integer msg-oob "MSG_OOB")
+ (:integer msg-peek "MSG_PEEK")
+ (:integer msg-trunc "MSG_TRUNC")
+ (:integer msg-waitall "MSG_WAITALL")
+
+ #|
+ ;;; stat is nothing to do with sockets, but I keep it around for testing
+ ;;; the ffi glue
+ (:structure stat ("struct stat"
+ (t dev "dev_t" "st_dev")
+ ((alien:integer 32) atime "time_t" "st_atime")))
+ (:function stat ("stat" (integer 32)
+ (file-name (* t))
+ (buf (* t))))
+ |#
+ (:structure protoent ("struct protoent"
+ ((* t) name "char *" "p_name")
+ ((* (* t)) aliases "char **" "p_aliases")
+ (integer proto "int" "p_proto")))
+ (:function getprotobyname ("getprotobyname" (* t)
+ (name c-string)))
+ (:integer inaddr-any "INADDR_ANY")
+ (:structure in-addr ("struct in_addr"
+ ((array (unsigned 8) 4) addr "u_int32_t" "s_addr")))
+ (:structure sockaddr-in ("struct sockaddr_in"
+ (integer family "sa_family_t" "sin_family")
+ ((array (unsigned 8) 2) port "u_int16_t" "sin_port")
+ ((array (unsigned 8) 4) addr "struct in_addr" "sin_addr")))
+ (:structure sockaddr-un ("struct sockaddr_un"
+ (integer family "sa_family_t" "sun_family")
+ ((array (unsigned 8) 108) path "char" "sun_path")))
+ (:structure hostent ("struct hostent"
+ ((* t) name "char *" "h_name")
+ ((* c-string) aliases "char **" "h_aliases")
+ (integer type "int" "h_addrtype")
+ (integer length "int" "h_length")
+ ((* (* (unsigned 8))) addresses "char **" "h_addr_list")))
+ (:function socket ("socket" integer
+ (domain integer)
+ (type integer)
+ (protocol integer)))
+ (:function bind ("bind" integer
+ (sockfd integer)
+ (my-addr (* t))
+ (addrlen integer)))
+ (:function listen ("listen" integer
+ (socket integer)
+ (backlog integer)))
+ (:function accept ("accept" integer
+ (socket integer)
+ (my-addr (* t))
+ (addrlen integer :in-out)))
+ (:function getpeername ("getpeername" integer
+ (socket integer)
+ (her-addr (* t))
+ (addrlen integer :in-out)))
+ (:function getsockname ("getsockname" integer
+ (socket integer)
+ (my-addr (* t))
+ (addrlen integer :in-out)))
+ (:function connect ("connect" integer
+ (socket integer)
+ (his-addr (* t))
+ (addrlen integer )))
+
+ (:function close ("close" integer
+ (fd integer)))
+ (:function recvfrom ("recvfrom" integer
+ (socket integer)
+ (buf (* t))
+ (len integer)
+ (flags integer)
+ (sockaddr (* t))
+ (socklen (* integer))))
+ (:function gethostbyname ("gethostbyname" (* t ) (name c-string)))
+ (:function gethostbyaddr ("gethostbyaddr" (* t )
+ (addr (* t))
+ (len integer)
+ (af integer)))
+ (:structure hostent ("struct hostent"
+ ((* t) name "char *" "h_name")
+ (integer length "int" "h_length")))
+
+ (:function setsockopt ("setsockopt" integer
+ (socket integer)
+ (level integer)
+ (optname integer)
+ (optval (* t))
+ (optlen integer)))
+ (:function fcntl ("fcntl" integer
+ (fd integer)
+ (cmd integer)
+ (arg integer)))
+ (:function getsockopt ("getsockopt" integer
+ (socket integer)
+ (level integer)
+ (optname integer)
+ (optval (* t))
+ (optlen integer :in-out))))
+)
--- /dev/null
+(in-package :BSD-SOCKETS-INTERNAL)
+(defconstant size-of-int 4)
+(defconstant size-of-char 1)
+(defconstant size-of-long 4)
+(defconstant AF-INET 2 "IP Protocol family")
+(defconstant AF-UNSPEC 0 "Unspecified.")
+(defconstant AF-LOCAL 1 "Local to host (pipes and file-domain).")
+(defconstant AF-UNIX 1 "Old BSD name for af-local. ")
+(defconstant AF-FILE 1 "POSIX name for af-local. ")
+(defconstant AF-INET6 10 "IP version 6. ")
+(defconstant AF-ROUTE 16 "Alias to emulate 4.4BSD ")
+(defconstant SOCK-STREAM 1 "Sequenced, reliable, connection-based byte streams.")
+(defconstant SOCK-DGRAM 2 "Connectionless, unreliable datagrams of fixed maximum length.")
+(defconstant SOCK-RAW 3 "Raw protocol interface.")
+(defconstant SOCK-RDM 4 "Reliably-delivered messages.")
+(defconstant SOCK-SEQPACKET 5 "Sequenced, reliable, connection-based, datagrams of fixed maximum length.")
+(defconstant SOL-SOCKET 1 "NIL")
+(defconstant SO-DEBUG 1 "Enable debugging in underlying protocol modules")
+(defconstant SO-REUSEADDR 2 "Enable local address reuse")
+(defconstant SO-TYPE 3 "NIL")
+(defconstant SO-ERROR 4 "NIL")
+(defconstant SO-DONTROUTE 5 "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address")
+(defconstant SO-BROADCAST 6 "Request permission to send broadcast datagrams")
+(defconstant SO-SNDBUF 7 "NIL")
+(defconstant SO-PASSCRED 16 "NIL")
+(defconstant SO-RCVBUF 8 "NIL")
+(defconstant SO-KEEPALIVE 9 "Send periodic keepalives: if peer does not respond, we get SIGPIPE")
+(defconstant SO-OOBINLINE 10 "Put out-of-band data into the normal input queue when received")
+(defconstant SO-NO-CHECK 11 "NIL")
+(defconstant SO-PRIORITY 12 "NIL")
+(defconstant SO-LINGER 13 "For reliable streams, pause a while on closing when unsent messages are queued")
+(defconstant SO-BSDCOMPAT 14 "NIL")
+(defconstant SO-SNDLOWAT 19 "NIL")
+(defconstant SO-RCVLOWAT 18 "NIL")
+(defconstant SO-SNDTIMEO 21 "NIL")
+(defconstant SO-RCVTIMEO 20 "NIL")
+(defconstant TCP-NODELAY 1 "NIL")
+(defconstant SO-BINDTODEVICE 25 "NIL")
+(defconstant IFNAMSIZ 16 "NIL")
+(defconstant EADDRINUSE 98 "NIL")
+(defconstant EAGAIN 11 "NIL")
+(defconstant EBADF 9 "NIL")
+(defconstant ECONNREFUSED 111 "NIL")
+(defconstant EINTR 4 "NIL")
+(defconstant EINVAL 22 "NIL")
+(defconstant ENOBUFS 105 "NIL")
+(defconstant ENOMEM 12 "NIL")
+(defconstant EOPNOTSUPP 95 "NIL")
+(defconstant EPERM 1 "NIL")
+(defconstant EPROTONOSUPPORT 93 "NIL")
+(defconstant ESOCKTNOSUPPORT 94 "NIL")
+(defconstant ENETUNREACH 101 "NIL")
+(defconstant NETDB-INTERNAL -1 "See errno.")
+(defconstant NETDB-SUCCESS 0 "No problem.")
+(defconstant HOST-NOT-FOUND 1 "Authoritative Answer Host not found.")
+(defconstant TRY-AGAIN 2 "Non-Authoritative Host not found, or SERVERFAIL.")
+(defconstant NO-RECOVERY 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
+(defconstant NO-DATA 4 "Valid name, no data record of requested type.")
+(defconstant NO-ADDRESS 4 "No address, look for MX record.")
+(defconstant O-NONBLOCK 2048 "NIL")
+(defconstant F-GETFL 3 "NIL")
+(defconstant F-SETFL 4 "NIL")
+(defconstant MSG-NOSIGNAL 16384 "NIL")
+(defconstant MSG-OOB 1 "NIL")
+(defconstant MSG-PEEK 2 "NIL")
+(defconstant MSG-TRUNC 32 "NIL")
+(defconstant MSG-WAITALL 256 "NIL")
+(define-c-struct PROTOENT 12)
+(define-c-accessor PROTOENT-NAME PROTOENT (* T) 0 4)
+(define-c-accessor PROTOENT-ALIASES PROTOENT (* (* T)) 4 4)
+(define-c-accessor PROTOENT-PROTO PROTOENT INTEGER 8 4)
+(declaim (inline GETPROTOBYNAME))
+(def-foreign-routine ("getprotobyname" GETPROTOBYNAME ) (* T) (NAME
+ C-STRING) )
+(defconstant INADDR-ANY 0 "NIL")
+(define-c-struct IN-ADDR 4)
+(define-c-accessor IN-ADDR-ADDR IN-ADDR (ARRAY (UNSIGNED 8) 4) 0 4)
+(define-c-struct SOCKADDR-IN 16)
+(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 0 2)
+(define-c-accessor SOCKADDR-IN-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
+(define-c-accessor SOCKADDR-IN-ADDR SOCKADDR-IN (ARRAY (UNSIGNED 8) 4) 4 4)
+(define-c-struct SOCKADDR-UN 110)
+(define-c-accessor SOCKADDR-UN-FAMILY SOCKADDR-UN INTEGER 0 2)
+(define-c-accessor SOCKADDR-UN-PATH SOCKADDR-UN (ARRAY (UNSIGNED 8) 108) 2 108)
+(define-c-struct HOSTENT 20)
+(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4)
+(define-c-accessor HOSTENT-ALIASES HOSTENT (* C-STRING) 4 4)
+(define-c-accessor HOSTENT-TYPE HOSTENT INTEGER 8 4)
+(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4)
+(define-c-accessor HOSTENT-ADDRESSES HOSTENT (* (* (UNSIGNED 8))) 16 4)
+(declaim (inline SOCKET))
+(def-foreign-routine ("socket" SOCKET ) INTEGER (DOMAIN INTEGER) (TYPE
+ INTEGER) (PROTOCOL
+ INTEGER) )
+(declaim (inline BIND))
+(def-foreign-routine ("bind" BIND ) INTEGER (SOCKFD INTEGER) (MY-ADDR
+ (* T)) (ADDRLEN
+ INTEGER) )
+(declaim (inline LISTEN))
+(def-foreign-routine ("listen" LISTEN ) INTEGER (SOCKET INTEGER) (BACKLOG
+ INTEGER) )
+(declaim (inline ACCEPT))
+(def-foreign-routine ("accept" ACCEPT ) INTEGER (SOCKET INTEGER) (MY-ADDR
+ (*
+ T)) (ADDRLEN
+ INTEGER
+ :IN-OUT) )
+(declaim (inline GETPEERNAME))
+(def-foreign-routine ("getpeername" GETPEERNAME ) INTEGER (SOCKET
+ INTEGER) (HER-ADDR
+ (*
+ T)) (ADDRLEN
+ INTEGER
+ :IN-OUT) )
+(declaim (inline GETSOCKNAME))
+(def-foreign-routine ("getsockname" GETSOCKNAME ) INTEGER (SOCKET
+ INTEGER) (MY-ADDR
+ (*
+ T)) (ADDRLEN
+ INTEGER
+ :IN-OUT) )
+(declaim (inline CONNECT))
+(def-foreign-routine ("connect" CONNECT ) INTEGER (SOCKET INTEGER) (HIS-ADDR
+ (*
+ T)) (ADDRLEN
+ INTEGER) )
+(declaim (inline CLOSE))
+(def-foreign-routine ("close" CLOSE ) INTEGER (FD INTEGER) )
+(declaim (inline RECVFROM))
+(def-foreign-routine ("recvfrom" RECVFROM ) INTEGER (SOCKET INTEGER) (BUF
+ (*
+ T)) (LEN
+ INTEGER) (FLAGS
+ INTEGER) (SOCKADDR
+ (*
+ T)) (SOCKLEN
+ (*
+ INTEGER)) )
+(declaim (inline GETHOSTBYNAME))
+(def-foreign-routine ("gethostbyname" GETHOSTBYNAME ) (* T) (NAME
+ C-STRING) )
+(declaim (inline GETHOSTBYADDR))
+(def-foreign-routine ("gethostbyaddr" GETHOSTBYADDR ) (* T) (ADDR
+ (* T)) (LEN
+ INTEGER) (AF
+ INTEGER) )
+(define-c-struct HOSTENT 20)
+(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4)
+(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4)
+(declaim (inline SETSOCKOPT))
+(def-foreign-routine ("setsockopt" SETSOCKOPT ) INTEGER (SOCKET
+ INTEGER) (LEVEL
+ INTEGER) (OPTNAME
+ INTEGER) (OPTVAL
+ (*
+ T)) (OPTLEN
+ INTEGER) )
+(declaim (inline FCNTL))
+(def-foreign-routine ("fcntl" FCNTL ) INTEGER (FD INTEGER) (CMD
+ INTEGER) (ARG
+ INTEGER) )
+(declaim (inline GETSOCKOPT))
+(def-foreign-routine ("getsockopt" GETSOCKOPT ) INTEGER (SOCKET
+ INTEGER) (LEVEL
+ INTEGER) (OPTNAME
+ INTEGER) (OPTVAL
+ (*
+ T)) (OPTLEN
+ INTEGER
+ :IN-OUT) )
--- /dev/null
+(in-package :BSD-SOCKETS-SYSTEM)
+(defvar *export-symbols* nil)
+
+(defun c-for-structure (stream lisp-name c-struct)
+ (destructuring-bind (c-name &rest elements) c-struct
+ (format stream "printf(\"(define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
+ (dolist (e elements)
+ (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
+ (format stream "printf(\"(define-c-accessor ~A-~A ~A ~A \");~%"
+ lisp-name lisp-el-name lisp-name lisp-type)
+ ;; offset
+ (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
+ c-name c-el-name)
+ ;; length
+ (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
+ c-name c-el-name)
+ (format stream "printf(\")\\n\");~%")))))
+
+(defun c-for-function (stream lisp-name alien-defn)
+ (destructuring-bind (c-name &rest definition) alien-defn
+ (let ((*print-right-margin* nil))
+ (format stream "printf(\"(declaim (inline ~A))\\n\");~%"
+ lisp-name)
+ (princ "printf(\"(def-foreign-routine (" stream)
+ (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
+ (princ lisp-name stream)
+ (princ " ) " stream)
+ (dolist (d definition)
+ (write d :length nil
+ :right-margin nil :stream stream)
+ (princ " " stream))
+ (format stream ")\\n\");")
+ (terpri stream))))
+
+
+(defun print-c-source (stream headers definitions package-name)
+ ;(format stream "#include \"struct.h\"~%")
+ (let ((*print-right-margin* nil))
+ (loop for i in headers
+ do (format stream "#include <~A>~%" i))
+ (format stream "main() { ~%
+printf(\"(in-package ~S)\\\n\");~%" package-name)
+ (format stream "printf(\"(defconstant size-of-int %d)\\\n\",sizeof (int));~%")
+ (format stream "printf(\"(defconstant size-of-char %d)\\\n\",sizeof (char));~%")
+ (format stream "printf(\"(defconstant size-of-long %d)\\\n\",sizeof (long));~%")
+ (dolist (def definitions)
+ (destructuring-bind (type lispname cname &optional doc) def
+ (cond ((eq type :integer)
+ (format stream
+ "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
+ lispname doc cname))
+ ((eq type :string)
+ (format stream
+ "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
+ lispname doc cname))
+ ((eq type :function)
+ (c-for-function stream lispname cname))
+ ((eq type :structure)
+ (c-for-structure stream lispname cname))
+ (t
+ (format stream
+ "printf(\";; Non hablo Espagnol, Monsieur~%")))))
+ (format stream "exit(0);~%}")))
+
+(defun c-constants-extract (filename output-file package)
+ (with-open-file (f output-file :direction :output)
+ (with-open-file (i filename :direction :input)
+ (let* ((headers (read i))
+ (definitions (read i)))
+ (print-c-source f headers definitions package)))))
--- /dev/null
+(defpackage "BSD-SOCKETS-INTERNAL"
+ (:nicknames "SOCKINT")
+ (:shadow close listen)
+ #+cmu (:shadowing-import-from "CL" with-array-data)
+ #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data)
+
+ #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL")
+ #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL"))
+
+;;; SBCL changes a lot of package prefixes. To avoid littering the
+;;; code with conditionals, we use the SBCL package prefixes
+;;; throughout. This means that we need to create said packages
+;;; first, if we're using CMUCL
+
+;;; One thing that this exercise really has made clear is just how much
+;;; of the alien stuff is scattered around the cmucl package space
+;;; seemingly at random. Hmm.
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel)
+ (defun add-package-nickname (name nickname)
+ (let ((p (find-package name)))
+ (rename-package p (package-name p)
+ (cons nickname (package-nicknames name)))))
+ (add-package-nickname "EXT" "SB-EXT")
+ (add-package-nickname "ALIEN" "SB-ALIEN")
+ (add-package-nickname "UNIX" "SB-UNIX")
+ (add-package-nickname "C-CALL" "SB-C-CALL")
+ (add-package-nickname "KERNEL" "SB-KERNEL")
+ (add-package-nickname "SYSTEM" "SB-SYS"))
+
+(defpackage "BSD-SOCKETS"
+ (:export socket unix-socket inet-socket
+ make-unix-socket make-inet-socket
+ socket-bind socket-accept socket-connect
+ socket-send socket-receive socket-recv
+ socket-name socket-peername socket-listen
+ socket-close socket-file-descriptor socket-make-stream
+ get-protocol-by-name
+
+ get-host-by-name get-host-by-address
+ host-ent
+ host-ent-addresses host-ent-address
+ host-ent aliases host-ent-name
+ name-service-error
+ ;; not sure if these are really good names or not
+ netdb-internal-error
+ netdb-success-error
+ host-not-found-error
+ try-again-error
+ no-recovery-error
+
+ ;; all socket options are also exported, by code in
+ ;; sockopt.lisp
+
+ bad-file-descriptor-error
+ address-in-use-error
+ interrupted-error
+ invalid-argument-error
+ out-of-memory-error
+ operation-not-supported-error
+ operation-not-permitted-error
+ protocol-not-supported-error
+ socket-type-not-supported-error
+ network-unreachable-error
+
+ make-inet-address
+
+ non-blocking-mode
+ )
+ (:use "COMMON-LISP" "BSD-SOCKETS-INTERNAL")
+ (:documentation
+ "
+
+A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD
+socket API for C and Graham Barr's IO::Socket classes for Perl.
+
+We represent sockets as CLOS objects, and rename a lot of methods and
+arguments to fit Lisp style more closely.
+
+"
+ ))
+
+#||
+
+<h2>Contents</h2>
+
+<ol>
+<li> General concepts
+<li> Methods applicable to all <a href="#socket">sockets</a>
+<li> <a href="#sockopt">Socket Options</a>
+<li> Methods applicable to a particular subclass
+<ol>
+<li> <a href="#internet">INET-SOCKET</a> - Internet Protocol (TCP, UDP, raw) sockets
+<li> Methods on <a href="#UNIX-SOCKET">UNIX-SOCKET</a> - Unix-domain sockets
+</ol>
+<li> <a href="#name-service">Name resolution</a> (DNS, /etc/hosts, &c)
+</ol>
+
+<h2>General concepts</h2>
+
+<p>Most of the functions are modelled on the BSD socket API. BSD sockets
+are widely supported, portably <i>("portable" by Unix standards, at least)</i>
+available on a variety of systems, and documented. There are some
+differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly
+
+<ul>
+<li> Where the C API would typically return -1 and set errno, bsd-sockets
+signals an error. All the errors are subclasses of SOCKET-CONDITION
+and generally correspond one for one with possible <tt>errno</tt> values
+
+<li> We use multiple return values in many places where the C API would use p[ass-by-reference values
+
+<li> We can often avoid supplying an explicit <i>length</i> argument to
+functions because we already know how long the argument is.
+
+<li> IP addresses and ports are represented in slightly friendlier fashion
+than "network-endian integers". See the section on <a href="#internet"
+>Internet domain</a> sockets for details.
+</ul>
+
+
+|#
--- /dev/null
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext )))
+(in-package :db-doc)
+;;; turn water into wine ^W^W^W lisp into HTML
+
+#|
+OK. We need a design
+
+1) The aim is to document the current package, given a system.
+2) The assumption is that the system is loaded; this makes it easier to
+do cross-references and stuff
+3) We output HTML on *standard-output*
+4) Hyperlink wherever useful
+5) We're allowed to intern symbols all over the place if we like
+
+|#
+
+;;; note: break badly on multiple packages
+
+
+(defvar *symbols* nil
+ "List of external symbols to print; derived from parsing DEFPACKAGE form")
+
+
+(defun worth-documenting-p (symbol)
+ (and symbol
+ (eql (symbol-package symbol) *package*)
+ (or (ignore-errors (find-class symbol))
+ (boundp symbol) (fboundp symbol))))
+
+(defun linkable-symbol-p (word)
+ (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
+ (eql c #\-))))
+ (and (every #'symbol-char word)
+ (some #'upper-case-p word)
+ (worth-documenting-p (find-symbol word)))))
+
+(defun markup-word (w)
+ (if (symbolp w) (setf w (princ-to-string w)))
+ (cond ((linkable-symbol-p w)
+ (format nil "<a href=\"#~A\">~A</a>"
+ w w))
+ ((and (> (length w) 0)
+ (eql (elt w 0) #\_)
+ (eql (elt w (1- (length w))) #\_))
+ (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
+ (t w)))
+(defun markup-space (w)
+ (let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
+ (if para
+ (format nil "~A<P>~A"
+ (subseq w 0 (1+ para))
+ (markup-space (subseq w (1+ para) nil)))
+ w)))
+
+(defun text-markup (text)
+ (let ((start-word 0) (end-word 0))
+ (labels ((read-word ()
+ (setf end-word
+ (position-if
+ (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
+ text :start start-word))
+ (subseq text start-word end-word))
+ (read-space ()
+ (setf start-word
+ (position-if-not
+ (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
+ text :start end-word ))
+ (subseq text end-word start-word)))
+ (with-output-to-string (o)
+ (loop for inword = (read-word)
+ do (princ (markup-word inword) o)
+ while (and start-word end-word)
+ do (princ (markup-space (read-space)) o)
+ while (and start-word end-word))))))
+
+
+(defun do-defpackage (form stream)
+ (setf *symbols* nil)
+ (destructuring-bind (defn name &rest options) form
+ (when (string-equal name (package-name *package*))
+ (format stream "<h1>Package ~A</h1>~%" name)
+ (when (documentation *package* t)
+ (princ (text-markup (documentation *package* t))))
+ (let ((exports (assoc :export options)))
+ (when exports
+ (setf *symbols* (mapcar #'symbol-name (cdr exports)))))
+ 1)))
+
+(defun do-defclass (form stream)
+ (destructuring-bind (defn name super slots &rest options) form
+ (when (interesting-name-p name)
+ (let ((class (find-class name)))
+ (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
+ name name)
+ #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
+ (mapcar (lambda (x) (text-markup (class-name x)))
+ (mop:class-direct-superclasses class)))
+ (if (documentation class 'type)
+ (format stream "<blockquote>~A</blockquote>~%"
+ (text-markup (documentation class 'type))))
+ (when slots
+ (princ "<p><b>Slots:</b><ul>" stream)
+ (dolist (slot slots)
+ (destructuring-bind
+ (name &key reader writer accessor initarg initform type
+ documentation)
+ (if (consp slot) slot (list slot))
+ (format stream "<li>~A : ~A</li>~%" name
+ (if documentation (text-markup documentation) ""))))
+ (princ "</ul>" stream))
+ t))))
+
+
+(defun interesting-name-p (name)
+ (cond ((consp name)
+ (and (eql (car name) 'setf)
+ (interesting-name-p (cadr name))))
+ (t (member (symbol-name name) *symbols* :test #'string=))))
+
+(defun markup-lambdalist (l)
+ (let (key-p)
+ (loop for i in l
+ if (eq '&key i) do (setf key-p t)
+ end
+ if (and (not key-p) (consp i))
+ collect (list (car i) (markup-word (cadr i)))
+ else collect i)))
+
+(defun do-defunlike (form label stream)
+ (destructuring-bind (defn name lambdalist &optional doc &rest code) form
+ (when (interesting-name-p name)
+ (when (symbolp name)
+ (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
+ (format stream "<p><a name=\"~A\"><table width=\"100%\"><tr><td width=\"80%\">(~A <i>~A</i>)</td><td align=right>~A</td></tr></table>~%"
+ name (string-downcase (princ-to-string name))
+ (string-downcase
+ (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
+ label)
+ (if (stringp doc)
+ (format stream "<blockquote>~A</blockquote>~%"
+ (text-markup doc)))
+ t)))
+
+(defun do-defun (form stream) (do-defunlike form "Function" stream))
+(defun do-defmethod (form stream) (do-defunlike form "Method" stream))
+(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream))
+(defun do-boolean-sockopt (form stream)
+ (destructuring-bind (type lisp-name level c-name) form
+ (pushnew (symbol-name lisp-name) *symbols*)
+
+ (do-defunlike `(defun ,lisp-name ((socket socket) argument)
+ ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
+ "Accessor" stream)))
+
+(defun do-form (form output-stream)
+ (cond ((not (listp form)) nil)
+ ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
+ (do-boolean-sockopt form output-stream))
+ ((eq (car form) 'defclass)
+ (do-defclass form output-stream))
+ ((eq (car form) 'eval-when)
+ (do-form (third form) output-stream))
+ ((eq (car form) 'defpackage)
+ (do-defpackage form output-stream))
+ ((eq (car form) 'defun)
+ (do-defun form output-stream))
+ ((eq (car form) 'defmethod)
+ (do-defmethod form output-stream))
+ ((eq (car form) 'defgeneric)
+ (do-defgeneric form output-stream))
+ (t nil)))
+
+(defun do-file (input-stream output-stream)
+ "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
+ (let ((eof-marker (gensym)))
+ (if (< 0
+ (loop for form = (read input-stream nil eof-marker)
+ until (eq form eof-marker)
+ if (do-form form output-stream)
+ count 1 #| and
+ do (princ "<hr width=\"20%\">" output-stream) |# ))
+ (format output-stream "<hr>"
+ ))))
+
+(defvar *standard-sharpsign-reader*
+ (get-dispatch-macro-character #\# #\|))
+
+(defun document-system (system &key
+ (output-stream *standard-output*)
+ (package *package*))
+ "Produce HTML documentation for all files defined in SYSTEM, covering
+symbols exported from PACKAGE"
+ (let ((*package* (find-package package))
+ (*readtable* (copy-readtable))
+ (*standard-output* output-stream))
+ (set-dispatch-macro-character
+ #\# #\|
+ (lambda (s c n)
+ (if (eql (peek-char nil s t nil t) #\|)
+ (princ
+ (text-markup
+ (coerce
+ (loop with discard = (read-char s t nil t)
+ ;initially (princ "<P>")
+ for c = (read-char s t nil t)
+ until (and (eql c #\|)
+ (eql (peek-char nil s t nil t) #\#))
+ collect c
+ finally (read-char s t nil t))
+ 'string)))
+ (funcall *standard-sharpsign-reader* s c n))))
+ (dolist (c (cclan:all-components 'db-sockets))
+ (when (and (typep c 'cl-source-file)
+ (not (typep c 'db-sockets-system::constants-file)))
+ (with-open-file (in (component-pathname c) :direction :input)
+ (do-file in *standard-output*))))))
+
+(defun start ()
+ (with-open-file (*standard-output* "index.html" :direction :output)
+ (format t "<html><head><title>SBCL BSD-Sockets API Reference</title></head><body>~%")
+ (asdf:operate 'asdf:load-op 'bsd-sockets)
+ (document-system 'bsd-sockets :package :bsd-sockets)))
+
+(start)
--- /dev/null
+(in-package :bsd-sockets-internal)
+
+;;;; Foreign function glue. This is the only file in the distribution
+;;;; that's _intended_ to be vendor-specific. The macros defined here
+;;;; are called from constants.lisp, which was generated from constants.ccon
+;;;; by the C compiler as driven by that wacky def-to-lisp thing.
+
+;;;; of course, the whole thing is vendor-specific actually, due to
+;;;; the way we use cmucl alien types in constants.ccon as a cheap way
+;;;; of transforming C-world alues into Lisp-world values. But if
+;;;; anyone were to port that bit to their preferred implementation, they
+;;;; wouldn't need to port all the rest of the cmucl alien interface at
+;;;; the same time
+
+;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
+;;; C-CALL:C-STRING) (BUF (* T)) )
+
+;;; I can't help thinking this was originally going to do something a
+;;; lot more complex
+(defmacro def-foreign-routine
+ (&whole it (c-name lisp-name) return-type &rest args)
+ (declare (ignorable c-name lisp-name return-type args))
+ `(def-alien-routine ,@(cdr it)))
+#|
+(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
+(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
+|#
+;;; define-c-accessor makes us a setter and a getter for changing
+;;; memory at the appropriate offset
+
+;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
+
+(defmacro define-c-accessor (el structure type offset length)
+ (declare (ignore structure))
+ (let* ((ty (cond
+ ((eql type 'integer) `(,type ,(* 8 length)))
+ ((eql (car type) '*) `(unsigned ,(* 8 length)))
+ ((eql type 'c-string) `(unsigned ,(* 8 length)))
+ ((eql (car type) 'array) (cadr type))))
+ (sap-ref-? (intern (format nil "~ASAP-REF-~A"
+ (if (member (car ty) '(INTEGER SIGNED))
+ "SIGNED-" "")
+ (cadr ty))
+ (find-package "SB-SYS"))))
+ (labels ((template (before after)
+ `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
+ (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
+ (,before (,sap-ref-? sap index) ,after))))
+ `(progn
+ ;;(declaim (inline ,el (setf ,el)))
+ (defun ,el (ptr &optional (index 0))
+ ,(template 'prog1 nil))
+ (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
+ (defun (setf ,el) (newval ptr &optional (index 0))
+ ,(template 'setf 'newval))))))
+
+
+;;; make memory allocator for appropriately-sized block of memory, and
+;;; a constant to tell us how big it was anyway
+(defmacro define-c-struct (name size)
+ (labels ((p (x) (intern (concatenate 'string x (symbol-name name)))))
+ `(progn
+ (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
+ :element-type '(unsigned-byte 8)))
+ (defconstant ,(p "SIZE-OF-") ,size)
+ (defun ,(p "FREE-" ) (p) (declare (ignore p))))))
+
+(defun foreign-nullp (c)
+ "C is a pointer to 0?"
+ (= 0 (sb-sys:sap-int (sb-alien:alien-sap c))))
+
+;;; this could be a lot faster if I cared enough to think about it
+(defun foreign-vector (pointer size length)
+ "Compose a vector of the words found in foreign memory starting at
+POINTER. Each word is SIZE bytes long; LENGTH gives the number of
+elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO"
+ (assert (= size 1))
+ (let ((ptr
+ (typecase pointer
+ (sb-sys:system-area-pointer
+ (sap-alien pointer (* (sb-alien:unsigned 8))))
+ (t
+ (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
+ (result (make-array length :element-type '(unsigned-byte 8))))
+ (loop for i from 0 to (1- length) by size
+ do (setf (aref result i) (sb-alien:deref ptr i)))
+ ;;(format t "~S~%" result)
+ result))
--- /dev/null
+(in-package :bsd-sockets)
+
+#|| <h2>INET-domain sockets</h2>
+
+<p>The TCP and UDP sockets that you know and love. Some representation issues:
+<ul>
+<li>These functions do not accept hostnames directly: see <a href="#name-service">name resolution</a>
+<li>Internet <b>addresses</b> are represented by vectors of <tt>(unsigned-byte 8)</tt> - viz. <tt>#(127 0 0 1)</tt>. <b>Ports</b> are just integers: <tt>6010</tt>. No conversion between network- and host-order data is needed from the user of this package.
+<li><b><i>socket addresses</i></b> are represented by the two values for <b>address</b> and <b>port</b>, so for example, <tt>(<a href="#SOCKET-CONNECT">socket-connect</a> s #(192.168.1.1) 80)</tt>
+</ul>
+
+|#
+
+;;; Our class and constructor
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass inet-socket (socket)
+ ((family :initform sockint::AF-INET))))
+
+;;; XXX should we *...* this?
+(defparameter inet-address-any (vector 0 0 0 0))
+
+;;; binding a socket to an address and port. Doubt that anyone's
+;;; actually using this much, to be honest.
+
+(defun make-inet-address (dotted-quads)
+ "Return a vector of octets given a string DOTTED-QUADS in the format
+\"127.0.0.1\""
+ (coerce
+ (mapcar #'parse-integer
+ (split dotted-quads nil '(#\.)))
+ 'vector))
+
+;;; getprotobyname only works in the internet domain, which is why this
+;;; is here
+(defun get-protocol-by-name (name) ;exported
+ "Returns the network protocol number associated with the string NAME,
+using getprotobyname(2) which typically looks in NIS or /etc/protocols"
+ ;; for extra brownie points, could return canonical protocol name
+ ;; and aliases as extra values
+ (let ((ent (sockint::foreign-vector (sockint::getprotobyname name) 1
+ sockint::size-of-protoent)))
+ (sockint::protoent-proto ent)))
+
+
+;;; sockaddr protocol
+;;; (1) sockaddrs are represented as the semi-foreign array-of-octets
+;;; thing
+;;; (2) a protocol provides make-sockaddr-for, size-of-sockaddr,
+;;; bits-of-sockaddr
+
+(defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address)))
+ (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in))))
+ (when (and host port)
+ ;; port and host are represented in C as "network-endian" unsigned
+ ;; integers of various lengths. This is stupid. The value of the
+ ;; integer doesn't matter (and will change depending on your
+ ;; machine's endianness); what the bind(2) call is interested in
+ ;; is the pattern of bytes within that integer.
+
+ ;; We have no truck with such dreadful type punning. Octets to
+ ;; octets, dust to dust.
+
+ (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
+ (setf (sockint::sockaddr-in-port sockaddr 0) (ldb (byte 8 8) port))
+ (setf (sockint::sockaddr-in-port sockaddr 1) (ldb (byte 8 0) port))
+
+ (setf (sockint::sockaddr-in-addr sockaddr 0) (elt host 0))
+ (setf (sockint::sockaddr-in-addr sockaddr 1) (elt host 1))
+ (setf (sockint::sockaddr-in-addr sockaddr 2) (elt host 2))
+ (setf (sockint::sockaddr-in-addr sockaddr 3) (elt host 3)))
+ sockaddr))
+
+(defmethod size-of-sockaddr ((socket inet-socket))
+ sockint::size-of-sockaddr-in)
+
+(defmethod bits-of-sockaddr ((socket inet-socket) sockaddr)
+ "Returns address and port of SOCKADDR as multiple values"
+ (values
+ (vector
+ (sockint::sockaddr-in-addr sockaddr 0)
+ (sockint::sockaddr-in-addr sockaddr 1)
+ (sockint::sockaddr-in-addr sockaddr 2)
+ (sockint::sockaddr-in-addr sockaddr 3))
+ (+ (* 256 (sockint::sockaddr-in-port sockaddr 0))
+ (sockint::sockaddr-in-port sockaddr 1))))
+
+
+(defun make-inet-socket (type protocol)
+ "Make an INET socket. Deprecated in favour of make-instance"
+ (make-instance 'inet-socket :type type :protocol protocol))
+
+
+
--- /dev/null
+(in-package :bsd-sockets-internal)
+
+(defun malloc (size)
+ "Allocate foreign memory in some way that allows the garbage collector to free it later. Note that memory allocated this way does not count as `consed' for the purposes of deciding when to gc, so explicitly calling EXT:GC occasionally would be a good idea if you use it a lot"
+ ;; we can attach finalizers to any object, and they'll be called on
+ ;; the next gc after the object no longer has references. We can't
+ ;; however make the finalizer close over the object, or it'll never
+ ;; have no references. I experimentally determined that (sap-alien
+ ;; (alien-sap f)) is not EQ to f, so we can do it that way
+ (let* ((memory (make-alien (unsigned 8) size))
+ (alias (sap-alien (alien-sap memory)
+ (* (unsigned 8)))))
+ (sb-ext:finalize memory
+ (lambda ()
+ (free-alien alias)))))
+
--- /dev/null
+(in-package :bsd-sockets)
+
+;;; Miscellaneous things, placed here until I can find a logically more
+;;; coherent place to put them
+
+;;; I don't want to provide a complete interface to unix file
+;;; operations, for example, but being about to set O_NONBLOCK on a
+;;; socket is a necessary operation.
+
+;;; XXX bad (sizeof (int) ==4 ) assumptions
+
+(defmethod non-blocking-mode ((socket socket))
+ "Is SOCKET in non-blocking mode?"
+ (let ((fd (socket-file-descriptor socket)))
+ (sb-alien:with-alien ((arg integer))
+ (> (logand
+ (sockint::fcntl fd sockint::f-getfl arg)
+ sockint::o-nonblock)
+ 0))))
+
+(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket))
+ "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P"
+ (declare (optimize (speed 3)))
+ (let* ((fd (socket-file-descriptor socket))
+ (arg1 (the (signed-byte 32) (sockint::fcntl fd sockint::f-getfl 0)))
+ (arg2
+ (if non-blocking-p
+ (logior arg1 sockint::o-nonblock)
+ (logand (lognot sockint::o-nonblock) arg1))))
+ (when (= (the (signed-byte 32) -1)
+ (the (signed-byte 32)
+ (sockint::fcntl fd sockint::f-setfl arg2)))
+ (socket-error "fcntl"))
+ non-blocking-p))
+
+
--- /dev/null
+(in-package :bsd-sockets)
+#|| <a name="name-service"><h2>Name Service</h2></a>
+
+<p>Presently name service is implemented by calling whatever
+gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS,
+or something completely different. Typically it's controlled by
+/etc/nsswitch.conf
+
+<p> Direct links to the asynchronous resolver(3) routines would be nice to have
+eventually, so that we can do DNS lookups in parallel with other things
+|#
+
+(defclass host-ent ()
+ ((name :initarg :name :accessor host-ent-name)
+ (aliases :initarg :aliases :accessor host-ent-aliases)
+ (address-type :initarg :type :accessor host-ent-address-type)
+ ; presently always AF_INET
+ (addresses :initarg :addresses :accessor host-ent-addresses)))
+
+(defmethod host-ent-address ((host-ent host-ent))
+ (car (host-ent-addresses host-ent)))
+
+;(define-condition host-not-found-error (socket-error)) ; host unknown
+;(define-condition no-address-error (socket-error)) ; valid name but no IP address
+;(define-condition no-recovery-error (socket-error)) ; name server error
+;(define-condition try-again-error (socket-error)) ; temporary
+
+(defun get-host-by-name (host-name)
+ "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition.
+HOST-NAME may also be an IP address in dotted quad notation or some other
+weird stuff - see gethostbyname(3) for grisly details."
+ (let ((h (sockint::gethostbyname host-name)))
+ (make-host-ent h)))
+
+(defun get-host-by-address (address)
+ "Returns a HOST-ENT instance for ADDRESS, which should be a vector of
+(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
+grisly details."
+ (let ((packed-addr (sockint::allocate-in-addr)))
+ (loop for i from 0 to 3
+ do (setf (sockint::in-addr-addr packed-addr i) (elt address i)))
+ (make-host-ent
+ (sb-sys:without-gcing
+ (sockint::gethostbyaddr (sockint::array-data-address packed-addr)
+ 4
+ sockint::af-inet)))))
+
+(defun make-host-ent (h)
+ (if (sockint::foreign-nullp h) (name-service-error "gethostbyname"))
+ (let* ((local-h (sockint::foreign-vector h 1 sockint::size-of-hostent))
+ (length (sockint::hostent-length local-h))
+ (aliases
+ (loop for i = 0 then (1+ i)
+ for al = (sb-sys:sap-ref-sap
+ (sb-sys:int-sap (sockint::hostent-aliases local-h))
+ (* i 4))
+ until (= (sb-sys:sap-int al) 0)
+ collect (sb-c-call::%naturalize-c-string al)))
+ (address0 (sb-sys:sap-ref-sap (sb-sys:int-sap (sockint::hostent-addresses local-h)) 0))
+ (addresses
+ (loop for i = 0 then (+ length i)
+ for ad = (sb-sys:sap-ref-32 address0 i)
+ while (> ad 0)
+ collect
+ (sockint::foreign-vector (sb-sys:sap+ address0 i) 1 length))))
+ (make-instance 'host-ent
+ :name (sb-c-call::%naturalize-c-string
+ (sb-sys:int-sap (sockint::hostent-name local-h)))
+ :type (sockint::hostent-type local-h)
+ :aliases aliases
+ :addresses addresses)))
+
+;;; The remainder is my fault - gw
+
+(defvar *name-service-errno* 0
+ "The value of h_errno, after it's been fetched from Unix-land by calling
+GET-NAME-SERVICE-ERRNO")
+
+(defun name-service-error (where)
+ (get-name-service-errno)
+ ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.".
+ ;; This special case treatment hasn't actually been tested yet.
+ (if (= *name-service-errno* sockint::NETDB-INTERNAL)
+ (socket-error where)
+ (let ((condition
+ (condition-for-name-service-errno *name-service-errno*)))
+ (error condition :errno *name-service-errno* :syscall where))))
+
+(define-condition name-service-error (condition)
+ ((errno :initform nil
+ :initarg :errno
+ :reader name-service-error-errno)
+ (symbol :initform nil :initarg :symbol :reader name-service-error-symbol)
+ (syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall))
+ (:report (lambda (c s)
+ (let ((num (name-service-error-errno c)))
+ (format s "Name service error in \"~A\": ~A (~A)"
+ (name-service-error-syscall c)
+ (or (name-service-error-symbol c)
+ (name-service-error-errno c))
+ (get-name-service-error-message num))))))
+
+(defmacro define-name-service-condition (symbol name)
+ `(progn
+ (define-condition ,name (name-service-error)
+ ((symbol :reader name-service-error-symbol :initform (quote ,symbol))))
+ (push (cons ,symbol (quote ,name)) *conditions-for-name-service-errno*)))
+
+(defparameter *conditions-for-name-service-errno* nil)
+
+(define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error)
+(define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error)
+(define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error)
+(define-name-service-condition sockint::TRY-AGAIN try-again-error)
+(define-name-service-condition sockint::NO-RECOVERY no-recovery-error)
+;; this is the same as the next one
+;;(define-name-service-condition sockint::NO-DATA no-data-error)
+(define-name-service-condition sockint::NO-ADDRESS no-address-error)
+
+(defun condition-for-name-service-errno (err)
+ (or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql))
+ 'name-service))
+
+
+
+(defun get-name-service-errno ()
+ (setf *name-service-errno*
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien "get_h_errno" (function integer)))))
+
+#-solaris
+(progn
+ #+sbcl
+ (sb-alien:define-alien-routine "hstrerror"
+ sb-c-call:c-string
+ (errno integer))
+ #+cmu
+ (alien:def-alien-routine "hstrerror"
+ sb-c-call:c-string
+ (errno integer))
+ (defun get-name-service-error-message (num)
+ (hstrerror num))
+)
+
--- /dev/null
+;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
+
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+;This is the December 19, 1990 version of the regression tester.
+\f
+(defpackage "RT"
+ (:use "COMMON-LISP")
+ (:export deftest get-test do-test rem-test
+ rem-all-tests do-tests pending-tests
+ continue-testing *test*
+ *do-tests-when-defined*))
+(in-package :rt)
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+\f
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~@:(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+\f
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ (*break-on-warnings* t)
+ (r (multiple-value-list
+ (eval (form entry)))))
+ (setf (pend entry)
+ (not (equal r (vals entry))))
+ (when (pend entry)
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~
+ ~%Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry)
+ (length r) r))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+\f
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending))
+ (null pending)))
--- /dev/null
+(in-package "BSD-SOCKETS")
+
+;;;; Methods, classes, functions for sockets. Protocol-specific stuff
+;;;; is deferred to inet.lisp, unix.lisp, etc
+
+#|| <h2>SOCKETs</h2>
+
+|#
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+(defclass socket ()
+ ((file-descriptor :initarg :descriptor
+ :reader socket-file-descriptor)
+ (family :initform (error "No socket family") :reader socket-family)
+ (protocol :initarg :protocol :reader socket-protocol)
+ (type :initarg :type :reader socket-type)
+ (stream))))
+
+(defmethod print-object ((object socket) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (princ "descriptor " stream)
+ (princ (slot-value object 'file-descriptor) stream)))
+
+
+(defmethod shared-initialize :after ((socket socket) slot-names
+ &key protocol type
+ &allow-other-keys)
+ (let* ((proto-num
+ (cond ((and protocol (keywordp protocol))
+ (get-protocol-by-name (string-downcase (symbol-name protocol))))
+ (protocol protocol)
+ (t 0)))
+ (fd (or (and (slot-boundp socket 'file-descriptor)
+ (socket-file-descriptor socket))
+ (sockint::socket (socket-family socket)
+ (ecase type
+ ((:datagram) sockint::sock-dgram)
+ ((:stream) sockint::sock-stream))
+ proto-num))))
+ (if (= fd -1) (socket-error "socket"))
+ (setf (slot-value socket 'file-descriptor) fd
+ (slot-value socket 'protocol) proto-num
+ (slot-value socket 'type) type)
+ (sb-ext:finalize socket (lambda () (sockint::close fd)))))
+
+\f
+
+;; we deliberately redesign the "bind" interface: instead of passing a
+;; sockaddr_something as second arg, we pass the elements of one as
+;; multiple arguments.
+
+(defgeneric socket-bind (socket &rest address))
+(defmethod socket-bind ((socket socket)
+ &rest address)
+ "Bind SOCKET to ADDRESS, which may vary according to socket family. For
+the INET family, pass ADDRESS and PORT as two arguments; for FILE address
+family sockets, pass the filename string. See also bind(2)"
+ (let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
+ (if (= (sb-sys:without-gcing
+ (sockint::bind (socket-file-descriptor socket)
+ (sockint::array-data-address sockaddr)
+ (size-of-sockaddr socket)))
+ -1)
+ (socket-error "bind"))))
+
+\f
+(defmethod socket-accept ((socket socket))
+ "Perform the accept(2) call, returning a newly-created connected socket
+and the peer address as multiple values"
+ (let* ((sockaddr (make-sockaddr-for socket))
+ (fd (sb-sys:without-gcing
+ (sockint::accept (socket-file-descriptor socket)
+ (sockint::array-data-address sockaddr)
+ (size-of-sockaddr socket)))))
+ (apply #'values
+ (if (= fd -1)
+ (socket-error "accept")
+ (let ((s (make-instance (class-of socket)
+ :type (socket-type socket)
+ :protocol (socket-protocol socket)
+ :descriptor fd)))
+ (sb-ext:finalize s (lambda () (sockint::close fd)))))
+ (multiple-value-list (bits-of-sockaddr socket sockaddr)))))
+
+(defgeneric socket-connect (socket &rest address))
+(defmethod socket-connect ((socket socket) &rest peer)
+ "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value"
+ (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
+ (if (= (sb-sys:without-gcing
+ (sockint::connect (socket-file-descriptor socket)
+ (sockint::array-data-address sockaddr)
+ (size-of-sockaddr socket)))
+ -1)
+ (socket-error "connect") )))
+
+(defmethod socket-peername ((socket socket))
+ "Return the socket's peer; depending on the address family this may return multiple values"
+ (let* ((sockaddr (make-sockaddr-for socket)))
+ (when (= (sb-sys:without-gcing
+ (sockint::getpeername (socket-file-descriptor socket)
+ (sockint::array-data-address sockaddr)
+ (size-of-sockaddr socket)))
+ -1)
+ (socket-error "getpeername"))
+ (bits-of-sockaddr socket sockaddr)))
+
+(defmethod socket-name ((socket socket))
+ "Return the address (as vector of bytes) and port that the socket is bound to, as multiple values"
+ (let* ((sockaddr (make-sockaddr-for socket)))
+ (when (= (sb-sys:without-gcing
+ (sockint::getsockname (socket-file-descriptor socket)
+ (sockint::array-data-address sockaddr)
+ (size-of-sockaddr socket)))
+ -1)
+ (socket-error "getsockname"))
+ (bits-of-sockaddr socket sockaddr)))
+
+
+;;; There are a whole bunch of interesting things you can do with a
+;;; socket that don't really map onto "do stream io", especially in
+;;; CL which has no portable concept of a "short read". socket-receive
+;;; allows us to read from an unconnected socket into a buffer, and
+;;; to learn who the sender of the packet was
+
+(defmethod socket-receive ((socket socket) buffer length
+ &key
+ oob peek waitall
+ (element-type 'character))
+ "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
+NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
+used, so at least one of these two arguments must be non-NIL. If
+BUFFER is supplied, it had better be of an element type one octet wide.
+Returns the buffer, its length, and the address of the peer
+that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
+so that the actual packet length is returned even if the buffer was too
+small"
+ (let ((flags
+ (logior (if oob sockint::MSG-OOB 0)
+ (if peek sockint::MSG-PEEK 0)
+ (if waitall sockint::MSG-WAITALL 0)
+ sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
+ (if (eql (socket-type socket) :datagram)
+ sockint::msg-TRUNC 0)))
+ (sockaddr (make-sockaddr-for socket)))
+ (unless (or buffer length)
+ (error "Must supply at least one of BUFFER or LENGTH"))
+ (unless buffer
+ (setf buffer (make-array length :element-type element-type)))
+ (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
+ (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
+ (sb-sys:without-gcing
+ (let ((len
+ (sockint::recvfrom (socket-file-descriptor socket)
+ (sockint::array-data-address buffer)
+ (or length (length buffer))
+ flags
+ (sockint::array-data-address sockaddr)
+ (sb-alien:cast sa-len (* integer)))))
+ (when (= len -1) (socket-error "recvfrom"))
+ (apply #'values buffer len (multiple-value-list
+ (bits-of-sockaddr socket sockaddr))))))))
+
+
+
+(defmethod socket-listen ((socket socket) backlog)
+ "Mark SOCKET as willing to accept incoming connections. BACKLOG
+defines the maximum length that the queue of pending connections may
+grow to before new connection attempts are refused. See also listen(2)"
+ (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
+ (if (= r -1)
+ (socket-error "listen"))))
+
+(defmethod socket-close ((socket socket))
+ "Close SOCKET. May throw any kind of error that write(2) would have
+thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
+stream instead"
+ ;; the close(2) manual page has all kinds of warning about not
+ ;; checking the return value of close, on the grounds that an
+ ;; earlier write(2) might have returned successfully w/o actually
+ ;; writing the stuff to disk. It then goes on to define the only
+ ;; possible error return as EBADF (fd isn't a valid open file
+ ;; descriptor). Presumably this is an oversight and we could also
+ ;; get anything that write(2) would have given us.
+
+ ;; What we do: we catch EBADF. It should only ever happen if
+ ;; (a) someone's closed the socket already (stream closing seems
+ ;; to have this effect) or (b) the caller is messing around with
+ ;; socket internals. That's not supported, dude
+
+ (if (slot-boundp socket 'stream)
+ (close (slot-value socket 'stream)) ;; closes socket as well
+ (handler-case
+ (if (= (sockint::close (socket-file-descriptor socket)) -1)
+ (socket-error "close"))
+ (bad-file-descriptor-error (c) (declare (ignore c)) nil)
+ (:no-error (c) (declare (ignore c)) nil))))
+
+(defmethod socket-make-stream ((socket socket) &rest args)
+ "Find or create a STREAM that can be used for IO on SOCKET (which
+must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM."
+ (let ((stream
+ (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
+ (unless stream
+ (setf stream (apply #'sb-sys:make-fd-stream
+ (socket-file-descriptor socket) args))
+ (setf (slot-value socket 'stream) stream)
+ (sb-ext:cancel-finalization socket))
+ stream))
+
+\f
+
+;;; Error handling
+
+(define-condition socket-error (error)
+ ((errno :initform nil
+ :initarg :errno
+ :reader socket-error-errno)
+ (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
+ (syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall))
+ (:report (lambda (c s)
+ (let ((num (socket-error-errno c)))
+ (format s "Socket error in \"~A\": ~A (~A)"
+ (socket-error-syscall c)
+ (or (socket-error-symbol c) (socket-error-errno c))
+ #+cmu (sb-unix:get-unix-error-msg num)
+ #+sbcl (sb-int:strerror num))))))
+
+;;; watch out for slightly hacky symbol punning: we use both the value
+;;; and the symbol-name of sockint::efoo
+
+(defmacro define-socket-condition (symbol name)
+ `(progn
+ (define-condition ,name (socket-error)
+ ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
+ (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
+
+(defparameter *conditions-for-errno* nil)
+;;; this needs the rest of the list adding to it, really. They also
+;;; need
+;;; - conditions to be exported in the DEFPACKAGE form
+;;; - symbols to be added to constants.ccon
+;;; I haven't yet thought of a non-kludgey way of keeping all this in
+;;; the same place
+(define-socket-condition sockint::EADDRINUSE address-in-use-error)
+(define-socket-condition sockint::EAGAIN interrupted-error)
+(define-socket-condition sockint::EBADF bad-file-descriptor-error)
+(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
+(define-socket-condition sockint::EINTR interrupted-error)
+(define-socket-condition sockint::EINVAL invalid-argument-error)
+(define-socket-condition sockint::ENOBUFS no-buffers-error)
+(define-socket-condition sockint::ENOMEM out-of-memory-error)
+(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
+(define-socket-condition sockint::EPERM operation-not-permitted-error)
+(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
+(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
+(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
+
+
+(defun condition-for-errno (err)
+ (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
+
+#+cmu
+(defun socket-error (where)
+ ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
+ ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
+ ;; to update the value that unix-errno looks at. On other CMUCL
+ ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
+ (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
+ (let ((condition (condition-for-errno sb-unix:unix-errno)))
+ (error condition :errno sb-unix:unix-errno :syscall where)))
+
+#+sbcl
+(defun socket-error (where)
+ (let* ((errno (sb-unix::get-errno))
+ (condition (condition-for-errno errno)))
+ (error condition :errno errno :syscall where)))
+
+
+
--- /dev/null
+(in-package :bsd-sockets)
+
+#||
+<H2> Socket Options </h2>
+<a name="sockopt"> </a>
+<p> A subset of socket options are supported, using a fairly
+general framework which should make it simple to add more as required
+- see sockopt.lisp for details. The name mapping from C is fairly
+straightforward: <tt>SO_RCVLOWAT</tt> becomes
+<tt>sockopt-receive-low-water</tt> and <tt>(setf
+sockopt-receive-low-water)</tt>.
+||#
+
+#|
+getsockopt(socket, level, int optname, void *optval, socklen_t *optlen)
+setsockopt(socket, level, int optname, void *optval, socklen_t optlen)
+ ^ SOL_SOCKET or a protocol number
+
+In terms of providing a useful interface, we have to face up to the
+fact that most of these take different data types - some are integers,
+some are booleans, some are foreign struct instances, etc etc
+
+(define-socket-option lisp-name level number mangle-arg size mangle-return)
+
+macro-expands to two functions that define lisp-name and (setf ,lisp-name)
+and calls the functions mangle-arg and mangle-return on outgoing and incoming
+data resp.
+
+Parameters passed to the function thus defined (lisp-name)
+are all passed directly into mangle-arg. mangle-arg should return an
+alien pointer - this is passed unscathed to the foreign routine, so
+wants to have type (* t). Note that even for options that have
+integer arguments, this is still a pointer to said integer.
+
+size is the size of the buffer that the return of mangle-arg points
+to, and also of the buffer that we should allocate for getsockopt
+to write into.
+
+mangle-return is called with an alien buffer and should turn it into
+something that the caller will want.
+
+Code for options that not every system has should be conditionalised:
+
+(if (boundp 'sockint::IP_RECVIF)
+ (define-socket-option so-receive-interface (getprotobyname "ip")
+ sockint::IP_RECVIF ... ))
+
+
+|#
+
+(defmacro define-socket-option
+ (lisp-name level number mangle-arg size mangle-return)
+ (let ((find-level
+ (if (numberp (eval level))
+ level
+ `(get-protocol-by-name ,(string-downcase (symbol-name level))))))
+ `(progn
+ (export ',lisp-name)
+ (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket)))
+ (sb-sys:without-gcing
+ (let ((buf (make-array sockint::size-of-int
+ :element-type '(unsigned-byte 8)
+ :initial-element 0)))
+ (if (= -1 (sockint::getsockopt
+ fd ,find-level ,number (sockint::array-data-address buf) ,size))
+ (socket-error "getsockopt")
+ (,mangle-return buf ,size)))))
+ (defun (setf ,lisp-name) (new-val socket
+ &aux (fd (socket-file-descriptor socket)))
+ (if (= -1
+ (sb-sys:without-gcing
+ (sockint::setsockopt
+ fd ,find-level ,number (funcall (function ,mangle-arg) new-val ,size)
+ ,size)))
+ (socket-error "setsockopt"))))))
+
+;;; sockopts that have integer arguments
+
+(defun int-to-foreign (x size)
+ ;; can't use with-alien, as the variables it creates only have
+ ;; dynamic scope. can't use the passed-in size because sap-alien
+ ;; is a macro and evaluates its second arg at read time
+ (let* ((v (make-array size :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (d (sockint::array-data-address v))
+ (alien (sb-alien:sap-alien
+ d; (sb-sys:int-sap d)
+ (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
+ (setf (sb-alien:deref alien 0) x)
+ alien))
+
+(defun buffer-to-int (x size)
+ (declare (ignore size))
+ (let ((alien (sb-alien:sap-alien
+ (sockint::array-data-address x)
+ (* (sb-alien:signed #.(* 8 sockint::size-of-int))))))
+ (sb-alien:deref alien)))
+
+(defmacro define-socket-option-int (name level number)
+ `(define-socket-option ,name ,level ,number
+ int-to-foreign sockint::size-of-int buffer-to-int))
+
+(define-socket-option-int
+ sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
+(define-socket-option-int
+ sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat)
+(define-socket-option-int
+ sockopt-type sockint::sol-socket sockint::so-type)
+(define-socket-option-int
+ sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
+(define-socket-option-int
+ sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
+(define-socket-option-int
+ sockopt-priority sockint::sol-socket sockint::so-priority)
+
+;;; boolean options are integers really
+
+(defun bool-to-foreign (x size)
+ (int-to-foreign (if x 1 0) size))
+
+(defun buffer-to-bool (x size)
+ (not (= (buffer-to-int x size) 0)))
+
+(defmacro define-socket-option-bool (name level number)
+ `(define-socket-option ,name ,level ,number
+ bool-to-foreign sockint::size-of-int buffer-to-bool))
+
+(define-socket-option-bool
+ sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
+(define-socket-option-bool
+ sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
+(define-socket-option-bool
+ sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
+(define-socket-option-bool
+ sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat)
+(define-socket-option-bool
+ sockopt-pass-credentials sockint::sol-socket sockint::so-passcred)
+(define-socket-option-bool
+ sockopt-debug sockint::sol-socket sockint::so-debug)
+(define-socket-option-bool
+ sockopt-dont-route sockint::sol-socket sockint::so-dontroute)
+(define-socket-option-bool
+ sockopt-broadcast sockint::sol-socket sockint::so-broadcast)
+
+(define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay)
+
+(defun string-to-foreign (string size)
+ (declare (ignore size))
+ (let ((data (sockint::array-data-address string)))
+ (sb-alien:sap-alien data (* t))))
+
+(defun buffer-to-string (x size)
+ (declare (ignore size))
+ (sb-c-call::%naturalize-c-string
+ (sockint::array-data-address x)))
+
+(define-socket-option sockopt-bind-to-device sockint::sol-socket
+ sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz
+ buffer-to-string)
+
+;;; other kinds of socket option
+
+;;; so_peercred takes a ucre structure
+;;; so_linger struct linger {
+; int l_onoff; /* linger active */
+; int l_linger; /* how many seconds to linger for */
+; };
+
+#|
+
+(sockopt-reuse-address 2)
+
+(defun echo-server ()
+ (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp"))))
+ (setf (sockopt-reuse-address s) t)
+ (setf (sockopt-bind-to-device s) "lo")
+ (socket-bind s (make-inet-address "127.0.0.1") 3459)
+ (socket-listen s 5)
+ (dotimes (i 10)
+ (let* ((s1 (socket-accept s))
+ (stream (socket-make-stream s1 :input t :output t :buffering :none)))
+ (let ((line (read-line stream)))
+ (format t "got one ~A ~%" line)
+ (format stream "~A~%" line))
+ (close stream)))))
+
+NIL
+|#
+
--- /dev/null
+(in-package :bsd-sockets)
+
+;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100
+;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de>
+
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ "Split `string' along whitespace as defined by the sequence `ws'.
+The whitespace is elided from the result. The whole string will be
+split, unless `max' is a non-negative integer, in which case the
+string will be split into `max' tokens at most, the last one
+containing the whole rest of the given `string', if any."
+ (flet ((is-ws (char) (find char ws)))
+ (loop for start = (position-if-not #'is-ws string)
+ then (position-if-not #'is-ws string :start index)
+ for index = (and start
+ (if (and max (= (1+ word-count) max))
+ nil
+ (position-if #'is-ws string :start start)))
+ while start
+ collect (subseq string start index)
+ count 1 into word-count
+ while index)))
+
--- /dev/null
+(defpackage "BSD-SOCKETS-TEST"
+ (:use "CL" "BSD-SOCKETS" "RT"))
+
+#||
+
+<H1>Tests</h1>
+
+There should be at least one test for pretty much everything you can do
+with the package. In some places I've been more diligent than others; more
+tests gratefully accepted.
+
+Tests are in the file <tt>tests.lisp</tt> and also make good examples.
+
+||#
+
+(in-package :bsd-sockets-test)
+
+;;; a real address
+(deftest make-inet-address
+ (equalp (make-inet-address "127.0.0.1") #(127 0 0 1))
+ t)
+;;; and an address with bit 8 set on some octets
+(deftest make-inet-address2
+ (equalp (make-inet-address "242.1.211.3") #(242 1 211 3))
+ t)
+
+(deftest make-inet-socket
+ ;; make a socket
+ (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+ (and (> (socket-file-descriptor s) 1) t))
+ t)
+
+(deftest make-inet-socket-keyword
+ ;; make a socket
+ (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+ (and (> (socket-file-descriptor s) 1) t))
+ t)
+
+(deftest make-inet-socket-wrong
+ ;; fail to make a socket: check correct error return. There's no nice
+ ;; way to check the condition stuff on its own, which is a shame
+ (handler-case
+ (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp"))
+ ((or socket-type-not-supported-error protocol-not-supported-error) (c)
+ (declare (ignorable c)) t)
+ (:no-error nil))
+ t)
+
+(deftest make-inet-socket-keyword-wrong
+ ;; same again with keywords
+ (handler-case
+ (make-instance 'inet-socket :type :stream :protocol :udp)
+ ((or protocol-not-supported-error socket-type-not-supported-error) (c)
+ (declare (ignorable c)) t)
+ (:no-error nil))
+ t)
+
+
+(deftest non-block-socket
+ (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+ (setf (non-blocking-mode s) t)
+ (non-blocking-mode s))
+ t)
+
+(defun do-gc-portably ()
+ ;; cmucl on linux has generational gc with a keyword argument,
+ ;; sbcl GC function takes same arguments no matter what collector is in
+ ;; use
+ #+(or sbcl gencgc) (SB-EXT:gc :full t)
+ ;; other platforms have full gc or nothing
+ #-(or sbcl gencgc) (sb-ext:gc))
+
+(deftest inet-socket-bind
+ (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+ ;; Given the functions we've got so far, if you can think of a
+ ;; better way to make sure the bind succeeded than trying it
+ ;; twice, let me know
+ ;; 1974 has no special significance, unless you're the same age as me
+ (do-gc-portably) ;gc should clear out any old sockets bound to this port
+ (socket-bind s (make-inet-address "127.0.0.1") 1974)
+ (handler-case
+ (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+ (socket-bind s2 (make-inet-address "127.0.0.1") 1974)
+ nil)
+ (address-in-use-error () t)))
+ t)
+
+(deftest simple-sockopt-test
+ ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in
+ ;; the process that all the weird macros in sockopt happened right.
+ (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+ (setf (sockopt-reuse-address s) t)
+ (sockopt-reuse-address s))
+ t)
+
+(defun read-buf-nonblock (buffer stream)
+ "Like READ-SEQUENCE, but returns early if the full quantity of data isn't there to be read. Blocks if no input at all"
+ (let ((eof (gensym)))
+ (do ((i 0 (1+ i))
+ (c (read-char stream nil eof)
+ (read-char-no-hang stream nil eof)))
+ ((or (>= i (length buffer)) (not c) (eq c eof)) i)
+ (setf (elt buffer i) c))))
+
+;;; these require that the echo services are turned on in inetd
+
+(deftest simple-tcp-client
+ (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
+ (data (make-string 200)))
+ (socket-connect s #(127 0 0 1) 7)
+ (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+ (format stream "here is some text")
+ (let ((data (subseq data 0 (read-buf-nonblock data stream))))
+ (format t "~&Got ~S back from TCP echo server~%" data)
+ (> (length data) 0))))
+ t)
+
+(deftest simple-udp-client
+ (let ((s (make-instance 'inet-socket :type :datagram :protocol (get-protocol-by-name "udp")))
+ (data (make-string 200)))
+ (format t "Socket type is ~A~%" (sockopt-type s))
+ (socket-connect s #(127 0 0 1) 7)
+ (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+ (format stream "here is some text")
+ (let ((data (subseq data 0 (read-buf-nonblock data stream))))
+ (format t "~&Got ~S back from UDP echo server~%" data)
+ (> (length data) 0))))
+ t)
+
+#||
+<h2>Unix-domain sockets</h2>
+
+A fairly rudimentary test that connects to the syslog socket and sends a
+message. Priority 7 is kern.debug; you'll probably want to look at
+/etc/syslog.conf or local equivalent to find out where the message ended up
+||#
+
+(deftest simple-unix-client
+ (let ((s (make-instance 'unix-socket :type :datagram)))
+ (format t "~A~%" s)
+ (socket-connect s "/dev/log")
+ (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+ (format stream
+ "<7>bsd-sockets: Don't panic. We're testing unix-domain client code; this message can safely be ignored")
+ t))
+ t)
+
+
+;;; these require that the internet (or bits of it, atleast) is available
+
+(deftest get-host-by-name
+ (equalp (car (host-ent-addresses (get-host-by-name "a.root-servers.net")))
+ #(198 41 0 4))
+ t)
+
+(deftest get-host-by-address
+ (host-ent-name (get-host-by-address #(198 41 0 4)))
+ "a.root-servers.net")
+
+(deftest get-host-by-name-wrong
+ (handler-case
+ (get-host-by-name "foo.tninkpad.telent.net")
+ (NAME-SERVICE-ERROR () t)
+ (:no-error nil))
+ t)
+
+(defun http-stream (host port request)
+ (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+ (socket-connect
+ s (car (host-ent-addresses (get-host-by-name host))) port)
+ (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+ (format stream "~A HTTP/1.0~%~%" request))
+ s))
+
+(deftest simple-http-client-1
+ (handler-case
+ (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
+ (let ((data (make-string 200)))
+ (setf data (subseq data 0
+ (read-buf-nonblock data
+ (socket-make-stream s))))
+ (princ data)
+ (> (length data) 0)))
+ (network-unreachable-error () 'network-unreachable))
+ t)
+
+
+(deftest sockopt-receive-buffer
+ ;; on Linux x86, the receive buffer size appears to be doubled in the
+ ;; kernel: we set a size of x and then getsockopt() returns 2x.
+ ;; This is why we compare with >= instead of =
+ (handler-case
+ (let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
+ (setf (sockopt-receive-buffer s) 1975)
+ (let ((data (make-string 200)))
+ (setf data (subseq data 0
+ (read-buf-nonblock data
+ (socket-make-stream s))))
+ (and (> (length data) 0)
+ (>= (sockopt-receive-buffer s) 1975))))
+ (network-unreachable-error () 'network-unreachable))
+ t)
+
+
+;;; we don't have an automatic test for some of this yet. There's no
+;;; simple way to run servers and have something automatically connect
+;;; to them as client, unless we spawn external programs. Then we
+;;; have to start telling people what external programs they should
+;;; have installed. Which, eventually, we will, but not just yet
+
+
+;;; to check with this: can display packets from multiple peers
+;;; peer address is shown correctly for each packet
+;;; packet length is correct
+;;; long (>500 byte) packets have the full length shown (doesn't work)
+
+(defun udp-server (port)
+ (let ((s (make-instance 'inet-socket :type :datagram :protocol :udp)))
+ (socket-bind s #(0 0 0 0) port)
+ (loop
+ (multiple-value-bind (buf len address port) (socket-receive s nil 500)
+ (format t "Received ~A bytes from ~A:~A - ~A ~%"
+ len address port (subseq buf 0 (min 10 len)))))))
+
+
--- /dev/null
+(in-package :bsd-sockets)
+
+#|| <h2>File-domain sockets</h2>
+
+File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were
+renamed by POSIX presumably on the basis that they may be
+available on other systems too.
+
+A file-domain socket address is a string, which is used to create a node
+in the local filesystem. This means of course that they cannot be used across
+a network.
+
+||#
+
+(defclass unix-socket (socket)
+ ((family :initform sockint::af-unix)))
+
+(defmethod make-sockaddr-for ((socket unix-socket) &optional sockaddr &rest address &aux (filename (first address)))
+ (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un))))
+ (setf (sockint::sockaddr-un-family sockaddr) sockint::af-unix)
+ (when filename
+ (loop for c across filename
+ ;; XXX magic constant ew ew ew. should grovel this from
+ ;; system headers
+ for i from 0 to (min 107 (1- (length filename)))
+ do (setf (sockint::sockaddr-un-path sockaddr i) (char-code c))
+ finally
+ (setf (sockint::sockaddr-un-path sockaddr (1+ i)) 0)))
+ sockaddr))
+
+(defmethod size-of-sockaddr ((socket unix-socket))
+ sockint::size-of-sockaddr-un)
+
+(defmethod bits-of-sockaddr ((socket unix-socket) sockaddr)
+ "Returns filename of SOCKADDR"
+ (let ((name (sb-c-call::%naturalize-c-string
+ (sb-sys:sap+ (sockint::array-data-address sockaddr)
+ sockint::offset-of-sockaddr-un-path))))
+ (if (zerop (length name)) nil name)))
+
# Install SBCL files into the usual places.
-cp /usr/local/bin/sbcl /usr/local/bin/sbcl.old
-cp /usr/local/lib/sbcl.core /usr/local/lib/sbcl.core.old
+function ensure_dirs ()
+{
+ for j in $*; do
+ test -d $j || mkdir $j
+ done;
+}
-cp src/runtime/sbcl /usr/local/bin/
-cp output/sbcl.core /usr/local/lib/
-cp doc/sbcl.1 /usr/local/man/man1/
+INSTALL_ROOT=${INSTALL_ROOT-/usr/local}
+SBCL_SOURCE=`pwd`
+if [ -n "$SBCL_HOME" -a "$INSTALL_ROOT/lib/sbcl" != "$SBCL_HOME" ];then
+ echo SBCL_HOME environment variable is set, and conflicts with INSTALL_ROOT.
+ echo Aborting installation. Unset one or reset the other, then try again
+ echo INSTALL_ROOT="$INSTALL_ROOT"
+ echo SBCL_HOME="$SBCL_HOME"
+ exit 1
+fi
+SBCL_HOME=$INSTALL_ROOT/lib/sbcl
+export SBCL_HOME
+ensure_dirs $INSTALL_ROOT $INSTALL_ROOT/bin $INSTALL_ROOT/lib \
+ $INSTALL_ROOT/man $INSTALL_ROOT/man/man1 \
+ $SBCL_HOME $SBCL_HOME/systems
+
+test -a $INSTALL_ROOT/bin/sbcl && \
+ cp $INSTALL_ROOT/bin/sbcl $INSTALL_ROOT/bin/sbcl.old
+test -a $SBCL_HOME/sbcl.core && \
+ cp $SBCL_HOME/sbcl.core $SBCL_HOME/sbcl.core.old
+
+cp src/runtime/sbcl $INSTALL_ROOT/bin/
+cp output/sbcl.core $SBCL_HOME/sbcl.core
+cp doc/sbcl.1 $INSTALL_ROOT/man/man1/
+
+# installing contrib
+
+SBCL="`pwd`/src/runtime/sbcl --noinform --core `pwd`/output/sbcl.core --userinit /dev/null --sysinit /dev/null --disable-debugger"
+SBCL_BUILDING_CONTRIB=1
+export SBCL SBCL_BUILDING_CONTRIB
+for i in contrib/*; do
+ test -d $i || continue;
+ export INSTALL_DIR=$SBCL_HOME/`basename $i `
+ make -C $i test && ensure_dirs $INSTALL_DIR && make -C $i install
+done
;; miscellaneous useful supported extensions
"QUIT"
-
+ "*MODULE-PROVIDER-FUNCTIONS*"
+
;; RUN-PROGRAM is not only useful for users, but also
;; useful to implement parts of SBCL itself, so we're
;; going to have to implement it anyway, so we might
;;;; REQUIRE, PROVIDE, and friends
;;;;
-;;;; Note that this module file is based on the old system, and is being
-;;;; spliced into the current sources to reflect the last minute deprecated
-;;;; addition of modules to the X3J13 ANSI standard.
-;;;;
-;;;; FIXME: This implementation has cruft not required by the ANSI
-;;;; spec, notably DEFMODULE. We should probably minimize it, since
-;;;; it's deprecated anyway.
+;;;; Officially these are deprecated, but in practice they're probably
+;;;; even less likely to actually go away than there is to ever be
+;;;; another revision of the standard.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
"This is a list of module names that have been loaded into Lisp so far.
It is used by PROVIDE and REQUIRE.")
-;;;; DEFMODULE
-;;;; FIXME: Remove this.
-
-(defvar *module-file-translations* (make-hash-table :test 'equal))
-(defmacro defmodule (name &rest files)
- #!+sb-doc
- "Defines a module by registering the files that need to be loaded when
- the module is required. If name is a symbol, its print name is used
- after downcasing it."
- `(%define-module ,name ',files))
-
-(defun %define-module (name files)
- (setf (gethash (module-name-string name) *module-file-translations*)
- files))
+(defvar sb!ext::*MODULE-PROVIDER-FUNCTIONS* '(module-provide-contrib)
+ "See function documentation for REQUIRE")
-(defun module-files (name)
- (gethash name *module-file-translations*))
\f
;;;; PROVIDE and REQUIRE
(defun provide (module-name)
#!+sb-doc
"Adds a new module name to *MODULES* indicating that it has been loaded.
- Module-name may be either a case-sensitive string or a symbol; if it is
- a symbol, its print name is downcased and used."
- (pushnew (module-name-string module-name) *modules* :test #'string=)
+ Module-name is a string designator"
+ (pushnew (string module-name) *modules* :test #'string=)
t)
-(defun require (module-name &optional pathname)
+(defun require (module-name &optional pathnames)
#!+sb-doc
- "Loads a module when it has not been already. PATHNAME, if supplied,
- is a single pathname or list of pathnames to be loaded if the module
- needs to be. If PATHNAME is not supplied, then a list of files are
- looked for that were registered by a DEFMODULE form. If the module
- has not been defined, then a file will be loaded whose name is formed
- by merging \"modules:\" and MODULE-NAME (downcased if it is a symbol).
- This merged name will be probed with both a .lisp extension and any
- architecture-specific FASL extensions, and LOAD will be called on it
- if it is found."
- ;; KLUDGE: Does this really match the doc string any more? (Did it ever
- ;; match the doc string? Arguably this isn't a high priority question
- ;; since REQUIRE is deprecated anyway and I've not been very motivated
- ;; to maintain CMU CL extensions like DEFMODULE.. -- WHN 19990804
- (setf module-name
- (module-name-string module-name))
- (unless (member module-name *modules* :test #'string=)
- (if pathname
- (unless (listp pathname) (setf pathname (list pathname)))
- (let ((files (module-files module-name)))
- (if files
- (setf pathname files)
- (setf pathname (list (merge-pathnames "modules:" module-name))))))
- (dolist (ele pathname t)
- (load ele))))
+ "Loads a module, unless it already has been loaded. PATHNAMES, if supplied,
+ is a designator for a list of pathnames to be loaded if the module
+ needs to be. If PATHNAMES is not supplied, functions from the list
+ *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME
+ as an argument, until one of them returns non-NIL."
+ (unless (member (string module-name) *modules* :test #'string=)
+ (cond (pathnames
+ (unless (listp pathnames) (setf pathnames (list pathnames)))
+ ;; ambiguity in standard: should we try all pathnames in the
+ ;; list, or should we stop as soon as one of them calls PROVIDE?
+ (dolist (ele pathnames t)
+ (load ele)))
+ (t
+ (unless (some (lambda (p) (funcall p module-name))
+ sb!ext::*module-provider-functions*)
+ (error "Don't know how to load ~A" module-name))))))
+
\f
;;;; miscellany
-(defun module-name-string (name)
- (typecase name
- (string name)
- (symbol (string-downcase (symbol-name name)))
- (t (error 'simple-type-error
- :datum name
- :expected-type '(or string symbol)
- :format-control "Module name must be a string or symbol: ~S"
- :format-arguments (list name)))))
+(defun module-provide-contrib (name)
+ "Stringify and downcase NAME if it is a symbol, then attempt to load
+ the file $SBCL_HOME/name/name"
+ (let ((name (if (symbolp name) (string-downcase (symbol-name name)) name)))
+ (load
+ (merge-pathnames (make-pathname :directory (list :relative name)
+ :name name)
+ (truename (posix-getenv "SBCL_HOME")))))
+ (provide name))
+
+
core = copied_existing_filename_or_null(lookhere);
free(lookhere);
} else {
- core = copied_existing_filename_or_null("/usr/lib/sbcl.core");
+ putenv("SBCL_HOME=/usr/local/lib/sbcl/");
+ core = copied_existing_filename_or_null("/usr/local/lib/sbcl/sbcl.core");
if (!core) {
+ putenv("SBCL_HOME=/usr/lib/sbcl/");
core =
- copied_existing_filename_or_null("/usr/local/lib/sbcl.core");
+ copied_existing_filename_or_null("/usr/lib/sbcl/sbcl.core");
}
}
if (!core) {
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.12.23"
+"0.7.12.24"
projects / sbcl.git / commitdiff