X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fsockets.lisp;h=4a5249f55c53d7ec17ac55d52ab9dd4872d9f28d;hb=4bc6b918bb99e8dcd17bbe6479a06e52b2d04a6c;hp=6c68594530658dbbf29c789b15619776e51565a3;hpb=d4c7ab04ed10729a2cfa3321f4382d8a218ad958;p=sbcl.git diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index 6c68594..4a5249f 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -3,19 +3,25 @@ ;;;; 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)))) - + (family :initform (error "No socket family") + :reader socket-family) + (protocol :initarg :protocol + :reader socket-protocol + :documentation "Protocol used by the socket. If a +keyword, the symbol-name of the keyword will be passed to +GET-PROTOCOL-BY-NAME downcased, and the returned value used as +protocol. Other values are used as-is.") + (type :initarg :type + :reader socket-type + :documentation "Type of the socket: :STREAM or :DATAGRAM.") + (stream)) + (:documentation "Common base class of all sockets, not ment to be +directly instantiated."))) + (defmethod print-object ((object socket) stream) (print-unreadable-object (object stream :type t :identity t) (princ "descriptor " stream) @@ -53,7 +59,7 @@ When SOCKADDR is passed, it is used instead of a new object.")) (:documentation "Deallocate a Socket Address object that was created for SOCKET.")) -(defmacro with-sockaddr-for ((socket sockaddr sockaddr-args) &body body) +(defmacro with-sockaddr-for ((socket sockaddr &optional sockaddr-args) &body body) `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args))) (unwind-protect (progn ,@body) (free-sockaddr-for ,socket ,sockaddr)))) @@ -84,19 +90,21 @@ newly-created connected socket and the peer address as multiple values")) (defmethod socket-accept ((socket socket)) - (with-sockaddr-for (socket sockaddr nil) + (with-sockaddr-for (socket sockaddr) (let ((fd (sockint::accept (socket-file-descriptor socket) 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)))))) + (cond + ((and (= fd -1) (= sockint::EAGAIN (sb-unix::get-errno))) + nil) + ((= fd -1) (socket-error "accept")) + (t (apply #'values + (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) (:documentation "Perform the connect(2) call to connect SOCKET to a @@ -115,7 +123,7 @@ values")) family this may return multiple values")) (defmethod socket-peername ((socket socket)) - (with-sockaddr-for (socket sockaddr address) + (with-sockaddr-for (socket sockaddr) (when (= (sockint::getpeername (socket-file-descriptor socket) sockaddr (size-of-sockaddr socket)) @@ -128,7 +136,7 @@ values")) that the socket is bound to, as multiple values.")) (defmethod socket-name ((socket socket)) - (with-sockaddr-for (socket sockaddr nil) + (with-sockaddr-for (socket sockaddr) (when (= (sockint::getsockname (socket-file-descriptor socket) sockaddr (size-of-sockaddr socket)) @@ -159,7 +167,7 @@ small")) &key oob peek waitall (element-type 'character)) - (with-sockaddr-for (socket sockaddr nil) + (with-sockaddr-for (socket sockaddr) (let ((flags (logior (if oob sockint::MSG-OOB 0) (if peek sockint::MSG-PEEK 0) @@ -171,26 +179,38 @@ small")) (error "Must supply at least one of BUFFER or LENGTH")) (unless length (setf length (length buffer))) - (let ((copy-buffer (sb-alien:make-alien (array sb-alien:unsigned 1) length))) + (when buffer (setf element-type (array-element-type buffer))) + (unless (or (subtypep element-type 'character) + (subtypep element-type 'integer)) + (error "Buffer element-type must be either a character or an integer subtype.")) + (unless buffer + (setf buffer (make-array length :element-type element-type))) + ;; really big FIXME: This whole copy-buffer thing is broken. + ;; doesn't support characters more than 8 bits wide, or integer + ;; types that aren't (unsigned-byte 8). + (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length))) (unwind-protect - (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2))) - (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket)) + (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket))) (let ((len (sockint::recvfrom (socket-file-descriptor socket) copy-buffer length flags sockaddr - (sb-alien:cast sa-len (* integer))))) - (when (= len -1) (socket-error "recvfrom")) - (loop for i from 0 below len - do (setf (elt buffer i) (sb-alien:deref copy-buffer i))) - (apply #'values buffer len (multiple-value-list - (bits-of-sockaddr socket sockaddr))))) + (sb-alien:addr sa-len)))) + (cond + ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil) + ((= len -1) (socket-error "recvfrom")) + (t (loop for i from 0 below len + do (setf (elt buffer i) + (cond + ((or (eql element-type 'character) (eql element-type 'base-char)) + (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i))) + (t (sb-alien:deref (sb-alien:deref copy-buffer) i))))) + (apply #'values buffer len (multiple-value-list + (bits-of-sockaddr socket sockaddr))))))) (sb-alien:free-alien copy-buffer)))))) - - (defgeneric socket-listen (socket backlog) (:documentation "Mark SOCKET as willing to accept incoming connections. BACKLOG defines the maximum length that the queue of pending connections may @@ -269,7 +289,8 @@ SB-SYS:MAKE-FD-STREAM.")) (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)))))) + #+sbcl (sb-int:strerror num))))) + (:documentation "Common base class of socket related conditions.")) ;;; watch out for slightly hacky symbol punning: we use both the value ;;; and the symbol-name of sockint::efoo @@ -278,19 +299,19 @@ SB-SYS:MAKE-FD-STREAM.")) `(progn (define-condition ,name (socket-error) ((symbol :reader socket-error-symbol :initform (quote ,symbol)))) + (export ',name) (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 +;;; need 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::ETIMEDOUT operation-timeout-error) (define-socket-condition sockint::EINTR interrupted-error) (define-socket-condition sockint::EINVAL invalid-argument-error) (define-socket-condition sockint::ENOBUFS no-buffers-error) @@ -317,6 +338,9 @@ SB-SYS:MAKE-FD-STREAM.")) #+sbcl (defun socket-error (where) + ;; FIXME: Our Texinfo documentation extracter need at least his to spit + ;; out the signature. Real documentation would be better... + "" (let* ((errno (sb-unix::get-errno)) (condition (condition-for-errno errno))) (error condition :errno errno :syscall where)))