X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fsockets.lisp;h=072dc079986affa7b588fe05542f37a0fa3eedc7;hb=27763fafd1b170518ac2e85b9344fdddddcfd7c5;hp=bb4e7c1b959e49e2c9c57a89c13569441f7fb322;hpb=0fe5525f1f9d9f5eff63e583b5b7b19c0e1cb933;p=sbcl.git diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index bb4e7c1..072dc07 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -4,22 +4,23 @@ ;;;; is deferred to inet.lisp, unix.lisp, etc (eval-when (:load-toplevel :compile-toplevel :execute) + (defclass socket () ((file-descriptor :initarg :descriptor - :reader socket-file-descriptor) + :reader socket-file-descriptor) (family :initform (error "No socket family") - :reader socket-family) + :reader socket-family) (protocol :initarg :protocol - :reader socket-protocol - :documentation "Protocol used by the socket. If a + :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.") + :reader socket-type + :documentation "Type of the socket: :STREAM or :DATAGRAM.") (stream)) - (:documentation "Common base class of all sockets, not ment to be + (:documentation "Common base class of all sockets, not meant to be directly instantiated."))) (defmethod print-object ((object socket) stream) @@ -29,24 +30,24 @@ directly instantiated."))) (defmethod shared-initialize :after ((socket socket) slot-names - &key protocol type - &allow-other-keys) + &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)))) + (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) + (slot-value socket 'protocol) proto-num + (slot-value socket 'type) type) (sb-ext:finalize socket (lambda () (sockint::close fd))))) @@ -78,8 +79,8 @@ See also bind(2)")) &rest address) (with-sockaddr-for (socket sockaddr address) (if (= (sockint::bind (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) + sockaddr + (size-of-sockaddr socket)) -1) (socket-error "bind")))) @@ -88,24 +89,26 @@ See also bind(2)")) (:documentation "Perform the accept(2) call, returning a newly-created connected socket and the peer address as multiple values")) - + (defmethod socket-accept ((socket socket)) (with-sockaddr-for (socket sockaddr) (let ((fd (sockint::accept (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)))) + sockaddr + (size-of-sockaddr socket)))) (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)))))))) - + ((and (= fd -1) + (member (sb-unix::get-errno) + (list sockint::EAGAIN sockint::EINTR))) + 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 remote PEER. No useful return value.")) @@ -113,21 +116,21 @@ values")) (defmethod socket-connect ((socket socket) &rest peer) (with-sockaddr-for (socket sockaddr peer) (if (= (sockint::connect (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) - (socket-error "connect")))) + sockaddr + (size-of-sockaddr socket)) + -1) + (socket-error "connect")))) (defgeneric socket-peername (socket) (:documentation "Return the socket's peer; depending on the address family this may return multiple values")) - + (defmethod socket-peername ((socket socket)) (with-sockaddr-for (socket sockaddr) (when (= (sockint::getpeername (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) + sockaddr + (size-of-sockaddr socket)) + -1) (socket-error "getpeername")) (bits-of-sockaddr socket sockaddr))) @@ -138,9 +141,9 @@ values")) (defmethod socket-name ((socket socket)) (with-sockaddr-for (socket sockaddr) (when (= (sockint::getsockname (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) + sockaddr + (size-of-sockaddr socket)) + -1) (socket-error "getsockname")) (bits-of-sockaddr socket sockaddr))) @@ -152,8 +155,8 @@ values")) ;;; to learn who the sender of the packet was (defgeneric socket-receive (socket buffer length - &key - oob peek waitall element-type) + &key + oob peek waitall element-type) (:documentation "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 @@ -162,54 +165,127 @@ 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")) - + (defmethod socket-receive ((socket socket) buffer length - &key - oob peek waitall - (element-type 'character)) + &key + oob peek waitall + (element-type 'character)) (with-sockaddr-for (socket sockaddr) (let ((flags - (logior (if oob sockint::MSG-OOB 0) - (if peek sockint::MSG-PEEK 0) - (if waitall sockint::MSG-WAITALL 0) - #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE - (if (eql (socket-type socket) :datagram) - sockint::msg-TRUNC 0)))) + (logior (if oob sockint::MSG-OOB 0) + (if peek sockint::MSG-PEEK 0) + (if waitall sockint::MSG-WAITALL 0) + #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE + (if (eql (socket-type socket) :datagram) + sockint::msg-TRUNC 0)))) (unless (or buffer length) - (error "Must supply at least one of BUFFER or LENGTH")) + (error "Must supply at least one of BUFFER or LENGTH")) (unless length - (setf length (length buffer))) + (setf length (length buffer))) (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.")) + (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))) + (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 sockint::socklen-t (size-of-sockaddr socket))) - (let ((len - (sockint::recvfrom (socket-file-descriptor socket) - copy-buffer - length - flags - 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)))))) + (unwind-protect + (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:addr sa-len)))) + (cond + ((and (= len -1) + (member (sb-unix::get-errno) + (list sockint::EAGAIN sockint::EINTR))) + 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)))))) + +(defmacro with-vector-sap ((name vector) &body body) + `(sb-sys:with-pinned-objects (,vector) + (let ((,name (sb-sys:vector-sap ,vector))) + ,@body))) + +(defgeneric socket-send (socket buffer length + &key + address + external-format + oob eor dontroute dontwait nosignal + #+linux confirm #+linux more) + (:documentation + "Send LENGTH octets from BUFFER into SOCKET, using sendto(2). If BUFFER +is a string, it will converted to octets according to EXTERNAL-FORMAT. If +LENGTH is NIL, the length of the octet buffer is used. The format of ADDRESS +depends on the socket type (for example for INET domain sockets it would +be a list of an IP address and a port). If no socket address is provided, +send(2) will be called instead. Returns the number of octets written.")) + +(defmethod socket-send ((socket socket) buffer length + &key + address + (external-format :default) + oob eor dontroute dontwait nosignal + #+linux confirm #+linux more) + (let* ((flags + (logior (if oob sockint::MSG-OOB 0) + (if eor sockint::MSG-EOR 0) + (if dontroute sockint::MSG-DONTROUTE 0) + (if dontwait sockint::MSG-DONTWAIT 0) + (if nosignal sockint::MSG-NOSIGNAL 0) + #+linux (if confirm sockint::MSG-CONFIRM 0) + #+linux (if more sockint::MSG-MORE 0))) + (buffer (etypecase buffer + (string + (sb-ext:string-to-octets buffer + :external-format external-format + :null-terminate nil)) + ((simple-array (unsigned-byte 8)) + buffer) + ((array (unsigned-byte 8)) + (make-array (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer)))) + (len (with-vector-sap (buffer-sap buffer) + (unless length + (setf length (length buffer))) + (if address + (with-sockaddr-for (socket sockaddr address) + (sb-alien:with-alien ((sa-len sockint::socklen-t + (size-of-sockaddr socket))) + (sockint::sendto (socket-file-descriptor socket) + buffer-sap + length + flags + sockaddr + sa-len))) + (sockint::send (socket-file-descriptor socket) + buffer-sap + length + flags))))) + (cond + ((and (= len -1) + (member (sb-unix::get-errno) + (list sockint::EAGAIN sockint::EINTR))) + nil) + ((= len -1) + (socket-error "sendto")) + (t len)))) (defgeneric socket-listen (socket backlog) (:documentation "Mark SOCKET as willing to accept incoming connections. BACKLOG @@ -224,7 +300,7 @@ grow to before new connection attempts are refused. See also listen(2)")) (defgeneric socket-open-p (socket) (:documentation "Return true if SOCKET is open; otherwise, return false.") (:method ((socket t)) (error 'type-error - :datum socket :expected-type 'socket))) + :datum socket :expected-type 'socket))) (defmethod socket-open-p ((socket socket)) (if (slot-boundp socket 'stream) @@ -245,30 +321,30 @@ calls CLOSE on that stream instead")) ;; descriptor). Presumably this is an oversight and we could also ;; get anything that write(2) would have given us. - ;; note that if you have a socket _and_ a stream on the same fd, + ;; note that if you have a socket _and_ a stream on the same fd, ;; the socket will avoid doing anything to close the fd in case ;; the stream has done it already - if so, it may have been ;; reassigned to some other file, and closing it would be bad (let ((fd (socket-file-descriptor socket))) (cond ((eql fd -1) ; already closed - nil) - ((slot-boundp socket 'stream) - (unwind-protect (close (slot-value socket 'stream)) ;; closes fd - (setf (slot-value socket 'file-descriptor) -1) - (slot-makunbound socket 'stream))) - (t - (sb-ext:cancel-finalization socket) - (handler-case - (if (= (sockint::close fd) -1) - (socket-error "close")) - (bad-file-descriptor-error (c) (declare (ignore c)) nil) - (:no-error (c) + nil) + ((slot-boundp socket 'stream) + (unwind-protect (close (slot-value socket 'stream)) ;; closes fd + (setf (slot-value socket 'file-descriptor) -1) + (slot-makunbound socket 'stream))) + (t + (sb-ext:cancel-finalization socket) + (handler-case + (if (= (sockint::close fd) -1) + (socket-error "close")) + (bad-file-descriptor-error (c) (declare (ignore c)) nil) + (:no-error (c) (declare (ignore c)) (setf (slot-value socket 'file-descriptor) -1) nil)))))) - + (defgeneric socket-make-stream (socket &rest args) (:documentation "Find or create a STREAM that can be used for IO on SOCKET (which must be connected). ARGS are passed onto @@ -276,13 +352,13 @@ SB-SYS:MAKE-FD-STREAM.")) (defmethod socket-make-stream ((socket socket) &rest args) (let ((stream - (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) + (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) (unless stream (setf stream (apply #'sb-sys:make-fd-stream - (socket-file-descriptor socket) - :name "a constant string" - :dual-channel-p t - args)) + (socket-file-descriptor socket) + :name "a constant string" + :dual-channel-p t + args)) (setf (slot-value socket 'stream) stream) (sb-ext:cancel-finalization socket)) stream)) @@ -293,8 +369,8 @@ SB-SYS:MAKE-FD-STREAM.")) (define-condition socket-error (error) ((errno :initform nil - :initarg :errno - :reader socket-error-errno) + :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) @@ -339,7 +415,7 @@ SB-SYS:MAKE-FD-STREAM.")) (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)