0.9.2.38: thread cleanup, paranoid

[sbcl.git] / contrib / sb-bsd-sockets / sockets.lisp

diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp
index caaccc8..bb4e7c1 100644 (file)
--- 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
 
 ;;;; 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)
 (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)
 (defmethod print-object ((object socket) stream)
   (print-unreadable-object (object stream :type t :identity t)
                            (princ "descriptor " stream)

@@ -88,15 +94,17 @@ values"))
     (let ((fd (sockint::accept (socket-file-descriptor socket)
                               sockaddr
                               (size-of-sockaddr socket))))
     (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
     
 (defgeneric socket-connect (socket &rest address)
   (:documentation "Perform the connect(2) call to connect SOCKET to a

@@ -171,26 +179,38 @@ small"))
        (error "Must supply at least one of BUFFER or LENGTH"))
       (unless length
        (setf length (length buffer)))
        (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
        (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
              (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))))))
 
          (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
 (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

@@ -201,10 +221,20 @@ grow to before new connection attempts are refused.  See also listen(2)"))
     (if (= r -1)
         (socket-error "listen"))))
 
     (if (= r -1)
         (socket-error "listen"))))
 

+(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)))
+
+(defmethod socket-open-p ((socket socket))
+  (if (slot-boundp socket 'stream)
+      (open-stream-p (slot-value socket 'stream))
+      (/= -1 (socket-file-descriptor socket))))
+

 (defgeneric socket-close (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"))
+  (: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"))

 
 (defmethod socket-close ((socket socket))
   ;; the close(2) manual page has all kinds of warning about not
 
 (defmethod socket-close ((socket socket))
   ;; the close(2) manual page has all kinds of warning about not

@@ -224,30 +254,34 @@ stream instead"))
     (cond ((eql fd -1) ; already closed
           nil)
          ((slot-boundp socket 'stream)
     (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))
+          (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)
          (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))))))
+            (: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
+(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

 SB-SYS:MAKE-FD-STREAM."))
 
 SB-SYS:MAKE-FD-STREAM."))
 

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

   (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"
   (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))
                          args))
       (setf (slot-value socket 'stream) stream)
       (sb-ext:cancel-finalization socket))

@@ -269,7 +303,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)
                        (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
 
 ;;; watch out for slightly hacky symbol punning: we use both the value
 ;;; and the symbol-name of sockint::efoo

@@ -278,19 +313,19 @@ SB-SYS:MAKE-FD-STREAM."))
   `(progn
      (define-condition ,name (socket-error)
        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
   `(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
      (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)
 ;;; 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)
 (define-socket-condition sockint::EINTR interrupted-error)
 (define-socket-condition sockint::EINVAL invalid-argument-error)
 (define-socket-condition sockint::ENOBUFS no-buffers-error)

@@ -300,7 +335,7 @@ SB-SYS:MAKE-FD-STREAM."))
 (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)
 (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)

-
+(define-socket-condition sockint::ENOTCONN not-connected-error)

 
 (defun condition-for-errno (err)
   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 
 (defun condition-for-errno (err)
   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))

@@ -317,6 +352,9 @@ SB-SYS:MAKE-FD-STREAM."))
 
 #+sbcl
 (defun socket-error (where)
 
 #+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)))
   (let* ((errno  (sb-unix::get-errno))
          (condition (condition-for-errno errno)))
     (error condition :errno errno  :syscall where)))