X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fsockets.lisp;h=886dd6e6064fa6e87b791616ba4fd208e28139f2;hb=6e02a5455aeef5a4642a2334348544c1f19775ad;hp=c010811f5dc81275e4f3f6cb1c0ac49a7abd9bb9;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index c010811..886dd6e 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -4,6 +4,7 @@ ;;;; 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) @@ -19,14 +20,25 @@ protocol. Other values are used as-is.") :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) (print-unreadable-object (object stream :type t :identity t) - (princ "descriptor " stream) - (princ (slot-value object 'file-descriptor) stream))) + (format stream "~@[~A, ~]~@[peer: ~A, ~]fd: ~A" + (socket-namestring object) + (socket-peerstring object) + (slot-value object 'file-descriptor)))) + +(defgeneric socket-namestring (socket)) + +(defmethod socket-namestring (socket) + nil) + +(defgeneric socket-peerstring (socket)) +(defmethod socket-peerstring (socket) + nil) (defmethod shared-initialize :after ((socket socket) slot-names &key protocol type @@ -95,7 +107,9 @@ values")) sockaddr (size-of-sockaddr socket)))) (cond - ((and (= fd -1) (= sockint::EAGAIN (sb-unix::get-errno))) + ((and (= fd -1) + (member (sb-unix::get-errno) + (list sockint::EAGAIN sockint::EINTR))) nil) ((= fd -1) (socket-error "accept")) (t (apply #'values @@ -153,25 +167,27 @@ values")) (defgeneric socket-receive (socket buffer length &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 -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")) + oob peek waitall dontwait 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 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.")) (defmethod socket-receive ((socket socket) buffer length &key - oob peek waitall + oob peek waitall dontwait (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) + (if dontwait sockint::MSG-DONTWAIT 0) #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE (if (eql (socket-type socket) :datagram) sockint::msg-TRUNC 0)))) @@ -199,7 +215,10 @@ small")) sockaddr (sb-alien:addr sa-len)))) (cond - ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil) + ((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) @@ -211,6 +230,76 @@ small")) (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) + #-darwin (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 defines the maximum length that the queue of pending connections may @@ -231,12 +320,14 @@ grow to before new connection attempts are refused. See also listen(2)")) (open-stream-p (slot-value socket 'stream)) (/= -1 (socket-file-descriptor socket)))) -(defgeneric socket-close (socket) - (:documentation "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")) +(defgeneric socket-close (socket &key abort) + (:documentation + "Close SOCKET, unless it was already closed. + +If SOCKET-MAKE-STREAM has been called, calls CLOSE using ABORT on that stream. +Otherwise closes the socket file descriptor using close(2).")) -(defmethod socket-close ((socket socket)) +(defmethod socket-close ((socket socket) &key abort) ;; 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 @@ -249,42 +340,82 @@ calls CLOSE on that stream instead")) ;; 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 + (flet ((drop-it (&optional streamp) (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) + (if streamp + (slot-makunbound socket 'stream) + (sb-ext:cancel-finalization socket)) + t)) + (cond ((eql fd -1) + ;; already closed + nil) + ((slot-boundp socket 'stream) + (close (slot-value socket 'stream) :abort abort) + ;; Don't do this if there was an error from CLOSE -- the stream is + ;; still live. + (drop-it t)) + (t + (handler-case + (when (minusp (sockint::close fd)) + (socket-error "close")) + (bad-file-descriptor-error () + (drop-it)) + (:no-error (r) + (declare (ignore r)) + (drop-it)))))))) + +(defgeneric socket-make-stream (socket &key input output + element-type external-format + buffering + timeout) (:documentation "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.")) - -(defmethod socket-make-stream ((socket socket) &rest args) +SOCKET \(which must be connected\). Specify whether the stream is for +INPUT, OUTPUT, or both \(it is an error to specify neither\). ELEMENT-TYPE +and EXTERNAL-FORMAT are as per OPEN. TIMEOUT specifies a read timeout +for the stream.")) + +(defmethod socket-make-stream ((socket socket) + &key input output + (element-type 'character) + (buffering :full) + (external-format :default) + timeout + auto-close + (serve-events t)) + "Default method for SOCKET objects. + +An ELEMENT-TYPE of :DEFAULT will construct a bivalent stream, capable of both +binary and character IO. Acceptable values for BUFFERING are :FULL, :LINE +and :NONE. Streams will have no TIMEOUT by default. If AUTO-CLOSE is true, the +underlying OS socket is automatically closed after the stream and the socket +have been garbage collected. If SERVE-EVENTS is true, blocking IO on the +socket will dispatch to the recursive event loop -- the default is currently +true, but this liable to change. + +The stream for SOCKET will be cached, and a second invocation of this method +will return the same stream. This may lead to oddities if this function is +invoked with inconsistent arguments \(e.g., one might request an input stream +and get an output stream in response\)." (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) - :name "a constant string" - :dual-channel-p t - args)) - (setf (slot-value socket 'stream) stream) - (sb-ext:cancel-finalization socket)) + (setf stream (sb-sys:make-fd-stream + (socket-file-descriptor socket) + :name (format nil "socket~@[ ~A~]~@[, peer: ~A~]" + (socket-namestring socket) + (socket-peerstring socket)) + :dual-channel-p t + :input input + :output output + :element-type element-type + :buffering buffering + :external-format external-format + :timeout timeout + :auto-close auto-close + :serve-events serve-events)) + (setf (slot-value socket 'stream) stream)) + (sb-ext:cancel-finalization socket) stream))