From edc8da40fb17de047e290ed6bd819e096e435dc9 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Fri, 7 Feb 2003 02:11:09 +0000 Subject: [PATCH] 0.7.12.24 Changes to PROVIDE/REQUIRE to make them (a) conform to ANSI, (b) any use... ... cease nonstandardly downcasing elements in *MODULES* ... add a list of *MODULE-PROVIDER-FUNCTIONS* which the user can hang functions off to make REQUIRE do whatever he wants it to do. ... its default member knows how to load files in $SBCL_ROOT/modulename/modulename First pass at a contrib infrastructure... ... change install.sh to do new and exciting things, and as a side benefit, able to install other than into /usr/local ... amend INSTALL instructions to match Two contrib modules... ... asdf here is a direct copy of the one in cclan, but despite being portable and therefore not really qualifying, will be v. useful for loading the others ... bsd-sockets (db-sockets by any other name) is a fairly low-level interface to the BSD socket API: high-level interfaces (e.g. ACL-compatible, or CLOCC PORT) could be built on top of it without getting dirty with ALIEN --- INSTALL | 22 +- contrib/STANDARDS | 101 ++++ contrib/asdf/Makefile | 8 + contrib/asdf/asdf.lisp | 937 +++++++++++++++++++++++++++++++ contrib/bsd-sockets/FAQ | 47 ++ contrib/bsd-sockets/Makefile | 13 + contrib/bsd-sockets/NEWS | 135 +++++ contrib/bsd-sockets/README | 29 + contrib/bsd-sockets/TODO | 20 + contrib/bsd-sockets/alien.so | Bin 0 -> 5373 bytes contrib/bsd-sockets/alien/get-h-errno.c | 6 + contrib/bsd-sockets/alien/undefs.c | 9 + contrib/bsd-sockets/api-reference.html | 188 +++++++ contrib/bsd-sockets/array-data.lisp | 72 +++ contrib/bsd-sockets/bsd-sockets.asd | 127 +++++ contrib/bsd-sockets/constants.lisp | 189 +++++++ contrib/bsd-sockets/constants.lisp-temp | 170 ++++++ contrib/bsd-sockets/def-to-lisp.lisp | 70 +++ contrib/bsd-sockets/defpackage.lisp | 123 ++++ contrib/bsd-sockets/doc.lisp | 225 ++++++++ contrib/bsd-sockets/foreign-glue.lisp | 88 +++ contrib/bsd-sockets/inet.lisp | 94 ++++ contrib/bsd-sockets/malloc.lisp | 16 + contrib/bsd-sockets/misc.lisp | 36 ++ contrib/bsd-sockets/name-service.lisp | 144 +++++ contrib/bsd-sockets/rt.lisp | 167 ++++++ contrib/bsd-sockets/sockets.lisp | 279 +++++++++ contrib/bsd-sockets/sockopt.lisp | 189 +++++++ contrib/bsd-sockets/split.lisp | 23 + contrib/bsd-sockets/tests.lisp | 225 ++++++++ contrib/bsd-sockets/unix.lisp | 40 ++ install.sh | 45 +- package-data-list.lisp-expr | 3 +- src/code/module.lisp | 96 ++-- src/runtime/runtime.c | 6 +- version.lisp-expr | 2 +- 36 files changed, 3870 insertions(+), 74 deletions(-) create mode 100644 contrib/STANDARDS create mode 100644 contrib/asdf/Makefile create mode 100644 contrib/asdf/asdf.lisp create mode 100644 contrib/bsd-sockets/FAQ create mode 100644 contrib/bsd-sockets/Makefile create mode 100644 contrib/bsd-sockets/NEWS create mode 100644 contrib/bsd-sockets/README create mode 100644 contrib/bsd-sockets/TODO create mode 100755 contrib/bsd-sockets/alien.so create mode 100755 contrib/bsd-sockets/alien/get-h-errno.c create mode 100644 contrib/bsd-sockets/alien/undefs.c create mode 100644 contrib/bsd-sockets/api-reference.html create mode 100644 contrib/bsd-sockets/array-data.lisp create mode 100644 contrib/bsd-sockets/bsd-sockets.asd create mode 100644 contrib/bsd-sockets/constants.lisp create mode 100644 contrib/bsd-sockets/constants.lisp-temp create mode 100644 contrib/bsd-sockets/def-to-lisp.lisp create mode 100644 contrib/bsd-sockets/defpackage.lisp create mode 100644 contrib/bsd-sockets/doc.lisp create mode 100644 contrib/bsd-sockets/foreign-glue.lisp create mode 100644 contrib/bsd-sockets/inet.lisp create mode 100644 contrib/bsd-sockets/malloc.lisp create mode 100644 contrib/bsd-sockets/misc.lisp create mode 100644 contrib/bsd-sockets/name-service.lisp create mode 100644 contrib/bsd-sockets/rt.lisp create mode 100644 contrib/bsd-sockets/sockets.lisp create mode 100644 contrib/bsd-sockets/sockopt.lisp create mode 100644 contrib/bsd-sockets/split.lisp create mode 100644 contrib/bsd-sockets/tests.lisp create mode 100644 contrib/bsd-sockets/unix.lisp diff --git a/INSTALL b/INSTALL index 028e1ba..464a644 100644 --- a/INSTALL +++ b/INSTALL @@ -1,6 +1,6 @@ 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 @@ -17,7 +17,8 @@ stuff. 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 @@ -31,10 +32,21 @@ testing or other special cases. 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: diff --git a/contrib/STANDARDS b/contrib/STANDARDS new file mode 100644 index 0000000..f5b9598 --- /dev/null +++ b/contrib/STANDARDS @@ -0,0 +1,101 @@ +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)] + + diff --git a/contrib/asdf/Makefile b/contrib/asdf/Makefile new file mode 100644 index 0000000..3067de6 --- /dev/null +++ b/contrib/asdf/Makefile @@ -0,0 +1,8 @@ +asdf.fasl: asdf.lisp + $(SBCL) --eval '(compile-file "asdf")' . But note first that the canonical +;;; source for asdf is presently the cCLan CVS repository at +;;; +;;; +;;; 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*)) diff --git a/contrib/bsd-sockets/FAQ b/contrib/bsd-sockets/FAQ new file mode 100644 index 0000000..d788eb2 --- /dev/null +++ b/contrib/bsd-sockets/FAQ @@ -0,0 +1,47 @@ +Frequently Asked Questions + +Q1) Is this the same thing as db-sockets + +A1) Basically, yes. It's hoped that bundling it as a contrib may make +it easier for people to install. + +Q2) What are these test things? How do I run the tests? + +A2) Some of the tests get run automatically when the package is built +- if the tests fail, the package is not installed. The rest of the +tests depend on having Internet access which may not always be the +case on a build machine, but you can run them by hand from the Lisp +listener, if you want to: + +* (rt:do-tests) + +This uses the regression tester from the CMU AI repository to run the +tests defined in tests.lisp. You should not get any test failures, +unless - + +a) your "echo" services are disabled in inetd.conf - +SIMPLE-TCP-CLIENT and SIMPLE-UDP-CLIENT both attempt to connect to the +echo port. + +b) you're not on the internet - SIMPLE-HTTP-CLIENT attempts to connect to +ww.telent.net, and other tests do DNS lookups for well-known hosts + +c) a.root-servers.net has moved IP address + +Q3) What's constants.lisp-temp? + +A3) Many of the structure offsets and symbolic constants vary between +architectures and operating systems. To avoid a maintenance +nightmare, we derive them automatically by creating and running a +small C program. The C program is created by def-to-lisp.lisp +with input from constants.lisp + +Some of the exciting stuff in bsd-sockets.asd writes a C program in +/tmp, compiles it, and runs it. The output from this program becomes +constants.lisp-temp + +Q4) Is this compatible with ACL? With CMUCL's internet.lisp? + +A4) No. This is a sufficiently low-level interface that either could +be built on top of it, though. Actually, theq ACL-COMPAT library that +comes with Portable Allegroserve may already have this. diff --git a/contrib/bsd-sockets/Makefile b/contrib/bsd-sockets/Makefile new file mode 100644 index 0000000..42a6e8e --- /dev/null +++ b/contrib/bsd-sockets/Makefile @@ -0,0 +1,13 @@ +SYSTEM=bsd-sockets + +all: + $(MAKE) -C ../asdf + echo "(asdf:operate 'asdf:load-op :$(SYSTEM))" | \ + $(SBCL) --eval '(load "../asdf/asdf")' + +test: + true + +install: all + tar cf - . | ( cd $(INSTALL_DIR) && tar xpvf - ) + ( cd $(SBCL_HOME)/systems && ln -fs ../$(SYSTEM)/$(SYSTEM).asd . ) diff --git a/contrib/bsd-sockets/NEWS b/contrib/bsd-sockets/NEWS new file mode 100644 index 0000000..c12398d --- /dev/null +++ b/contrib/bsd-sockets/NEWS @@ -0,0 +1,135 @@ +Changes in 0.58 - Sun Jan 12 00:53:53 GMT 2003 + +Fix db-sockets.asd so that it doesn't recompile alien.so every single +time. + +Announce anon-cvs repo for people to get in-between versions + +MSG_NOSIGNAL is a linuxism, I'm told. + +Changes in 0.57 - Wed Sep 11 12:27:32 2002 + +Fix for compilation bug reported by Andreas Fuchs. Don't use 0.56, it +was a mistakenly uploaded file + +Changes in 0.55 - Tue Sep 10 23:42:27 2002 + +Fix for a unix-domain sockets problem, courtesy of David Lichteblau + +Changes in 0.54 - Wed Mar 6 2002 + +New version mostly due to new packaging format: this is now a +vendor-neutral cclan (vn-cclan) package. See INSTALL file + +Fixed bug in af_file support. + +Changes in 0.53 - Thu Jan 31 2002 + +By popular request (two people, at last count) this works in CMUCL again. +Also, some documentation updates, a really silly bug in make-instance +fixed, and support for the TCP_NODELAY socket option + +Changes in 0.52 - Tue Jan 8 2002 + +Very few. This release was put out a few days after 0.5.1 because +0.5.1 is less than 0.42, and various packaging tools tend to get +confused to see version numbers go backwards. + +Changes in 0.5.1 - Mon Jan 7 2002 + +Support for AF_FILE (formerly known as Unix-domain) sockets; both +stream and datagram. + +MAKE-INET-SOCKET has been deprecated (but is still there). New code is +encouraged to write (make-instance 'inet-socket ...) instead + +Fairly pervasive low-level changes to avoid leaking quite as much +memory. May also have fixed a file descriptor leak in the process. + +Changes in 0.42 + +Repackaged to be a debian-like package, and use +common-lisp-controller, which required a reasonably large amount of +thrashing around renaming files and so on. + +New function GET-HOST-BY-ADDRESS returns a HOST-ENT just like +GET-HOST-BY-NAME does. + +Tested on SBCL 0.6.12.7.flaky1.1 (x86), SBCL 0.6.12.7 (Alpha), +CMUCL 18c+ 2.5.2 (x86) + +Changes in 0.41 - Sun Jan 7 2001 + +Cleanups in the tests for more intelligible failure messages + +SOCKET-ERROR conditions now inherit from ERROR not CONDITION - as +otherwise IGNORE-ERROR doesn't ignore them, which is unexpected + +Tested on debian cmucl 2.4.19 , sbcl pre-0.6.9 snapshot of Nov 30 2000. + +The latter doesn't build without manual intervention: + + error in function SB-C::%DEFCONSTANT: + The constant INET-ADDRESS-ANY is being redefined. + +(just continue) + +Changes in 0.4 - Mon Jul 3 2000 + +Now works (passes tests) in + +- Solaris 2.6 SPARC (CMUCL 18b) +- Debian x86 GNU/Linux (Debian CMUCL 2.4.19) +- Debian x86 GNU/Linux (SBCL 0.6.5) + +Some CMUCL-on-FreeBSD changes (mostly involve commenting stuff out). Doesn't +work, though (but might in SBCL/FreeBSD) + +The Solaris changes comprised disabling bits and fixing an +endianness problem. + + +Changes in 0.37 - Sat May 20 2000 + + +Changes from Martin Atzmueller to make it compile more cleanly in SBCL + +Changes in 0.36 - Thu May 11 2000 + +Some documentation cleanups + +New functions NON-BLOCKING-MODE and (SETF NON-BLOCKING-MODE) + +EINTR now generates a INTERRUPTED-ERROR condition + + +Changes in 0.35 - Mon May 1 2000 + + +MAKE-INET-SOCKET now can take a keyword for PROTOCOL: it lowercases +the symbol's name, then looks it up using GET-PROTOCOL-BY-NAME + +A bad bug in the CMUCL code (which caused the EXTENSIONS package to +disappear - oops...) was found and fixed + + +Changes in 0.3 - Apr 17 2000 + +Now works with SBCL (0.6.1, 0.6.2) in addition to CMUCL. + +Fixed to actually work with a READ-SEQUENCE implementation that does +the right thing instead of the (suspected buggy) implementation in +CMUCL. At least, the Hyperspec doesn't give me any particular cause +for belief that READ-SEQUENCE can return before reading as much as the +user asks it to, which is what we were using it for hitherto. + +The Makefile got a lot bigger. defs-to-lisp.lisp got a lot smaller. + +Standard make target creates "sockets-system.x86f" which contains all +the code in a single file + +If you want to build it on SBCL you'll need a working defsystem for +said platform first. This involves some fiddling around: first you +need to get it from CLOCC on Sourceforge then you need to patch it +with this diff. Unless you're looking at a version newer than 1.12, in +which case they might have patched it already before you diff --git a/contrib/bsd-sockets/README b/contrib/bsd-sockets/README new file mode 100644 index 0000000..91e4df8 --- /dev/null +++ b/contrib/bsd-sockets/README @@ -0,0 +1,29 @@ +o/~ Hey Mr Tambourine Man, play some -*- Text -*- for me o/~ + +A semi-sane sockets interface for SBCL. Usually also works in CMUCL, +but is rarely actually tested there so may require some massaging + +See INSTALL for prerequisites and build details + +It uses the regression tester from the CMU AI repository. This is +bundled in the file rt.lisp which is unchanged except where I added a +DEFPACKAGE form. The tests themselves are in tests.lisp, and can be +run using the Makefile target intended for the purpose, or by +evaluating (rt:do-tests). Note that one of the tests is an HTTP +client that connects back to ww.telent.net; if this bothers your +expectations of privacy, don't run it. + +There is an automatically generated API reference in +api-reference.html which you can regenerate if you can figure out how +doc.lisp works. You might find the examples in tests.lisp useful, +too. + +Feedback, patches, development versions + +Instructions on how to access the CVS repository for db-sockets are +at http://cvs.telent.net/ + +If you find bugs or want to send patches for enhancements, by email to +Daniel Barlow , but please check the CVS version first. + +$Id$ diff --git a/contrib/bsd-sockets/TODO b/contrib/bsd-sockets/TODO new file mode 100644 index 0000000..90c82a3 --- /dev/null +++ b/contrib/bsd-sockets/TODO @@ -0,0 +1,20 @@ + +Things To Do - Urgent! (with apologies to Douglas Adams) + +I probably have opinions about how to do most of these. Even if not, +I almost certainly have opinions on how not to. Send me a proposal +before spending serious amounts of time on it. + +- the rest of the functions. A socket-send that doesn't use streams +would be a good one + +- the rest of the errors + +- the rest of the socket options: integer and boolean socket-level +options are in but need odd ones, plus tcp, udp, ip + +- async name service lookups. + +- write tests for socket-name and socket-peername + +- documentation: see doc.lisp, but beware: it's grotty. diff --git a/contrib/bsd-sockets/alien.so b/contrib/bsd-sockets/alien.so new file mode 100755 index 0000000000000000000000000000000000000000..67790fb5ae61cb7462d65980f7a2d38b0c0d0444 GIT binary patch literal 5373 zcmeHLYiJx*6h51+wT;oHHLY*E^+6-H<0g&b+qP*MBWYUuP_)+RWOtHX-R#8OiME1h z8AM_XRNEgSDx&>Sv_Dz}5mO{IMU4~*D%c+tLs8h+{!lCuL|nh`&fM8a8lfQm5IoD- zbH97eJ@@@M^K47|+E^?mn&J`{qMy$bX=3IDzNSeM(A3MNvQX*$T>pRcd=WB=h}4SG z9|JyiiO+R#xC}fy&{sj8fc^yZkGw3`#78eV)O|h|8N({5Qe34ZG4~RGBx(;q z`m0T(xHyZ29+$6!yxMFQ3%5$Xr!k1@n>%AnOUwuHG054-`-T#m`Zy&v_z6lJI3Gct z5B*_E=!YqB7#*d=g8G~i_FMXY^iIzyJpq@cJJH0_xA+?!k@5%J$mMtZUC9*pR|YH- z<7Lo0>_LX=i7|!ih?zMttS~B&4F4t$D$G+clOTQz7?O2w@=nhxF}-!y$U&^>0gt2o z{IFY99vj&9$LPrJ2&uN#ZPND7!QLCHr?bAaH?)jyT*EthX29c#T~3x>fX+Kwd+M^m z52-{xG6pxy>fgh}fS?YQ<=rZMC*g`l?mT!H^p?S3LunEIKl4}xXK!FzX>?@pNq@{L z?U=+#v2}E$|F>!F8%Mr3lu%9=c}FJ)JzioPwC{KSL=)(7_q1~ReSf>B=kG>-X`#(SBw>TU@RZr~$;Q-!)0)rp?jNW-e{4cvT1GCFx-luGNEP!$Vsw^*PVHw^8r=;3MF#z$d{ZeK+|C|Eo`;|7_TUcr;k9ORHWbQppoDmXdg!_ng+(YDhktQZl zlJ5p{-!aX-N9M84dg%*L(K`Ik1=Egum(0COOrjlEzyn}y$M++-9(lB5zP2-wrhlFx zJY&c_A2jKHJd6x&$M+_AyEcNPKe7$hc6^7D4{ImTaqLKsgS8#cG&0|OnskvTkij&^ zfoH=p*!izk-;#Bbo&sw-zGsgI=cH2NPuuN6nti1|o=1#hh64-{j?0TkYkz$IzK%iV zxN6e=UPgwt3ZKr4(ruKyQ?D^ zI{6+9(8ZAc#N=-XQN_o6Hm0&vr>sS;_9YWS?X`5c&ei1`0>Q5P+X=)xN*!H=RwDdRd_-8 zHTq>{A%5WtG{Fs{s9J7>3J7#yz>9lgDdQ_NJ z-wx!q+-t7gxN2RCxw@sbtpkPlE-}-6Jv}?c>3qyixkf{S`0=%$%STLL(B%|Tw&^-% z5E(Z|DvwsE9y39O%BH1b4WoO%wHo;C@KIkrZFd#fN!wkXS+2r!AUG{LX2!~=bNB+F zKP5zh`x&GEl`D0Op449yX8w3E#qg|e0a5MLj|fps^!vb+ZwoVg#Hf_x#{>O=Vdf7b K{M0b*>&Ral1dVzC literal 0 HcmV?d00001 diff --git a/contrib/bsd-sockets/alien/get-h-errno.c b/contrib/bsd-sockets/alien/get-h-errno.c new file mode 100755 index 0000000..a1d22a6 --- /dev/null +++ b/contrib/bsd-sockets/alien/get-h-errno.c @@ -0,0 +1,6 @@ +#include + +int get_h_errno() +{ + return h_errno; +} diff --git a/contrib/bsd-sockets/alien/undefs.c b/contrib/bsd-sockets/alien/undefs.c new file mode 100644 index 0000000..fca6cde --- /dev/null +++ b/contrib/bsd-sockets/alien/undefs.c @@ -0,0 +1,9 @@ +/* create a .o file with undefined references to all the C stuff we need + * that cmucl hasn't already fouind for us. Not needed on Linux/i386 + * because it has dynamic loading anyway + */ + +void likewecare() { + getprotobyname(); +} + diff --git a/contrib/bsd-sockets/api-reference.html b/contrib/bsd-sockets/api-reference.html new file mode 100644 index 0000000..09e3f04 --- /dev/null +++ b/contrib/bsd-sockets/api-reference.html @@ -0,0 +1,188 @@ +db-sockets API Reference +

