X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Fsockets.lisp;h=4a5249f55c53d7ec17ac55d52ab9dd4872d9f28d;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=ed03482dc4f5342c2b966b2079a2d07748233cde;hpb=e449254c6a6a768b42a878274a90db9bb7d2ba2b;p=sbcl.git

diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index ed03482..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
 
-#|| <h2>SOCKETs</h2>
-
-|#
-
 (eval-when (:load-toplevel :compile-toplevel :execute)
 (defclass socket ()
   ((file-descriptor :initarg :descriptor
 		    :reader socket-file-descriptor)
-   (family :initform (error "No socket family") :reader socket-family)
-   (protocol :initarg :protocol :reader socket-protocol)
-   (type  :initarg :type :reader socket-type)
-   (stream))))
-  
+   (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)
@@ -49,6 +55,15 @@
   (:documentation "Return a Socket Address object suitable for use with SOCKET.
 When SOCKADDR is passed, it is used instead of a new object."))
 
+(defgeneric free-sockaddr-for (socket sockaddr)
+  (:documentation "Deallocate a Socket Address object that was
+created for SOCKET."))
+
+(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))))
+
 ;; we deliberately redesign the "bind" interface: instead of passing a
 ;; sockaddr_something as second arg, we pass the elements of one as
 ;; multiple arguments.
@@ -61,11 +76,10 @@ See also bind(2)"))
 
 (defmethod socket-bind ((socket socket)
                         &rest address)
-  (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)))
+  (with-sockaddr-for (socket sockaddr address)
+    (if (= (sockint::bind (socket-file-descriptor socket)
+			  sockaddr
+			  (size-of-sockaddr socket))
            -1)
         (socket-error "bind"))))
 
@@ -76,44 +90,43 @@ newly-created connected socket and the peer address as multiple
 values"))
   
 (defmethod socket-accept ((socket socket))
-  (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)))))
-
+  (with-sockaddr-for (socket sockaddr)
+    (let ((fd (sockint::accept (socket-file-descriptor 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))))))))
+    
 (defgeneric socket-connect (socket &rest address)
   (:documentation "Perform the connect(2) call to connect SOCKET to a
   remote PEER.  No useful return value."))
 
 (defmethod socket-connect ((socket socket) &rest peer)
-  (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)))
+  (with-sockaddr-for (socket sockaddr peer)
+    (if (= (sockint::connect (socket-file-descriptor socket)
+			     sockaddr
+			     (size-of-sockaddr socket))
 	   -1)
-	(socket-error "connect") )))
+	(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))
-  (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)))
+  (with-sockaddr-for (socket sockaddr)
+    (when (= (sockint::getpeername (socket-file-descriptor socket)
+				    sockaddr
+				    (size-of-sockaddr socket))
 	     -1)
       (socket-error "getpeername"))
     (bits-of-sockaddr socket sockaddr)))
@@ -123,11 +136,10 @@ values"))
   that the socket is bound to, as multiple values."))
 
 (defmethod socket-name ((socket socket))
-  (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)))
+  (with-sockaddr-for (socket sockaddr)
+    (when (= (sockint::getsockname (socket-file-descriptor socket)
+				   sockaddr
+				   (size-of-sockaddr socket))
 	     -1)
       (socket-error "getsockname"))
     (bits-of-sockaddr socket sockaddr)))
@@ -152,36 +164,52 @@ 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))
-  (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))))))))
-
-
+			   &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))))
+      (unless (or buffer length)
+	(error "Must supply at least one of BUFFER or LENGTH"))
+      (unless length
+	(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."))
+      (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 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))))))
 
 (defgeneric socket-listen (socket backlog)
   (:documentation "Mark SOCKET as willing to accept incoming connections.  BACKLOG
@@ -207,19 +235,27 @@ stream instead"))
   ;; 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))))
-
+  ;; 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)
+	   (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)) 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
@@ -230,7 +266,9 @@ SB-SYS:MAKE-FD-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))
+			  (socket-file-descriptor socket)
+			  :name "a constant string"
+			  args))
       (setf (slot-value socket 'stream) stream)
       (sb-ext:cancel-finalization socket))
     stream))
@@ -251,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
@@ -260,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)
@@ -299,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)))