0.8.3.11

[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 6c68594..03b6344 100644 (file)
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -53,7 +53,7 @@ When SOCKADDR is passed, it is used instead of a new object."))
   (:documentation "Deallocate a Socket Address object that was
 created for SOCKET."))
 
   (: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))))
   `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args)))
      (unwind-protect (progn ,@body)
        (free-sockaddr-for ,socket ,sockaddr))))

@@ -84,19 +84,21 @@ newly-created connected socket and the peer address as multiple
 values"))
   
 (defmethod socket-accept ((socket socket))
 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))))
     (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

@@ -115,7 +117,7 @@ values"))
   family this may return multiple values"))
   
 (defmethod socket-peername ((socket socket))
   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))
     (when (= (sockint::getpeername (socket-file-descriptor socket)
                                    sockaddr
                                    (size-of-sockaddr socket))

@@ -128,7 +130,7 @@ values"))
   that the socket is bound to, as multiple values."))
 
 (defmethod socket-name ((socket socket))
   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))
     (when (= (sockint::getsockname (socket-file-descriptor socket)
                                   sockaddr
                                   (size-of-sockaddr socket))

@@ -159,7 +161,7 @@ small"))
                           &key
                           oob peek waitall
                           (element-type 'character))
                           &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)
     (let ((flags
           (logior (if oob sockint::MSG-OOB 0)
                   (if peek sockint::MSG-PEEK 0)

@@ -171,22 +173,36 @@ 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))))))
 
 

@@ -278,19 +294,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)