Package SOCKETS

+ +

+A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD +socket API for C and Graham Barr's IO::Socket classes for Perl. +

+We represent sockets as CLOS objects, and rename a lot of methods and +arguments to fit Lisp style more closely. +

+ +

+

Contents

+

+

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

+

General concepts

+

+

Most of the functions are modelled on the BSD socket API. BSD sockets +are widely supported, portably (well, fairly portably) +available on a variety of systems, and documented. There are some +differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly +

+

    +
  • Where the C API would typically return -1 and set errno, db-sockets +signals an error. All the errors are subclasses of SOCKET-CONDITION +and generally correspond one for one with possible errno values +

    +

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

    +

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

    +

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

+

+

SOCKETs

+

+

Class: SOCKET +

Slots:

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

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

(socket-accept (socket socket))Method
+

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

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

(socket-peername (socket socket))Method
+

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

(socket-name (socket socket))Method
+

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

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

Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if +NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is +used, so at least one of these two arguments must be non-NIL. If +BUFFER is supplied, it had better be of an element type one octet wide. +Returns the buffer, its length, and the address of the peer +that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC +so that the actual packet length is returned even if the buffer was too +small
+

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

Mark SOCKET as willing to accept incoming connections. BACKLOG +defines the maximum length that the queue of pending connections may +grow to before new connection attempts are refused. See also listen(2)
+

(socket-close (socket socket))Method
+

Close SOCKET. May throw any kind of error that write(2) would have +thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that +stream instead
+

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

