0.8.13.78: Birds of Feather

[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 384ca10..4a5249f 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)

@@ -173,30 +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)))

+      (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)))
       (unless buffer
        (setf buffer (make-array length :element-type element-type)))

-      (let ((copy-buffer (sb-alien:make-alien (array sb-alien:unsigned 1) length)))
+      ;; 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)))))
+                                       (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
                (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) (sb-alien:deref copy-buffer i)))
+                          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))))))
 
                     (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
 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

@@ -275,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)
                        (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

@@ -323,6 +338,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)))