Find or create a STREAM that can be used for IO on SOCKET (which +must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM.
+
+

Socket Options

+ +

A subset of socket options are supported, using a fairly +general framework which should make it simple to add more as required +- see sockopt.lisp for details. The name mapping from C is fairly +straightforward: SO_RCVLOWAT becomes +sockopt-receive-low-water and (setf +sockopt-receive-low-water). +|

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

INET-domain sockets

+

+

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

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

+

Class: INET-SOCKET +

Slots:

  • FAMILY :
    • +

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

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

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

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

(make-inet-socket type protocol)Function
+

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

File-domain sockets

+

+File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were +renamed by POSIX presumably on the basis that they may be +available on other systems too. +

+A file-domain socket address is a string, which is used to create a node +in the local filesystem. This means of course that they cannot be used across +a network. +

+|

Class: UNIX-SOCKET +

Slots:

  • FAMILY :
    • +

Name Service

 +

+

Presently name service is implemented by calling whatever +gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS, +or something completely different. Typically it's controlled by +/etc/nsswitch.conf +

+

Direct links to the asynchronous resolver(3) routines would be nice to have +eventually, so that we can do DNS lookups in parallel with other things +

Class: HOST-ENT +

Slots:

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

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

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

Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. +HOST-NAME may also be an IP address in dotted quad notation or some other +weird stuff - see gethostbyname(3) for grisly details.
+

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

Returns a HOST-ENT instance for ADDRESS, which should be a vector of +(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for +grisly details.
+

(name-service-error where)Function
+

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

Is SOCKET in non-blocking mode?
+
+

+

Tests

+

+There should be at least one test for pretty much everything you can do +with the package. In some places I've been more diligent than others; more +tests gratefully accepted. +

+Tests are in the file tests.lisp and also make good examples. +

+| +

Unix-domain sockets

+

+A fairly rudimentary test that connects to the syslog socket and sends a +message. Priority 7 is kern.debug; you'll probably want to look at +/etc/syslog.conf or local equivalent to find out where the message ended up +| \ No newline at end of file diff --git a/contrib/bsd-sockets/array-data.lisp b/contrib/bsd-sockets/array-data.lisp new file mode 100644 index 0000000..8a53daa --- /dev/null +++ b/contrib/bsd-sockets/array-data.lisp @@ -0,0 +1,72 @@ +(in-package :sockint) + +;;; borrowed from CMUCL manual, lightly ported + +(defun array-data-address (array) + "Return the physical address of where the actual data of an array is +stored. + +ARRAY must be a specialized array type - an array of one of these types: + + double-float + single-float + (unsigned-byte 32) + (unsigned-byte 16) + (unsigned-byte 8) + (signed-byte 32) + (signed-byte 16) + (signed-byte 8) +" + (declare (type (or (array (signed-byte 8)) + (array base-char) + simple-base-string + (array (signed-byte 16)) + (array (signed-byte 32)) + (array (unsigned-byte 8)) + (array (unsigned-byte 16)) + (array (unsigned-byte 32)) + (array single-float) + (array double-float)) + array) + (optimize (speed 0) (debug 3) (safety 3))) + ;; with-array-data will get us to the actual data. However, because + ;; the array could have been displaced, we need to know where the + ;; data starts. + + (let* ((type (car (multiple-value-list (array-element-type array)))) + (type-size + (cond ((or (equal type '(signed-byte 8)) + (equal type 'cl::base-char) + (equal type '(unsigned-byte 8))) + 1) + ((or (equal type '(signed-byte 16)) + (equal type '(unsigned-byte 16))) + 2) + ((or (equal type '(signed-byte 32)) + (equal type '(unsigned-byte 32))) + 4) + ((equal type 'single-float) + 4) + ((equal type 'double-float) + 8) + (t (error "Unknown specialized array element type"))))) + (with-array-data ((data array) + (start) + (end)) + (declare (ignore end)) + ;; DATA is a specialized simple-array. Memory is laid out like this: + ;; + ;; byte offset Value + ;; 0 type code (e.g. 70 for double-float vector) + ;; 4 FIXNUMIZE(number of elements in vector) + ;; 8 1st element of vector + ;; ... ... + ;; + (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data))))) + (declare (type (unsigned-byte 32) addr) + (optimize (speed 3) (safety 0))) + (sb-sys:int-sap (the (unsigned-byte 32) + (+ addr (* type-size start)))))))) + + + diff --git a/contrib/bsd-sockets/bsd-sockets.asd b/contrib/bsd-sockets/bsd-sockets.asd new file mode 100644 index 0000000..f968eb0 --- /dev/null +++ b/contrib/bsd-sockets/bsd-sockets.asd @@ -0,0 +1,127 @@ +;;; -*- Lisp -*- + +(defpackage #:bsd-sockets-system (:use #:asdf #:cl)) +(in-package #:bsd-sockets-system) + +;;; constants.lisp requires special treatment + +(defclass constants-file (cl-source-file) ()) + +(defmethod perform ((op compile-op) (component constants-file)) + ;; we want to generate all our temporary files in the fasl directory + ;; because that's where we have write permission. Can't use /tmp; + ;; it's insecure (these files will later be owned by root) + (let* ((output-file (car (output-files op component))) + (filename (component-pathname component)) + (real-output-file + (if (typep output-file 'logical-pathname) + (translate-logical-pathname output-file) + (pathname output-file))) + (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) + (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file)) + (tmp-constants (merge-pathnames #p"constants.lisp-temp" + real-output-file))) + (princ (list filename output-file real-output-file + tmp-c-source tmp-a-dot-out tmp-constants)) + (terpri) + (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "BSD-SOCKETS-SYSTEM")) + filename tmp-c-source :bsd-sockets-internal) + (and + (= (run-shell-command + "/usr/bin/gcc -o ~S ~S" (namestring tmp-a-dot-out) + (namestring tmp-c-source)) 0) + (= (run-shell-command "~A >~A" + (namestring tmp-a-dot-out) + (namestring tmp-constants)) 0) + (compile-file tmp-constants :output-file output-file)))) + + +;;; we also have a shared library with some .o files in it + +(defclass unix-dso (module) ()) +(defun unix-name (pathname) + (namestring + (typecase pathname + (logical-pathname (translate-logical-pathname pathname)) + (t pathname)))) + +(defmethod asdf::input-files ((operation compile-op) (dso unix-dso)) + (mapcar #'component-pathname (module-components dso))) + +(defmethod output-files ((operation compile-op) (dso unix-dso)) + (let ((dir (component-pathname dso))) + (list + (make-pathname :type "so" + :name (car (last (pathname-directory dir))) + :directory (butlast (pathname-directory dir)) + :defaults dir)))) + + +(defmethod perform :after ((operation compile-op) (dso unix-dso)) + (let ((dso-name (unix-name (car (output-files operation dso))))) + (unless (zerop + (run-shell-command + "gcc -shared -o ~S ~{~S ~}" + dso-name + (mapcar #'unix-name + (mapcan (lambda (c) + (output-files operation c)) + (module-components dso))))) + (error 'operation-error :operation operation :component dso)))) + +;;; if this goes into the standard asdf, it could reasonably be extended +;;; to allow cflags to be set somehow +(defmethod output-files ((op compile-op) (c c-source-file)) + (list + (make-pathname :type "o" :defaults + (component-pathname c)))) +(defmethod perform ((op compile-op) (c c-source-file)) + (unless + (= 0 (run-shell-command "/usr/bin/gcc -fPIC -o ~S -c ~S" + (unix-name (car (output-files op c))) + (unix-name (component-pathname c)))) + (error 'operation-error :operation op :component c))) + +(defmethod perform ((operation load-op) (c c-source-file)) + t) + +(defmethod perform ((o load-op) (c unix-dso)) + (let ((co (make-instance 'compile-op))) + (let ((filename (car (output-files co c)))) + #+cmu (ext:load-foreign filename) + #+sbcl (sb-alien:load-1-foreign filename)))) + +(defsystem bsd-sockets + :version "0.58" + :components ((:file "defpackage" :depends-on ("rt")) + (:file "split" :depends-on ("defpackage")) + (:file "array-data" :depends-on ("defpackage")) + (:unix-dso "alien" + :components ((:c-source-file "undefs") + (:c-source-file "get-h-errno"))) + (:file "malloc" :depends-on ("defpackage")) + (:file "foreign-glue" :depends-on ("defpackage" "malloc")) + (:constants-file "constants" + :pathname "constants.lisp" + :depends-on + ("def-to-lisp" "defpackage" "foreign-glue")) + (:file "sockets" + :depends-on ("constants" "array-data")) + + (:file "sockopt" :depends-on ("sockets")) + (:file "inet" :depends-on ("sockets" "split" "constants" )) + (:file "unix" :depends-on ("sockets" "split" "constants" )) + (:file "name-service" :depends-on ("sockets" "constants" "alien")) + (:file "misc" :depends-on ("sockets" "constants")) + + (:file "rt") + (:file "def-to-lisp") + (:file "tests" :depends-on ("inet" "sockopt" "rt")) + + (:static-file "NEWS") + (:static-file "INSTALL") + (:static-file "README") + (:static-file "index" :pathname "index.html") + (:static-file "doc" :pathname "doc.lisp") + (:static-file "TODO"))) + diff --git a/contrib/bsd-sockets/constants.lisp b/contrib/bsd-sockets/constants.lisp new file mode 100644 index 0000000..e792888 --- /dev/null +++ b/contrib/bsd-sockets/constants.lisp @@ -0,0 +1,189 @@ +;;; -*- Lisp -*- + +;;; This isn't really lisp, but it's definitely a source file. we +;;; name it thus to avoid having to mess with the clc lpn translations + +;;; first, the headers necessary to find definitions of everything +("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.h" "sys/un.h" + "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h" + "netdb.h" "errno.h" "netinet/tcp.h" "fcntl.h" ) + +;;; then the stuff we're looking for +((:integer af-inet "AF_INET" "IP Protocol family") + (:integer af-unspec "AF_UNSPEC" "Unspecified.") +#-solaris (:integer af-local "AF_LOCAL" "Local to host (pipes and file-domain).") + (:integer af-unix "AF_UNIX" "Old BSD name for af-local. ") +#-(or solaris freebsd) (:integer af-file "AF_FILE" "POSIX name for af-local. ") +#+linux (:integer af-inet6 "AF_INET6" "IP version 6. ") +#+linux (:integer af-route "AF_NETLINK" "Alias to emulate 4.4BSD ") + + (:integer sock-stream "SOCK_STREAM" + "Sequenced, reliable, connection-based byte streams.") + (:integer sock-dgram "SOCK_DGRAM" + "Connectionless, unreliable datagrams of fixed maximum length.") + (:integer sock-raw "SOCK_RAW" + "Raw protocol interface.") + (:integer sock-rdm "SOCK_RDM" + "Reliably-delivered messages.") + (:integer sock-seqpacket "SOCK_SEQPACKET" + "Sequenced, reliable, connection-based, datagrams of fixed maximum length.") + + (:integer sol-socket "SOL_SOCKET") + + ;; some of these may be linux-specific + (:integer so-debug "SO_DEBUG" + "Enable debugging in underlying protocol modules") + (:integer so-reuseaddr "SO_REUSEADDR" "Enable local address reuse") + (:integer so-type "SO_TYPE") ;get only + (:integer so-error "SO_ERROR") ;get only (also clears) + (:integer so-dontroute "SO_DONTROUTE" + "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address") + (:integer so-broadcast "SO_BROADCAST" "Request permission to send broadcast datagrams") + (:integer so-sndbuf "SO_SNDBUF") +#+linux (:integer so-passcred "SO_PASSCRED") + (:integer so-rcvbuf "SO_RCVBUF") + (:integer so-keepalive "SO_KEEPALIVE" + "Send periodic keepalives: if peer does not respond, we get SIGPIPE") + (:integer so-oobinline "SO_OOBINLINE" + "Put out-of-band data into the normal input queue when received") + (:integer so-no-check 11) +#+linux (:integer so-priority "SO_PRIORITY") + (:integer so-linger "SO_LINGER" + "For reliable streams, pause a while on closing when unsent messages are queued") +#+linux (:integer so-bsdcompat "SO_BSDCOMPAT") + (:integer so-sndlowat "SO_SNDLOWAT") + (:integer so-rcvlowat "SO_RCVLOWAT") + (:integer so-sndtimeo "SO_SNDTIMEO") + (:integer so-rcvtimeo "SO_RCVTIMEO") + + (:integer tcp-nodelay "TCP_NODELAY") + #+linux (:integer so-bindtodevice "SO_BINDTODEVICE") + (:integer ifnamsiz "IFNAMSIZ") + + (:integer EADDRINUSE "EADDRINUSE") + (:integer EAGAIN "EAGAIN") + (:integer EBADF "EBADF") + (:integer ECONNREFUSED "ECONNREFUSED") + (:integer EINTR "EINTR") + (:integer EINVAL "EINVAL") + (:integer ENOBUFS "ENOBUFS") + (:integer ENOMEM "ENOMEM") + (:integer EOPNOTSUPP "EOPNOTSUPP") + (:integer EPERM "EPERM") + (:integer EPROTONOSUPPORT "EPROTONOSUPPORT") + (:integer ESOCKTNOSUPPORT "ESOCKTNOSUPPORT") + (:integer ENETUNREACH "ENETUNREACH") + + (:integer NETDB-INTERNAL "NETDB_INTERNAL" "See errno.") + (:integer NETDB-SUCCESS "NETDB_SUCCESS" "No problem.") + (:integer HOST-NOT-FOUND "HOST_NOT_FOUND" "Authoritative Answer Host not found.") + (:integer TRY-AGAIN "TRY_AGAIN" "Non-Authoritative Host not found, or SERVERFAIL.") + (:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.") + (:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.") + (:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.") + + (:integer O-NONBLOCK "O_NONBLOCK") + (:integer f-getfl "F_GETFL") + (:integer f-setfl "F_SETFL") + + #+linux (:integer msg-nosignal "MSG_NOSIGNAL") + (:integer msg-oob "MSG_OOB") + (:integer msg-peek "MSG_PEEK") + (:integer msg-trunc "MSG_TRUNC") + (:integer msg-waitall "MSG_WAITALL") + + #| + ;;; stat is nothing to do with sockets, but I keep it around for testing + ;;; the ffi glue + (:structure stat ("struct stat" + (t dev "dev_t" "st_dev") + ((alien:integer 32) atime "time_t" "st_atime"))) + (:function stat ("stat" (integer 32) + (file-name (* t)) + (buf (* t)))) + |# + (:structure protoent ("struct protoent" + ((* t) name "char *" "p_name") + ((* (* t)) aliases "char **" "p_aliases") + (integer proto "int" "p_proto"))) + (:function getprotobyname ("getprotobyname" (* t) + (name c-string))) + (:integer inaddr-any "INADDR_ANY") + (:structure in-addr ("struct in_addr" + ((array (unsigned 8) 4) addr "u_int32_t" "s_addr"))) + (:structure sockaddr-in ("struct sockaddr_in" + (integer family "sa_family_t" "sin_family") + ((array (unsigned 8) 2) port "u_int16_t" "sin_port") + ((array (unsigned 8) 4) addr "struct in_addr" "sin_addr"))) + (:structure sockaddr-un ("struct sockaddr_un" + (integer family "sa_family_t" "sun_family") + ((array (unsigned 8) 108) path "char" "sun_path"))) + (:structure hostent ("struct hostent" + ((* t) name "char *" "h_name") + ((* c-string) aliases "char **" "h_aliases") + (integer type "int" "h_addrtype") + (integer length "int" "h_length") + ((* (* (unsigned 8))) addresses "char **" "h_addr_list"))) + (:function socket ("socket" integer + (domain integer) + (type integer) + (protocol integer))) + (:function bind ("bind" integer + (sockfd integer) + (my-addr (* t)) + (addrlen integer))) + (:function listen ("listen" integer + (socket integer) + (backlog integer))) + (:function accept ("accept" integer + (socket integer) + (my-addr (* t)) + (addrlen integer :in-out))) + (:function getpeername ("getpeername" integer + (socket integer) + (her-addr (* t)) + (addrlen integer :in-out))) + (:function getsockname ("getsockname" integer + (socket integer) + (my-addr (* t)) + (addrlen integer :in-out))) + (:function connect ("connect" integer + (socket integer) + (his-addr (* t)) + (addrlen integer ))) + + (:function close ("close" integer + (fd integer))) + (:function recvfrom ("recvfrom" integer + (socket integer) + (buf (* t)) + (len integer) + (flags integer) + (sockaddr (* t)) + (socklen (* integer)))) + (:function gethostbyname ("gethostbyname" (* t ) (name c-string))) + (:function gethostbyaddr ("gethostbyaddr" (* t ) + (addr (* t)) + (len integer) + (af integer))) + (:structure hostent ("struct hostent" + ((* t) name "char *" "h_name") + (integer length "int" "h_length"))) + + (:function setsockopt ("setsockopt" integer + (socket integer) + (level integer) + (optname integer) + (optval (* t)) + (optlen integer))) + (:function fcntl ("fcntl" integer + (fd integer) + (cmd integer) + (arg integer))) + (:function getsockopt ("getsockopt" integer + (socket integer) + (level integer) + (optname integer) + (optval (* t)) + (optlen integer :in-out)))) +) diff --git a/contrib/bsd-sockets/constants.lisp-temp b/contrib/bsd-sockets/constants.lisp-temp new file mode 100644 index 0000000..1294c43 --- /dev/null +++ b/contrib/bsd-sockets/constants.lisp-temp @@ -0,0 +1,170 @@ +(in-package :BSD-SOCKETS-INTERNAL) +(defconstant size-of-int 4) +(defconstant size-of-char 1) +(defconstant size-of-long 4) +(defconstant AF-INET 2 "IP Protocol family") +(defconstant AF-UNSPEC 0 "Unspecified.") +(defconstant AF-LOCAL 1 "Local to host (pipes and file-domain).") +(defconstant AF-UNIX 1 "Old BSD name for af-local. ") +(defconstant AF-FILE 1 "POSIX name for af-local. ") +(defconstant AF-INET6 10 "IP version 6. ") +(defconstant AF-ROUTE 16 "Alias to emulate 4.4BSD ") +(defconstant SOCK-STREAM 1 "Sequenced, reliable, connection-based byte streams.") +(defconstant SOCK-DGRAM 2 "Connectionless, unreliable datagrams of fixed maximum length.") +(defconstant SOCK-RAW 3 "Raw protocol interface.") +(defconstant SOCK-RDM 4 "Reliably-delivered messages.") +(defconstant SOCK-SEQPACKET 5 "Sequenced, reliable, connection-based, datagrams of fixed maximum length.") +(defconstant SOL-SOCKET 1 "NIL") +(defconstant SO-DEBUG 1 "Enable debugging in underlying protocol modules") +(defconstant SO-REUSEADDR 2 "Enable local address reuse") +(defconstant SO-TYPE 3 "NIL") +(defconstant SO-ERROR 4 "NIL") +(defconstant SO-DONTROUTE 5 "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address") +(defconstant SO-BROADCAST 6 "Request permission to send broadcast datagrams") +(defconstant SO-SNDBUF 7 "NIL") +(defconstant SO-PASSCRED 16 "NIL") +(defconstant SO-RCVBUF 8 "NIL") +(defconstant SO-KEEPALIVE 9 "Send periodic keepalives: if peer does not respond, we get SIGPIPE") +(defconstant SO-OOBINLINE 10 "Put out-of-band data into the normal input queue when received") +(defconstant SO-NO-CHECK 11 "NIL") +(defconstant SO-PRIORITY 12 "NIL") +(defconstant SO-LINGER 13 "For reliable streams, pause a while on closing when unsent messages are queued") +(defconstant SO-BSDCOMPAT 14 "NIL") +(defconstant SO-SNDLOWAT 19 "NIL") +(defconstant SO-RCVLOWAT 18 "NIL") +(defconstant SO-SNDTIMEO 21 "NIL") +(defconstant SO-RCVTIMEO 20 "NIL") +(defconstant TCP-NODELAY 1 "NIL") +(defconstant SO-BINDTODEVICE 25 "NIL") +(defconstant IFNAMSIZ 16 "NIL") +(defconstant EADDRINUSE 98 "NIL") +(defconstant EAGAIN 11 "NIL") +(defconstant EBADF 9 "NIL") +(defconstant ECONNREFUSED 111 "NIL") +(defconstant EINTR 4 "NIL") +(defconstant EINVAL 22 "NIL") +(defconstant ENOBUFS 105 "NIL") +(defconstant ENOMEM 12 "NIL") +(defconstant EOPNOTSUPP 95 "NIL") +(defconstant EPERM 1 "NIL") +(defconstant EPROTONOSUPPORT 93 "NIL") +(defconstant ESOCKTNOSUPPORT 94 "NIL") +(defconstant ENETUNREACH 101 "NIL") +(defconstant NETDB-INTERNAL -1 "See errno.") +(defconstant NETDB-SUCCESS 0 "No problem.") +(defconstant HOST-NOT-FOUND 1 "Authoritative Answer Host not found.") +(defconstant TRY-AGAIN 2 "Non-Authoritative Host not found, or SERVERFAIL.") +(defconstant NO-RECOVERY 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.") +(defconstant NO-DATA 4 "Valid name, no data record of requested type.") +(defconstant NO-ADDRESS 4 "No address, look for MX record.") +(defconstant O-NONBLOCK 2048 "NIL") +(defconstant F-GETFL 3 "NIL") +(defconstant F-SETFL 4 "NIL") +(defconstant MSG-NOSIGNAL 16384 "NIL") +(defconstant MSG-OOB 1 "NIL") +(defconstant MSG-PEEK 2 "NIL") +(defconstant MSG-TRUNC 32 "NIL") +(defconstant MSG-WAITALL 256 "NIL") +(define-c-struct PROTOENT 12) +(define-c-accessor PROTOENT-NAME PROTOENT (* T) 0 4) +(define-c-accessor PROTOENT-ALIASES PROTOENT (* (* T)) 4 4) +(define-c-accessor PROTOENT-PROTO PROTOENT INTEGER 8 4) +(declaim (inline GETPROTOBYNAME)) +(def-foreign-routine ("getprotobyname" GETPROTOBYNAME ) (* T) (NAME + C-STRING) ) +(defconstant INADDR-ANY 0 "NIL") +(define-c-struct IN-ADDR 4) +(define-c-accessor IN-ADDR-ADDR IN-ADDR (ARRAY (UNSIGNED 8) 4) 0 4) +(define-c-struct SOCKADDR-IN 16) +(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 0 2) +(define-c-accessor SOCKADDR-IN-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) +(define-c-accessor SOCKADDR-IN-ADDR SOCKADDR-IN (ARRAY (UNSIGNED 8) 4) 4 4) +(define-c-struct SOCKADDR-UN 110) +(define-c-accessor SOCKADDR-UN-FAMILY SOCKADDR-UN INTEGER 0 2) +(define-c-accessor SOCKADDR-UN-PATH SOCKADDR-UN (ARRAY (UNSIGNED 8) 108) 2 108) +(define-c-struct HOSTENT 20) +(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4) +(define-c-accessor HOSTENT-ALIASES HOSTENT (* C-STRING) 4 4) +(define-c-accessor HOSTENT-TYPE HOSTENT INTEGER 8 4) +(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4) +(define-c-accessor HOSTENT-ADDRESSES HOSTENT (* (* (UNSIGNED 8))) 16 4) +(declaim (inline SOCKET)) +(def-foreign-routine ("socket" SOCKET ) INTEGER (DOMAIN INTEGER) (TYPE + INTEGER) (PROTOCOL + INTEGER) ) +(declaim (inline BIND)) +(def-foreign-routine ("bind" BIND ) INTEGER (SOCKFD INTEGER) (MY-ADDR + (* T)) (ADDRLEN + INTEGER) ) +(declaim (inline LISTEN)) +(def-foreign-routine ("listen" LISTEN ) INTEGER (SOCKET INTEGER) (BACKLOG + INTEGER) ) +(declaim (inline ACCEPT)) +(def-foreign-routine ("accept" ACCEPT ) INTEGER (SOCKET INTEGER) (MY-ADDR + (* + T)) (ADDRLEN + INTEGER + :IN-OUT) ) +(declaim (inline GETPEERNAME)) +(def-foreign-routine ("getpeername" GETPEERNAME ) INTEGER (SOCKET + INTEGER) (HER-ADDR + (* + T)) (ADDRLEN + INTEGER + :IN-OUT) ) +(declaim (inline GETSOCKNAME)) +(def-foreign-routine ("getsockname" GETSOCKNAME ) INTEGER (SOCKET + INTEGER) (MY-ADDR + (* + T)) (ADDRLEN + INTEGER + :IN-OUT) ) +(declaim (inline CONNECT)) +(def-foreign-routine ("connect" CONNECT ) INTEGER (SOCKET INTEGER) (HIS-ADDR + (* + T)) (ADDRLEN + INTEGER) ) +(declaim (inline CLOSE)) +(def-foreign-routine ("close" CLOSE ) INTEGER (FD INTEGER) ) +(declaim (inline RECVFROM)) +(def-foreign-routine ("recvfrom" RECVFROM ) INTEGER (SOCKET INTEGER) (BUF + (* + T)) (LEN + INTEGER) (FLAGS + INTEGER) (SOCKADDR + (* + T)) (SOCKLEN + (* + INTEGER)) ) +(declaim (inline GETHOSTBYNAME)) +(def-foreign-routine ("gethostbyname" GETHOSTBYNAME ) (* T) (NAME + C-STRING) ) +(declaim (inline GETHOSTBYADDR)) +(def-foreign-routine ("gethostbyaddr" GETHOSTBYADDR ) (* T) (ADDR + (* T)) (LEN + INTEGER) (AF + INTEGER) ) +(define-c-struct HOSTENT 20) +(define-c-accessor HOSTENT-NAME HOSTENT (* T) 0 4) +(define-c-accessor HOSTENT-LENGTH HOSTENT INTEGER 12 4) +(declaim (inline SETSOCKOPT)) +(def-foreign-routine ("setsockopt" SETSOCKOPT ) INTEGER (SOCKET + INTEGER) (LEVEL + INTEGER) (OPTNAME + INTEGER) (OPTVAL + (* + T)) (OPTLEN + INTEGER) ) +(declaim (inline FCNTL)) +(def-foreign-routine ("fcntl" FCNTL ) INTEGER (FD INTEGER) (CMD + INTEGER) (ARG + INTEGER) ) +(declaim (inline GETSOCKOPT)) +(def-foreign-routine ("getsockopt" GETSOCKOPT ) INTEGER (SOCKET + INTEGER) (LEVEL + INTEGER) (OPTNAME + INTEGER) (OPTVAL + (* + T)) (OPTLEN + INTEGER + :IN-OUT) ) diff --git a/contrib/bsd-sockets/def-to-lisp.lisp b/contrib/bsd-sockets/def-to-lisp.lisp new file mode 100644 index 0000000..a0317a1 --- /dev/null +++ b/contrib/bsd-sockets/def-to-lisp.lisp @@ -0,0 +1,70 @@ +(in-package :BSD-SOCKETS-SYSTEM) +(defvar *export-symbols* nil) + +(defun c-for-structure (stream lisp-name c-struct) + (destructuring-bind (c-name &rest elements) c-struct + (format stream "printf(\"(define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name) + (dolist (e elements) + (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e + (format stream "printf(\"(define-c-accessor ~A-~A ~A ~A \");~%" + lisp-name lisp-el-name lisp-name lisp-type) + ;; offset + (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%" + c-name c-el-name) + ;; length + (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%" + c-name c-el-name) + (format stream "printf(\")\\n\");~%"))))) + +(defun c-for-function (stream lisp-name alien-defn) + (destructuring-bind (c-name &rest definition) alien-defn + (let ((*print-right-margin* nil)) + (format stream "printf(\"(declaim (inline ~A))\\n\");~%" + lisp-name) + (princ "printf(\"(def-foreign-routine (" stream) + (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream) + (princ lisp-name stream) + (princ " ) " stream) + (dolist (d definition) + (write d :length nil + :right-margin nil :stream stream) + (princ " " stream)) + (format stream ")\\n\");") + (terpri stream)))) + + +(defun print-c-source (stream headers definitions package-name) + ;(format stream "#include \"struct.h\"~%") + (let ((*print-right-margin* nil)) + (loop for i in headers + do (format stream "#include <~A>~%" i)) + (format stream "main() { ~% +printf(\"(in-package ~S)\\\n\");~%" package-name) + (format stream "printf(\"(defconstant size-of-int %d)\\\n\",sizeof (int));~%") + (format stream "printf(\"(defconstant size-of-char %d)\\\n\",sizeof (char));~%") + (format stream "printf(\"(defconstant size-of-long %d)\\\n\",sizeof (long));~%") + (dolist (def definitions) + (destructuring-bind (type lispname cname &optional doc) def + (cond ((eq type :integer) + (format stream + "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%" + lispname doc cname)) + ((eq type :string) + (format stream + "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" + lispname doc cname)) + ((eq type :function) + (c-for-function stream lispname cname)) + ((eq type :structure) + (c-for-structure stream lispname cname)) + (t + (format stream + "printf(\";; Non hablo Espagnol, Monsieur~%"))))) + (format stream "exit(0);~%}"))) + +(defun c-constants-extract (filename output-file package) + (with-open-file (f output-file :direction :output) + (with-open-file (i filename :direction :input) + (let* ((headers (read i)) + (definitions (read i))) + (print-c-source f headers definitions package))))) diff --git a/contrib/bsd-sockets/defpackage.lisp b/contrib/bsd-sockets/defpackage.lisp new file mode 100644 index 0000000..8f21df3 --- /dev/null +++ b/contrib/bsd-sockets/defpackage.lisp @@ -0,0 +1,123 @@ +(defpackage "BSD-SOCKETS-INTERNAL" + (:nicknames "SOCKINT") + (:shadow close listen) + #+cmu (:shadowing-import-from "CL" with-array-data) + #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data) + + #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL") + #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL")) + +;;; SBCL changes a lot of package prefixes. To avoid littering the +;;; code with conditionals, we use the SBCL package prefixes +;;; throughout. This means that we need to create said packages +;;; first, if we're using CMUCL + +;;; One thing that this exercise really has made clear is just how much +;;; of the alien stuff is scattered around the cmucl package space +;;; seemingly at random. Hmm. + +#+cmu +(eval-when (:compile-toplevel :load-toplevel) + (defun add-package-nickname (name nickname) + (let ((p (find-package name))) + (rename-package p (package-name p) + (cons nickname (package-nicknames name))))) + (add-package-nickname "EXT" "SB-EXT") + (add-package-nickname "ALIEN" "SB-ALIEN") + (add-package-nickname "UNIX" "SB-UNIX") + (add-package-nickname "C-CALL" "SB-C-CALL") + (add-package-nickname "KERNEL" "SB-KERNEL") + (add-package-nickname "SYSTEM" "SB-SYS")) + +(defpackage "BSD-SOCKETS" + (:export socket unix-socket inet-socket + make-unix-socket make-inet-socket + socket-bind socket-accept socket-connect + socket-send socket-receive socket-recv + socket-name socket-peername socket-listen + socket-close socket-file-descriptor socket-make-stream + get-protocol-by-name + + get-host-by-name get-host-by-address + host-ent + host-ent-addresses host-ent-address + host-ent aliases host-ent-name + name-service-error + ;; not sure if these are really good names or not + netdb-internal-error + netdb-success-error + host-not-found-error + try-again-error + no-recovery-error + + ;; all socket options are also exported, by code in + ;; sockopt.lisp + + bad-file-descriptor-error + address-in-use-error + interrupted-error + invalid-argument-error + out-of-memory-error + operation-not-supported-error + operation-not-permitted-error + protocol-not-supported-error + socket-type-not-supported-error + network-unreachable-error + + make-inet-address + + non-blocking-mode + ) + (:use "COMMON-LISP" "BSD-SOCKETS-INTERNAL") + (:documentation + " + +A thinly-disguised BSD socket API for SBCL. Ideas stolen from the BSD +socket API for C and Graham Barr's IO::Socket classes for Perl. + +We represent sockets as CLOS objects, and rename a lot of methods and +arguments to fit Lisp style more closely. + +" + )) + +#|| + +

Contents

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

General concepts

+ +

Most of the functions are modelled on the BSD socket API. BSD sockets +are widely supported, portably ("portable" by Unix standards, at least) +available on a variety of systems, and documented. There are some +differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly + +

    +
  • Where the C API would typically return -1 and set errno, bsd-sockets +signals an error. All the errors are subclasses of SOCKET-CONDITION +and generally correspond one for one with possible errno values + +
  • We use multiple return values in many places where the C API would use p[ass-by-reference values + +
  • We can often avoid supplying an explicit length argument to +functions because we already know how long the argument is. + +
  • IP addresses and ports are represented in slightly friendlier fashion +than "network-endian integers". See the section on Internet domain sockets for details. +
+ + +|# diff --git a/contrib/bsd-sockets/doc.lisp b/contrib/bsd-sockets/doc.lisp new file mode 100644 index 0000000..37cfe36 --- /dev/null +++ b/contrib/bsd-sockets/doc.lisp @@ -0,0 +1,225 @@ +(eval-when (:load-toplevel :compile-toplevel :execute) + (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext ))) +(in-package :db-doc) +;;; turn water into wine ^W^W^W lisp into HTML + +#| +OK. We need a design + +1) The aim is to document the current package, given a system. +2) The assumption is that the system is loaded; this makes it easier to +do cross-references and stuff +3) We output HTML on *standard-output* +4) Hyperlink wherever useful +5) We're allowed to intern symbols all over the place if we like + +|# + +;;; note: break badly on multiple packages + + +(defvar *symbols* nil + "List of external symbols to print; derived from parsing DEFPACKAGE form") + + +(defun worth-documenting-p (symbol) + (and symbol + (eql (symbol-package symbol) *package*) + (or (ignore-errors (find-class symbol)) + (boundp symbol) (fboundp symbol)))) + +(defun linkable-symbol-p (word) + (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c) + (eql c #\-)))) + (and (every #'symbol-char word) + (some #'upper-case-p word) + (worth-documenting-p (find-symbol word))))) + +(defun markup-word (w) + (if (symbolp w) (setf w (princ-to-string w))) + (cond ((linkable-symbol-p w) + (format nil "~A" + w w)) + ((and (> (length w) 0) + (eql (elt w 0) #\_) + (eql (elt w (1- (length w))) #\_)) + (format nil "~A" (subseq w 1 (1- (length w))))) + (t w))) +(defun markup-space (w) + (let ((para (search (coerce '(#\Newline #\Newline) 'string) w))) + (if para + (format nil "~A

~A" + (subseq w 0 (1+ para)) + (markup-space (subseq w (1+ para) nil))) + w))) + +(defun text-markup (text) + (let ((start-word 0) (end-word 0)) + (labels ((read-word () + (setf end-word + (position-if + (lambda (x) (member x '(#\Space #\, #\. #\Newline))) + text :start start-word)) + (subseq text start-word end-word)) + (read-space () + (setf start-word + (position-if-not + (lambda (x) (member x '(#\Space #\, #\. #\Newline))) + text :start end-word )) + (subseq text end-word start-word))) + (with-output-to-string (o) + (loop for inword = (read-word) + do (princ (markup-word inword) o) + while (and start-word end-word) + do (princ (markup-space (read-space)) o) + while (and start-word end-word)))))) + + +(defun do-defpackage (form stream) + (setf *symbols* nil) + (destructuring-bind (defn name &rest options) form + (when (string-equal name (package-name *package*)) + (format stream "

Package ~A

~%" name) + (when (documentation *package* t) + (princ (text-markup (documentation *package* t)))) + (let ((exports (assoc :export options))) + (when exports + (setf *symbols* (mapcar #'symbol-name (cdr exports))))) + 1))) + +(defun do-defclass (form stream) + (destructuring-bind (defn name super slots &rest options) form + (when (interesting-name-p name) + (let ((class (find-class name))) + (format stream "

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

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

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

Slots:

    " stream) + (dolist (slot slots) + (destructuring-bind + (name &key reader writer accessor initarg initform type + documentation) + (if (consp slot) slot (list slot)) + (format stream "
  • ~A : ~A
    • ~%" name + (if documentation (text-markup documentation) "")))) + (princ "
" stream)) + t)))) + + +(defun interesting-name-p (name) + (cond ((consp name) + (and (eql (car name) 'setf) + (interesting-name-p (cadr name)))) + (t (member (symbol-name name) *symbols* :test #'string=)))) + +(defun markup-lambdalist (l) + (let (key-p) + (loop for i in l + if (eq '&key i) do (setf key-p t) + end + if (and (not key-p) (consp i)) + collect (list (car i) (markup-word (cadr i))) + else collect i))) + +(defun do-defunlike (form label stream) + (destructuring-bind (defn name lambdalist &optional doc &rest code) form + (when (interesting-name-p name) + (when (symbolp name) + (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=))) + (format stream "

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

~A
~%" + (text-markup doc))) + t))) + +(defun do-defun (form stream) (do-defunlike form "Function" stream)) +(defun do-defmethod (form stream) (do-defunlike form "Method" stream)) +(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream)) +(defun do-boolean-sockopt (form stream) + (destructuring-bind (type lisp-name level c-name) form + (pushnew (symbol-name lisp-name) *symbols*) + + (do-defunlike `(defun ,lisp-name ((socket socket) argument) + ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty) + "Accessor" stream))) + +(defun do-form (form output-stream) + (cond ((not (listp form)) nil) + ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL") + (do-boolean-sockopt form output-stream)) + ((eq (car form) 'defclass) + (do-defclass form output-stream)) + ((eq (car form) 'eval-when) + (do-form (third form) output-stream)) + ((eq (car form) 'defpackage) + (do-defpackage form output-stream)) + ((eq (car form) 'defun) + (do-defun form output-stream)) + ((eq (car form) 'defmethod) + (do-defmethod form output-stream)) + ((eq (car form) 'defgeneric) + (do-defgeneric form output-stream)) + (t nil))) + +(defun do-file (input-stream output-stream) + "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM" + (let ((eof-marker (gensym))) + (if (< 0 + (loop for form = (read input-stream nil eof-marker) + until (eq form eof-marker) + if (do-form form output-stream) + count 1 #| and + do (princ "
" output-stream) |# )) + (format output-stream "
" + )))) + +(defvar *standard-sharpsign-reader* + (get-dispatch-macro-character #\# #\|)) + +(defun document-system (system &key + (output-stream *standard-output*) + (package *package*)) + "Produce HTML documentation for all files defined in SYSTEM, covering +symbols exported from PACKAGE" + (let ((*package* (find-package package)) + (*readtable* (copy-readtable)) + (*standard-output* output-stream)) + (set-dispatch-macro-character + #\# #\| + (lambda (s c n) + (if (eql (peek-char nil s t nil t) #\|) + (princ + (text-markup + (coerce + (loop with discard = (read-char s t nil t) + ;initially (princ "

") + for c = (read-char s t nil t) + until (and (eql c #\|) + (eql (peek-char nil s t nil t) #\#)) + collect c + finally (read-char s t nil t)) + 'string))) + (funcall *standard-sharpsign-reader* s c n)))) + (dolist (c (cclan:all-components 'db-sockets)) + (when (and (typep c 'cl-source-file) + (not (typep c 'db-sockets-system::constants-file))) + (with-open-file (in (component-pathname c) :direction :input) + (do-file in *standard-output*)))))) + +(defun start () + (with-open-file (*standard-output* "index.html" :direction :output) + (format t "SBCL BSD-Sockets API Reference~%") + (asdf:operate 'asdf:load-op 'bsd-sockets) + (document-system 'bsd-sockets :package :bsd-sockets))) + +(start) diff --git a/contrib/bsd-sockets/foreign-glue.lisp b/contrib/bsd-sockets/foreign-glue.lisp new file mode 100644 index 0000000..0b4e08c --- /dev/null +++ b/contrib/bsd-sockets/foreign-glue.lisp @@ -0,0 +1,88 @@ +(in-package :bsd-sockets-internal) + +;;;; Foreign function glue. This is the only file in the distribution +;;;; that's _intended_ to be vendor-specific. The macros defined here +;;;; are called from constants.lisp, which was generated from constants.ccon +;;;; by the C compiler as driven by that wacky def-to-lisp thing. + +;;;; of course, the whole thing is vendor-specific actually, due to +;;;; the way we use cmucl alien types in constants.ccon as a cheap way +;;;; of transforming C-world alues into Lisp-world values. But if +;;;; anyone were to port that bit to their preferred implementation, they +;;;; wouldn't need to port all the rest of the cmucl alien interface at +;;;; the same time + +;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME +;;; C-CALL:C-STRING) (BUF (* T)) ) + +;;; I can't help thinking this was originally going to do something a +;;; lot more complex +(defmacro def-foreign-routine + (&whole it (c-name lisp-name) return-type &rest args) + (declare (ignorable c-name lisp-name return-type args)) + `(def-alien-routine ,@(cdr it))) +#| +(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) +(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2) +|# +;;; define-c-accessor makes us a setter and a getter for changing +;;; memory at the appropriate offset + +;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4) + +(defmacro define-c-accessor (el structure type offset length) + (declare (ignore structure)) + (let* ((ty (cond + ((eql type 'integer) `(,type ,(* 8 length))) + ((eql (car type) '*) `(unsigned ,(* 8 length))) + ((eql type 'c-string) `(unsigned ,(* 8 length))) + ((eql (car type) 'array) (cadr type)))) + (sap-ref-? (intern (format nil "~ASAP-REF-~A" + (if (member (car ty) '(INTEGER SIGNED)) + "SIGNED-" "") + (cadr ty)) + (find-package "SB-SYS")))) + (labels ((template (before after) + `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr)))) + (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset))))) + (,before (,sap-ref-? sap index) ,after)))) + `(progn + ;;(declaim (inline ,el (setf ,el))) + (defun ,el (ptr &optional (index 0)) + ,(template 'prog1 nil)) + (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset) + (defun (setf ,el) (newval ptr &optional (index 0)) + ,(template 'setf 'newval)))))) + + +;;; make memory allocator for appropriately-sized block of memory, and +;;; a constant to tell us how big it was anyway +(defmacro define-c-struct (name size) + (labels ((p (x) (intern (concatenate 'string x (symbol-name name))))) + `(progn + (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0 + :element-type '(unsigned-byte 8))) + (defconstant ,(p "SIZE-OF-") ,size) + (defun ,(p "FREE-" ) (p) (declare (ignore p)))))) + +(defun foreign-nullp (c) + "C is a pointer to 0?" + (= 0 (sb-sys:sap-int (sb-alien:alien-sap c)))) + +;;; this could be a lot faster if I cared enough to think about it +(defun foreign-vector (pointer size length) + "Compose a vector of the words found in foreign memory starting at +POINTER. Each word is SIZE bytes long; LENGTH gives the number of +elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO" + (assert (= size 1)) + (let ((ptr + (typecase pointer + (sb-sys:system-area-pointer + (sap-alien pointer (* (sb-alien:unsigned 8)))) + (t + (sb-alien:cast pointer (* (sb-alien:unsigned 8)))))) + (result (make-array length :element-type '(unsigned-byte 8)))) + (loop for i from 0 to (1- length) by size + do (setf (aref result i) (sb-alien:deref ptr i))) + ;;(format t "~S~%" result) + result)) diff --git a/contrib/bsd-sockets/inet.lisp b/contrib/bsd-sockets/inet.lisp new file mode 100644 index 0000000..3cc0545 --- /dev/null +++ b/contrib/bsd-sockets/inet.lisp @@ -0,0 +1,94 @@ +(in-package :bsd-sockets) + +#||

INET-domain sockets

+ +

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

 + +|# + +;;; Our class and constructor + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass inet-socket (socket) + ((family :initform sockint::AF-INET)))) + +;;; XXX should we *...* this? +(defparameter inet-address-any (vector 0 0 0 0)) + +;;; binding a socket to an address and port. Doubt that anyone's +;;; actually using this much, to be honest. + +(defun make-inet-address (dotted-quads) + "Return a vector of octets given a string DOTTED-QUADS in the format +\"127.0.0.1\"" + (coerce + (mapcar #'parse-integer + (split dotted-quads nil '(#\.))) + 'vector)) + +;;; getprotobyname only works in the internet domain, which is why this +;;; is here +(defun get-protocol-by-name (name) ;exported + "Returns the network protocol number associated with the string NAME, +using getprotobyname(2) which typically looks in NIS or /etc/protocols" + ;; for extra brownie points, could return canonical protocol name + ;; and aliases as extra values + (let ((ent (sockint::foreign-vector (sockint::getprotobyname name) 1 + sockint::size-of-protoent))) + (sockint::protoent-proto ent))) + + +;;; sockaddr protocol +;;; (1) sockaddrs are represented as the semi-foreign array-of-octets +;;; thing +;;; (2) a protocol provides make-sockaddr-for, size-of-sockaddr, +;;; bits-of-sockaddr + +(defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address))) + (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in)))) + (when (and host port) + ;; port and host are represented in C as "network-endian" unsigned + ;; integers of various lengths. This is stupid. The value of the + ;; integer doesn't matter (and will change depending on your + ;; machine's endianness); what the bind(2) call is interested in + ;; is the pattern of bytes within that integer. + + ;; We have no truck with such dreadful type punning. Octets to + ;; octets, dust to dust. + + (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet) + (setf (sockint::sockaddr-in-port sockaddr 0) (ldb (byte 8 8) port)) + (setf (sockint::sockaddr-in-port sockaddr 1) (ldb (byte 8 0) port)) + + (setf (sockint::sockaddr-in-addr sockaddr 0) (elt host 0)) + (setf (sockint::sockaddr-in-addr sockaddr 1) (elt host 1)) + (setf (sockint::sockaddr-in-addr sockaddr 2) (elt host 2)) + (setf (sockint::sockaddr-in-addr sockaddr 3) (elt host 3))) + sockaddr)) + +(defmethod size-of-sockaddr ((socket inet-socket)) + sockint::size-of-sockaddr-in) + +(defmethod bits-of-sockaddr ((socket inet-socket) sockaddr) + "Returns address and port of SOCKADDR as multiple values" + (values + (vector + (sockint::sockaddr-in-addr sockaddr 0) + (sockint::sockaddr-in-addr sockaddr 1) + (sockint::sockaddr-in-addr sockaddr 2) + (sockint::sockaddr-in-addr sockaddr 3)) + (+ (* 256 (sockint::sockaddr-in-port sockaddr 0)) + (sockint::sockaddr-in-port sockaddr 1)))) + + +(defun make-inet-socket (type protocol) + "Make an INET socket. Deprecated in favour of make-instance" + (make-instance 'inet-socket :type type :protocol protocol)) + + + diff --git a/contrib/bsd-sockets/malloc.lisp b/contrib/bsd-sockets/malloc.lisp new file mode 100644 index 0000000..75921e7 --- /dev/null +++ b/contrib/bsd-sockets/malloc.lisp @@ -0,0 +1,16 @@ +(in-package :bsd-sockets-internal) + +(defun malloc (size) + "Allocate foreign memory in some way that allows the garbage collector to free it later. Note that memory allocated this way does not count as `consed' for the purposes of deciding when to gc, so explicitly calling EXT:GC occasionally would be a good idea if you use it a lot" + ;; we can attach finalizers to any object, and they'll be called on + ;; the next gc after the object no longer has references. We can't + ;; however make the finalizer close over the object, or it'll never + ;; have no references. I experimentally determined that (sap-alien + ;; (alien-sap f)) is not EQ to f, so we can do it that way + (let* ((memory (make-alien (unsigned 8) size)) + (alias (sap-alien (alien-sap memory) + (* (unsigned 8))))) + (sb-ext:finalize memory + (lambda () + (free-alien alias))))) + diff --git a/contrib/bsd-sockets/misc.lisp b/contrib/bsd-sockets/misc.lisp new file mode 100644 index 0000000..254bd47 --- /dev/null +++ b/contrib/bsd-sockets/misc.lisp @@ -0,0 +1,36 @@ +(in-package :bsd-sockets) + +;;; Miscellaneous things, placed here until I can find a logically more +;;; coherent place to put them + +;;; I don't want to provide a complete interface to unix file +;;; operations, for example, but being about to set O_NONBLOCK on a +;;; socket is a necessary operation. + +;;; XXX bad (sizeof (int) ==4 ) assumptions + +(defmethod non-blocking-mode ((socket socket)) + "Is SOCKET in non-blocking mode?" + (let ((fd (socket-file-descriptor socket))) + (sb-alien:with-alien ((arg integer)) + (> (logand + (sockint::fcntl fd sockint::f-getfl arg) + sockint::o-nonblock) + 0)))) + +(defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) + "Put SOCKET in non-blocking mode - or not, according to NON-BLOCKING-P" + (declare (optimize (speed 3))) + (let* ((fd (socket-file-descriptor socket)) + (arg1 (the (signed-byte 32) (sockint::fcntl fd sockint::f-getfl 0))) + (arg2 + (if non-blocking-p + (logior arg1 sockint::o-nonblock) + (logand (lognot sockint::o-nonblock) arg1)))) + (when (= (the (signed-byte 32) -1) + (the (signed-byte 32) + (sockint::fcntl fd sockint::f-setfl arg2))) + (socket-error "fcntl")) + non-blocking-p)) + + diff --git a/contrib/bsd-sockets/name-service.lisp b/contrib/bsd-sockets/name-service.lisp new file mode 100644 index 0000000..98e67fe --- /dev/null +++ b/contrib/bsd-sockets/name-service.lisp @@ -0,0 +1,144 @@ +(in-package :bsd-sockets) +#||

Name Service

 + +

Presently name service is implemented by calling whatever +gethostbyname(2) uses. This may be any or all of /etc/hosts, NIS, DNS, +or something completely different. Typically it's controlled by +/etc/nsswitch.conf + +

Direct links to the asynchronous resolver(3) routines would be nice to have +eventually, so that we can do DNS lookups in parallel with other things +|# + +(defclass host-ent () + ((name :initarg :name :accessor host-ent-name) + (aliases :initarg :aliases :accessor host-ent-aliases) + (address-type :initarg :type :accessor host-ent-address-type) + ; presently always AF_INET + (addresses :initarg :addresses :accessor host-ent-addresses))) + +(defmethod host-ent-address ((host-ent host-ent)) + (car (host-ent-addresses host-ent))) + +;(define-condition host-not-found-error (socket-error)) ; host unknown +;(define-condition no-address-error (socket-error)) ; valid name but no IP address +;(define-condition no-recovery-error (socket-error)) ; name server error +;(define-condition try-again-error (socket-error)) ; temporary + +(defun get-host-by-name (host-name) + "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. +HOST-NAME may also be an IP address in dotted quad notation or some other +weird stuff - see gethostbyname(3) for grisly details." + (let ((h (sockint::gethostbyname host-name))) + (make-host-ent h))) + +(defun get-host-by-address (address) + "Returns a HOST-ENT instance for ADDRESS, which should be a vector of +(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for +grisly details." + (let ((packed-addr (sockint::allocate-in-addr))) + (loop for i from 0 to 3 + do (setf (sockint::in-addr-addr packed-addr i) (elt address i))) + (make-host-ent + (sb-sys:without-gcing + (sockint::gethostbyaddr (sockint::array-data-address packed-addr) + 4 + sockint::af-inet))))) + +(defun make-host-ent (h) + (if (sockint::foreign-nullp h) (name-service-error "gethostbyname")) + (let* ((local-h (sockint::foreign-vector h 1 sockint::size-of-hostent)) + (length (sockint::hostent-length local-h)) + (aliases + (loop for i = 0 then (1+ i) + for al = (sb-sys:sap-ref-sap + (sb-sys:int-sap (sockint::hostent-aliases local-h)) + (* i 4)) + until (= (sb-sys:sap-int al) 0) + collect (sb-c-call::%naturalize-c-string al))) + (address0 (sb-sys:sap-ref-sap (sb-sys:int-sap (sockint::hostent-addresses local-h)) 0)) + (addresses + (loop for i = 0 then (+ length i) + for ad = (sb-sys:sap-ref-32 address0 i) + while (> ad 0) + collect + (sockint::foreign-vector (sb-sys:sap+ address0 i) 1 length)))) + (make-instance 'host-ent + :name (sb-c-call::%naturalize-c-string + (sb-sys:int-sap (sockint::hostent-name local-h))) + :type (sockint::hostent-type local-h) + :aliases aliases + :addresses addresses))) + +;;; The remainder is my fault - gw + +(defvar *name-service-errno* 0 + "The value of h_errno, after it's been fetched from Unix-land by calling +GET-NAME-SERVICE-ERRNO") + +(defun name-service-error (where) + (get-name-service-errno) + ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.". + ;; This special case treatment hasn't actually been tested yet. + (if (= *name-service-errno* sockint::NETDB-INTERNAL) + (socket-error where) + (let ((condition + (condition-for-name-service-errno *name-service-errno*))) + (error condition :errno *name-service-errno* :syscall where)))) + +(define-condition name-service-error (condition) + ((errno :initform nil + :initarg :errno + :reader name-service-error-errno) + (symbol :initform nil :initarg :symbol :reader name-service-error-symbol) + (syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall)) + (:report (lambda (c s) + (let ((num (name-service-error-errno c))) + (format s "Name service error in \"~A\": ~A (~A)" + (name-service-error-syscall c) + (or (name-service-error-symbol c) + (name-service-error-errno c)) + (get-name-service-error-message num)))))) + +(defmacro define-name-service-condition (symbol name) + `(progn + (define-condition ,name (name-service-error) + ((symbol :reader name-service-error-symbol :initform (quote ,symbol)))) + (push (cons ,symbol (quote ,name)) *conditions-for-name-service-errno*))) + +(defparameter *conditions-for-name-service-errno* nil) + +(define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error) +(define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error) +(define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error) +(define-name-service-condition sockint::TRY-AGAIN try-again-error) +(define-name-service-condition sockint::NO-RECOVERY no-recovery-error) +;; this is the same as the next one +;;(define-name-service-condition sockint::NO-DATA no-data-error) +(define-name-service-condition sockint::NO-ADDRESS no-address-error) + +(defun condition-for-name-service-errno (err) + (or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql)) + 'name-service)) + + + +(defun get-name-service-errno () + (setf *name-service-errno* + (sb-alien:alien-funcall + (sb-alien:extern-alien "get_h_errno" (function integer))))) + +#-solaris +(progn + #+sbcl + (sb-alien:define-alien-routine "hstrerror" + sb-c-call:c-string + (errno integer)) + #+cmu + (alien:def-alien-routine "hstrerror" + sb-c-call:c-string + (errno integer)) + (defun get-name-service-error-message (num) + (hstrerror num)) +) + diff --git a/contrib/bsd-sockets/rt.lisp b/contrib/bsd-sockets/rt.lisp new file mode 100644 index 0000000..ab7a79c --- /dev/null +++ b/contrib/bsd-sockets/rt.lisp @@ -0,0 +1,167 @@ +;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +;This is the December 19, 1990 version of the regression tester. + +(defpackage "RT" + (:use "COMMON-LISP") + (:export deftest get-test do-test rem-test + rem-all-tests do-tests pending-tests + continue-testing *test* + *do-tests-when-defined*)) +(in-package :rt) +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~@:(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + (*break-on-warnings* t) + (r (multiple-value-list + (eval (form entry))))) + (setf (pend entry) + (not (equal r (vals entry)))) + (when (pend entry) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~ + ~%Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + *test* (form entry) + (length (vals entry)) + (vals entry) + (length r) r)))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests))) + (if (null pending) + (format s "~&No tests failed.") + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending)) + (null pending))) diff --git a/contrib/bsd-sockets/sockets.lisp b/contrib/bsd-sockets/sockets.lisp new file mode 100644 index 0000000..630a73d --- /dev/null +++ b/contrib/bsd-sockets/sockets.lisp @@ -0,0 +1,279 @@ +(in-package "BSD-SOCKETS") + +;;;; Methods, classes, functions for sockets. Protocol-specific stuff +;;;; is deferred to inet.lisp, unix.lisp, etc + +#||

SOCKETs

+ +|# + +(eval-when (:load-toplevel :compile-toplevel :execute) +(defclass socket () + ((file-descriptor :initarg :descriptor + :reader socket-file-descriptor) + (family :initform (error "No socket family") :reader socket-family) + (protocol :initarg :protocol :reader socket-protocol) + (type :initarg :type :reader socket-type) + (stream)))) + +(defmethod print-object ((object socket) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ "descriptor " stream) + (princ (slot-value object 'file-descriptor) stream))) + + +(defmethod shared-initialize :after ((socket socket) slot-names + &key protocol type + &allow-other-keys) + (let* ((proto-num + (cond ((and protocol (keywordp protocol)) + (get-protocol-by-name (string-downcase (symbol-name protocol)))) + (protocol protocol) + (t 0))) + (fd (or (and (slot-boundp socket 'file-descriptor) + (socket-file-descriptor socket)) + (sockint::socket (socket-family socket) + (ecase type + ((:datagram) sockint::sock-dgram) + ((:stream) sockint::sock-stream)) + proto-num)))) + (if (= fd -1) (socket-error "socket")) + (setf (slot-value socket 'file-descriptor) fd + (slot-value socket 'protocol) proto-num + (slot-value socket 'type) type) + (sb-ext:finalize socket (lambda () (sockint::close fd))))) + + + +;; we deliberately redesign the "bind" interface: instead of passing a +;; sockaddr_something as second arg, we pass the elements of one as +;; multiple arguments. + +(defgeneric socket-bind (socket &rest address)) +(defmethod socket-bind ((socket socket) + &rest address) + "Bind SOCKET to ADDRESS, which may vary according to socket family. For +the INET family, pass ADDRESS and PORT as two arguments; for FILE address +family sockets, pass the filename string. See also bind(2)" + (let ((sockaddr (apply #'make-sockaddr-for socket nil address))) + (if (= (sb-sys:without-gcing + (sockint::bind (socket-file-descriptor socket) + (sockint::array-data-address sockaddr) + (size-of-sockaddr socket))) + -1) + (socket-error "bind")))) + + +(defmethod socket-accept ((socket socket)) + "Perform the accept(2) call, returning a newly-created connected socket +and the peer address as multiple values" + (let* ((sockaddr (make-sockaddr-for socket)) + (fd (sb-sys:without-gcing + (sockint::accept (socket-file-descriptor socket) + (sockint::array-data-address sockaddr) + (size-of-sockaddr socket))))) + (apply #'values + (if (= fd -1) + (socket-error "accept") + (let ((s (make-instance (class-of socket) + :type (socket-type socket) + :protocol (socket-protocol socket) + :descriptor fd))) + (sb-ext:finalize s (lambda () (sockint::close fd))))) + (multiple-value-list (bits-of-sockaddr socket sockaddr))))) + +(defgeneric socket-connect (socket &rest address)) +(defmethod socket-connect ((socket socket) &rest peer) + "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value" + (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer))) + (if (= (sb-sys:without-gcing + (sockint::connect (socket-file-descriptor socket) + (sockint::array-data-address sockaddr) + (size-of-sockaddr socket))) + -1) + (socket-error "connect") ))) + +(defmethod socket-peername ((socket socket)) + "Return the socket's peer; depending on the address family this may return multiple values" + (let* ((sockaddr (make-sockaddr-for socket))) + (when (= (sb-sys:without-gcing + (sockint::getpeername (socket-file-descriptor socket) + (sockint::array-data-address sockaddr) + (size-of-sockaddr socket))) + -1) + (socket-error "getpeername")) + (bits-of-sockaddr socket sockaddr))) + +(defmethod socket-name ((socket socket)) + "Return the address (as vector of bytes) and port that the socket is bound to, as multiple values" + (let* ((sockaddr (make-sockaddr-for socket))) + (when (= (sb-sys:without-gcing + (sockint::getsockname (socket-file-descriptor socket) + (sockint::array-data-address sockaddr) + (size-of-sockaddr socket))) + -1) + (socket-error "getsockname")) + (bits-of-sockaddr socket sockaddr))) + + +;;; There are a whole bunch of interesting things you can do with a +;;; socket that don't really map onto "do stream io", especially in +;;; CL which has no portable concept of a "short read". socket-receive +;;; allows us to read from an unconnected socket into a buffer, and +;;; to learn who the sender of the packet was + +(defmethod socket-receive ((socket socket) buffer length + &key + oob peek waitall + (element-type 'character)) + "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if +NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is +used, so at least one of these two arguments must be non-NIL. If +BUFFER is supplied, it had better be of an element type one octet wide. +Returns the buffer, its length, and the address of the peer +that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC +so that the actual packet length is returned even if the buffer was too +small" + (let ((flags + (logior (if oob sockint::MSG-OOB 0) + (if peek sockint::MSG-PEEK 0) + (if waitall sockint::MSG-WAITALL 0) + sockint::MSG-NOSIGNAL ;don't send us SIGPIPE + (if (eql (socket-type socket) :datagram) + sockint::msg-TRUNC 0))) + (sockaddr (make-sockaddr-for socket))) + (unless (or buffer length) + (error "Must supply at least one of BUFFER or LENGTH")) + (unless buffer + (setf buffer (make-array length :element-type element-type))) + (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2))) + (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket)) + (sb-sys:without-gcing + (let ((len + (sockint::recvfrom (socket-file-descriptor socket) + (sockint::array-data-address buffer) + (or length (length buffer)) + flags + (sockint::array-data-address sockaddr) + (sb-alien:cast sa-len (* integer))))) + (when (= len -1) (socket-error "recvfrom")) + (apply #'values buffer len (multiple-value-list + (bits-of-sockaddr socket sockaddr)))))))) + + + +(defmethod socket-listen ((socket socket) backlog) + "Mark SOCKET as willing to accept incoming connections. BACKLOG +defines the maximum length that the queue of pending connections may +grow to before new connection attempts are refused. See also listen(2)" + (let ((r (sockint::listen (socket-file-descriptor socket) backlog))) + (if (= r -1) + (socket-error "listen")))) + +(defmethod socket-close ((socket socket)) + "Close SOCKET. May throw any kind of error that write(2) would have +thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that +stream instead" + ;; the close(2) manual page has all kinds of warning about not + ;; checking the return value of close, on the grounds that an + ;; earlier write(2) might have returned successfully w/o actually + ;; writing the stuff to disk. It then goes on to define the only + ;; possible error return as EBADF (fd isn't a valid open file + ;; descriptor). Presumably this is an oversight and we could also + ;; get anything that write(2) would have given us. + + ;; What we do: we catch EBADF. It should only ever happen if + ;; (a) someone's closed the socket already (stream closing seems + ;; to have this effect) or (b) the caller is messing around with + ;; socket internals. That's not supported, dude + + (if (slot-boundp socket 'stream) + (close (slot-value socket 'stream)) ;; closes socket as well + (handler-case + (if (= (sockint::close (socket-file-descriptor socket)) -1) + (socket-error "close")) + (bad-file-descriptor-error (c) (declare (ignore c)) nil) + (:no-error (c) (declare (ignore c)) nil)))) + +(defmethod socket-make-stream ((socket socket) &rest args) + "Find or create a STREAM that can be used for IO on SOCKET (which +must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM." + (let ((stream + (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) + (unless stream + (setf stream (apply #'sb-sys:make-fd-stream + (socket-file-descriptor socket) args)) + (setf (slot-value socket 'stream) stream) + (sb-ext:cancel-finalization socket)) + stream)) + + + +;;; Error handling + +(define-condition socket-error (error) + ((errno :initform nil + :initarg :errno + :reader socket-error-errno) + (symbol :initform nil :initarg :symbol :reader socket-error-symbol) + (syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall)) + (:report (lambda (c s) + (let ((num (socket-error-errno c))) + (format s "Socket error in \"~A\": ~A (~A)" + (socket-error-syscall c) + (or (socket-error-symbol c) (socket-error-errno c)) + #+cmu (sb-unix:get-unix-error-msg num) + #+sbcl (sb-int:strerror num)))))) + +;;; watch out for slightly hacky symbol punning: we use both the value +;;; and the symbol-name of sockint::efoo + +(defmacro define-socket-condition (symbol name) + `(progn + (define-condition ,name (socket-error) + ((symbol :reader socket-error-symbol :initform (quote ,symbol)))) + (push (cons ,symbol (quote ,name)) *conditions-for-errno*))) + +(defparameter *conditions-for-errno* nil) +;;; this needs the rest of the list adding to it, really. They also +;;; need +;;; - conditions to be exported in the DEFPACKAGE form +;;; - symbols to be added to constants.ccon +;;; I haven't yet thought of a non-kludgey way of keeping all this in +;;; the same place +(define-socket-condition sockint::EADDRINUSE address-in-use-error) +(define-socket-condition sockint::EAGAIN interrupted-error) +(define-socket-condition sockint::EBADF bad-file-descriptor-error) +(define-socket-condition sockint::ECONNREFUSED connection-refused-error) +(define-socket-condition sockint::EINTR interrupted-error) +(define-socket-condition sockint::EINVAL invalid-argument-error) +(define-socket-condition sockint::ENOBUFS no-buffers-error) +(define-socket-condition sockint::ENOMEM out-of-memory-error) +(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) +(define-socket-condition sockint::EPERM operation-not-permitted-error) +(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) +(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) +(define-socket-condition sockint::ENETUNREACH network-unreachable-error) + + +(defun condition-for-errno (err) + (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error)) + +#+cmu +(defun socket-error (where) + ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them) + ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO + ;; to update the value that unix-errno looks at. On other CMUCL + ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist + (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno)) + (let ((condition (condition-for-errno sb-unix:unix-errno))) + (error condition :errno sb-unix:unix-errno :syscall where))) + +#+sbcl +(defun socket-error (where) + (let* ((errno (sb-unix::get-errno)) + (condition (condition-for-errno errno))) + (error condition :errno errno :syscall where))) + + + diff --git a/contrib/bsd-sockets/sockopt.lisp b/contrib/bsd-sockets/sockopt.lisp new file mode 100644 index 0000000..4f7944e --- /dev/null +++ b/contrib/bsd-sockets/sockopt.lisp @@ -0,0 +1,189 @@ +(in-package :bsd-sockets) + +#|| +

Socket Options

+ +

A subset of socket options are supported, using a fairly +general framework which should make it simple to add more as required +- see sockopt.lisp for details. The name mapping from C is fairly +straightforward: SO_RCVLOWAT becomes +sockopt-receive-low-water and (setf +sockopt-receive-low-water). +||# + +#| +getsockopt(socket, level, int optname, void *optval, socklen_t *optlen) +setsockopt(socket, level, int optname, void *optval, socklen_t optlen) + ^ SOL_SOCKET or a protocol number + +In terms of providing a useful interface, we have to face up to the +fact that most of these take different data types - some are integers, +some are booleans, some are foreign struct instances, etc etc + +(define-socket-option lisp-name level number mangle-arg size mangle-return) + +macro-expands to two functions that define lisp-name and (setf ,lisp-name) +and calls the functions mangle-arg and mangle-return on outgoing and incoming +data resp. + +Parameters passed to the function thus defined (lisp-name) +are all passed directly into mangle-arg. mangle-arg should return an +alien pointer - this is passed unscathed to the foreign routine, so +wants to have type (* t). Note that even for options that have +integer arguments, this is still a pointer to said integer. + +size is the size of the buffer that the return of mangle-arg points +to, and also of the buffer that we should allocate for getsockopt +to write into. + +mangle-return is called with an alien buffer and should turn it into +something that the caller will want. + +Code for options that not every system has should be conditionalised: + +(if (boundp 'sockint::IP_RECVIF) + (define-socket-option so-receive-interface (getprotobyname "ip") + sockint::IP_RECVIF ... )) + + +|# + +(defmacro define-socket-option + (lisp-name level number mangle-arg size mangle-return) + (let ((find-level + (if (numberp (eval level)) + level + `(get-protocol-by-name ,(string-downcase (symbol-name level)))))) + `(progn + (export ',lisp-name) + (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket))) + (sb-sys:without-gcing + (let ((buf (make-array sockint::size-of-int + :element-type '(unsigned-byte 8) + :initial-element 0))) + (if (= -1 (sockint::getsockopt + fd ,find-level ,number (sockint::array-data-address buf) ,size)) + (socket-error "getsockopt") + (,mangle-return buf ,size))))) + (defun (setf ,lisp-name) (new-val socket + &aux (fd (socket-file-descriptor socket))) + (if (= -1 + (sb-sys:without-gcing + (sockint::setsockopt + fd ,find-level ,number (funcall (function ,mangle-arg) new-val ,size) + ,size))) + (socket-error "setsockopt")))))) + +;;; sockopts that have integer arguments + +(defun int-to-foreign (x size) + ;; can't use with-alien, as the variables it creates only have + ;; dynamic scope. can't use the passed-in size because sap-alien + ;; is a macro and evaluates its second arg at read time + (let* ((v (make-array size :element-type '(unsigned-byte 8) + :initial-element 0)) + (d (sockint::array-data-address v)) + (alien (sb-alien:sap-alien + d; (sb-sys:int-sap d) + (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) + (setf (sb-alien:deref alien 0) x) + alien)) + +(defun buffer-to-int (x size) + (declare (ignore size)) + (let ((alien (sb-alien:sap-alien + (sockint::array-data-address x) + (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) + (sb-alien:deref alien))) + +(defmacro define-socket-option-int (name level number) + `(define-socket-option ,name ,level ,number + int-to-foreign sockint::size-of-int buffer-to-int)) + +(define-socket-option-int + sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat) +(define-socket-option-int + sockopt-send-low-water sockint::sol-socket sockint::so-sndlowat) +(define-socket-option-int + sockopt-type sockint::sol-socket sockint::so-type) +(define-socket-option-int + sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf) +(define-socket-option-int + sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf) +(define-socket-option-int + sockopt-priority sockint::sol-socket sockint::so-priority) + +;;; boolean options are integers really + +(defun bool-to-foreign (x size) + (int-to-foreign (if x 1 0) size)) + +(defun buffer-to-bool (x size) + (not (= (buffer-to-int x size) 0))) + +(defmacro define-socket-option-bool (name level number) + `(define-socket-option ,name ,level ,number + bool-to-foreign sockint::size-of-int buffer-to-bool)) + +(define-socket-option-bool + sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr) +(define-socket-option-bool + sockopt-keep-alive sockint::sol-socket sockint::so-keepalive) +(define-socket-option-bool + sockopt-oob-inline sockint::sol-socket sockint::so-oobinline) +(define-socket-option-bool + sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat) +(define-socket-option-bool + sockopt-pass-credentials sockint::sol-socket sockint::so-passcred) +(define-socket-option-bool + sockopt-debug sockint::sol-socket sockint::so-debug) +(define-socket-option-bool + sockopt-dont-route sockint::sol-socket sockint::so-dontroute) +(define-socket-option-bool + sockopt-broadcast sockint::sol-socket sockint::so-broadcast) + +(define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay) + +(defun string-to-foreign (string size) + (declare (ignore size)) + (let ((data (sockint::array-data-address string))) + (sb-alien:sap-alien data (* t)))) + +(defun buffer-to-string (x size) + (declare (ignore size)) + (sb-c-call::%naturalize-c-string + (sockint::array-data-address x))) + +(define-socket-option sockopt-bind-to-device sockint::sol-socket + sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz + buffer-to-string) + +;;; other kinds of socket option + +;;; so_peercred takes a ucre structure +;;; so_linger struct linger { +; int l_onoff; /* linger active */ +; int l_linger; /* how many seconds to linger for */ +; }; + +#| + +(sockopt-reuse-address 2) + +(defun echo-server () + (let ((s (make-inet-socket :stream (get-protocol-by-name "tcp")))) + (setf (sockopt-reuse-address s) t) + (setf (sockopt-bind-to-device s) "lo") + (socket-bind s (make-inet-address "127.0.0.1") 3459) + (socket-listen s 5) + (dotimes (i 10) + (let* ((s1 (socket-accept s)) + (stream (socket-make-stream s1 :input t :output t :buffering :none))) + (let ((line (read-line stream))) + (format t "got one ~A ~%" line) + (format stream "~A~%" line)) + (close stream))))) + +NIL +|# + diff --git a/contrib/bsd-sockets/split.lisp b/contrib/bsd-sockets/split.lisp new file mode 100644 index 0000000..2c0d17c --- /dev/null +++ b/contrib/bsd-sockets/split.lisp @@ -0,0 +1,23 @@ +(in-package :bsd-sockets) + +;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100 +;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de> + +(defun split (string &optional max (ws '(#\Space #\Tab))) + "Split `string' along whitespace as defined by the sequence `ws'. +The whitespace is elided from the result. The whole string will be +split, unless `max' is a non-negative integer, in which case the +string will be split into `max' tokens at most, the last one +containing the whole rest of the given `string', if any." + (flet ((is-ws (char) (find char ws))) + (loop for start = (position-if-not #'is-ws string) + then (position-if-not #'is-ws string :start index) + for index = (and start + (if (and max (= (1+ word-count) max)) + nil + (position-if #'is-ws string :start start))) + while start + collect (subseq string start index) + count 1 into word-count + while index))) + diff --git a/contrib/bsd-sockets/tests.lisp b/contrib/bsd-sockets/tests.lisp new file mode 100644 index 0000000..347ddd1 --- /dev/null +++ b/contrib/bsd-sockets/tests.lisp @@ -0,0 +1,225 @@ +(defpackage "BSD-SOCKETS-TEST" + (:use "CL" "BSD-SOCKETS" "RT")) + +#|| + +

Tests

+ +There should be at least one test for pretty much everything you can do +with the package. In some places I've been more diligent than others; more +tests gratefully accepted. + +Tests are in the file tests.lisp and also make good examples. + +||# + +(in-package :bsd-sockets-test) + +;;; a real address +(deftest make-inet-address + (equalp (make-inet-address "127.0.0.1") #(127 0 0 1)) + t) +;;; and an address with bit 8 set on some octets +(deftest make-inet-address2 + (equalp (make-inet-address "242.1.211.3") #(242 1 211 3)) + t) + +(deftest make-inet-socket + ;; make a socket + (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + (and (> (socket-file-descriptor s) 1) t)) + t) + +(deftest make-inet-socket-keyword + ;; make a socket + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (and (> (socket-file-descriptor s) 1) t)) + t) + +(deftest make-inet-socket-wrong + ;; fail to make a socket: check correct error return. There's no nice + ;; way to check the condition stuff on its own, which is a shame + (handler-case + (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) + ((or socket-type-not-supported-error protocol-not-supported-error) (c) + (declare (ignorable c)) t) + (:no-error nil)) + t) + +(deftest make-inet-socket-keyword-wrong + ;; same again with keywords + (handler-case + (make-instance 'inet-socket :type :stream :protocol :udp) + ((or protocol-not-supported-error socket-type-not-supported-error) (c) + (declare (ignorable c)) t) + (:no-error nil)) + t) + + +(deftest non-block-socket + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (setf (non-blocking-mode s) t) + (non-blocking-mode s)) + t) + +(defun do-gc-portably () + ;; cmucl on linux has generational gc with a keyword argument, + ;; sbcl GC function takes same arguments no matter what collector is in + ;; use + #+(or sbcl gencgc) (SB-EXT:gc :full t) + ;; other platforms have full gc or nothing + #-(or sbcl gencgc) (sb-ext:gc)) + +(deftest inet-socket-bind + (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + ;; Given the functions we've got so far, if you can think of a + ;; better way to make sure the bind succeeded than trying it + ;; twice, let me know + ;; 1974 has no special significance, unless you're the same age as me + (do-gc-portably) ;gc should clear out any old sockets bound to this port + (socket-bind s (make-inet-address "127.0.0.1") 1974) + (handler-case + (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + (socket-bind s2 (make-inet-address "127.0.0.1") 1974) + nil) + (address-in-use-error () t))) + t) + +(deftest simple-sockopt-test + ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in + ;; the process that all the weird macros in sockopt happened right. + (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + (setf (sockopt-reuse-address s) t) + (sockopt-reuse-address s)) + t) + +(defun read-buf-nonblock (buffer stream) + "Like READ-SEQUENCE, but returns early if the full quantity of data isn't there to be read. Blocks if no input at all" + (let ((eof (gensym))) + (do ((i 0 (1+ i)) + (c (read-char stream nil eof) + (read-char-no-hang stream nil eof))) + ((or (>= i (length buffer)) (not c) (eq c eof)) i) + (setf (elt buffer i) c)))) + +;;; these require that the echo services are turned on in inetd + +(deftest simple-tcp-client + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) + (data (make-string 200))) + (socket-connect s #(127 0 0 1) 7) + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream "here is some text") + (let ((data (subseq data 0 (read-buf-nonblock data stream)))) + (format t "~&Got ~S back from TCP echo server~%" data) + (> (length data) 0)))) + t) + +(deftest simple-udp-client + (let ((s (make-instance 'inet-socket :type :datagram :protocol (get-protocol-by-name "udp"))) + (data (make-string 200))) + (format t "Socket type is ~A~%" (sockopt-type s)) + (socket-connect s #(127 0 0 1) 7) + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream "here is some text") + (let ((data (subseq data 0 (read-buf-nonblock data stream)))) + (format t "~&Got ~S back from UDP echo server~%" data) + (> (length data) 0)))) + t) + +#|| +

Unix-domain sockets

+ +A fairly rudimentary test that connects to the syslog socket and sends a +message. Priority 7 is kern.debug; you'll probably want to look at +/etc/syslog.conf or local equivalent to find out where the message ended up +||# + +(deftest simple-unix-client + (let ((s (make-instance 'unix-socket :type :datagram))) + (format t "~A~%" s) + (socket-connect s "/dev/log") + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream + "<7>bsd-sockets: Don't panic. We're testing unix-domain client code; this message can safely be ignored") + t)) + t) + + +;;; these require that the internet (or bits of it, atleast) is available + +(deftest get-host-by-name + (equalp (car (host-ent-addresses (get-host-by-name "a.root-servers.net"))) + #(198 41 0 4)) + t) + +(deftest get-host-by-address + (host-ent-name (get-host-by-address #(198 41 0 4))) + "a.root-servers.net") + +(deftest get-host-by-name-wrong + (handler-case + (get-host-by-name "foo.tninkpad.telent.net") + (NAME-SERVICE-ERROR () t) + (:no-error nil)) + t) + +(defun http-stream (host port request) + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (socket-connect + s (car (host-ent-addresses (get-host-by-name host))) port) + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream "~A HTTP/1.0~%~%" request)) + s)) + +(deftest simple-http-client-1 + (handler-case + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (princ data) + (> (length data) 0))) + (network-unreachable-error () 'network-unreachable)) + t) + + +(deftest sockopt-receive-buffer + ;; on Linux x86, the receive buffer size appears to be doubled in the + ;; kernel: we set a size of x and then getsockopt() returns 2x. + ;; This is why we compare with >= instead of = + (handler-case + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (setf (sockopt-receive-buffer s) 1975) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (and (> (length data) 0) + (>= (sockopt-receive-buffer s) 1975)))) + (network-unreachable-error () 'network-unreachable)) + t) + + +;;; we don't have an automatic test for some of this yet. There's no +;;; simple way to run servers and have something automatically connect +;;; to them as client, unless we spawn external programs. Then we +;;; have to start telling people what external programs they should +;;; have installed. Which, eventually, we will, but not just yet + + +;;; to check with this: can display packets from multiple peers +;;; peer address is shown correctly for each packet +;;; packet length is correct +;;; long (>500 byte) packets have the full length shown (doesn't work) + +(defun udp-server (port) + (let ((s (make-instance 'inet-socket :type :datagram :protocol :udp))) + (socket-bind s #(0 0 0 0) port) + (loop + (multiple-value-bind (buf len address port) (socket-receive s nil 500) + (format t "Received ~A bytes from ~A:~A - ~A ~%" + len address port (subseq buf 0 (min 10 len))))))) + + diff --git a/contrib/bsd-sockets/unix.lisp b/contrib/bsd-sockets/unix.lisp new file mode 100644 index 0000000..61cf005 --- /dev/null +++ b/contrib/bsd-sockets/unix.lisp @@ -0,0 +1,40 @@ +(in-package :bsd-sockets) + +#||

File-domain sockets

+ +File-domain (AF_FILE) sockets are also known as Unix-domain sockets, but were +renamed by POSIX presumably on the basis that they may be +available on other systems too. + +A file-domain socket address is a string, which is used to create a node +in the local filesystem. This means of course that they cannot be used across +a network. + +||# + +(defclass unix-socket (socket) + ((family :initform sockint::af-unix))) + +(defmethod make-sockaddr-for ((socket unix-socket) &optional sockaddr &rest address &aux (filename (first address))) + (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un)))) + (setf (sockint::sockaddr-un-family sockaddr) sockint::af-unix) + (when filename + (loop for c across filename + ;; XXX magic constant ew ew ew. should grovel this from + ;; system headers + for i from 0 to (min 107 (1- (length filename))) + do (setf (sockint::sockaddr-un-path sockaddr i) (char-code c)) + finally + (setf (sockint::sockaddr-un-path sockaddr (1+ i)) 0))) + sockaddr)) + +(defmethod size-of-sockaddr ((socket unix-socket)) + sockint::size-of-sockaddr-un) + +(defmethod bits-of-sockaddr ((socket unix-socket) sockaddr) + "Returns filename of SOCKADDR" + (let ((name (sb-c-call::%naturalize-c-string + (sb-sys:sap+ (sockint::array-data-address sockaddr) + sockint::offset-of-sockaddr-un-path)))) + (if (zerop (length name)) nil name))) + diff --git a/install.sh b/install.sh index e58871d..5fab6a2 100644 --- a/install.sh +++ b/install.sh @@ -2,9 +2,44 @@ # 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 77e058e..357908f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -615,7 +615,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; 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 diff --git a/src/code/module.lisp b/src/code/module.lisp index 59835d3..77fe18b 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -1,12 +1,8 @@ ;;;; 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. @@ -26,69 +22,49 @@ "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*)) ;;;; 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)))))) + ;;;; 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)) + + diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 55f4d50..908bd8c 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -271,10 +271,12 @@ main(int argc, char *argv[], char *envp[]) 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) { diff --git a/version.lisp-expr b/version.lisp-expr index e768dd1..aeab4ed 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.12.23" +"0.7.12.24" -- 1.7.10.4