win32: provide error messages when loading foreign libraries.

[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 17f30b7..ed863ae 100644 (file)
--- a/contrib/sb-bsd-sockets/sockets.lisp
+++ b/contrib/sb-bsd-sockets/sockets.lisp
@@ -5,6 +5,13 @@
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
 
+
+;;; Winsock is different w.r.t errno
+(defun socket-errno ()
+  "Get socket error code, usually from errno, but see #+win32."
+  #+win32 (sockint::wsa-get-last-error)
+  #-win32 (sb-unix::get-errno))
+
 (defclass socket ()
   ((file-descriptor :initarg :descriptor
                     :reader socket-file-descriptor)
@@ -19,6 +26,8 @@ protocol. Other values are used as-is.")
    (type  :initarg :type
           :reader socket-type
           :documentation "Type of the socket: :STREAM or :DATAGRAM.")
+   #+win32
+   (non-blocking-p :type (member t nil) :initform nil)
    (stream))
   (:documentation "Common base class of all sockets, not meant to be
 directly instantiated.")))
@@ -109,7 +118,7 @@ values"))
                                (size-of-sockaddr socket))))
       (cond
         ((and (= fd -1)
-              (member (sb-unix::get-errno)
+              (member (socket-errno)
                       (list sockint::EAGAIN sockint::EINTR)))
          nil)
         ((= fd -1) (socket-error "accept"))
@@ -218,11 +227,11 @@ buffer was too small."))
                                         (sb-alien:addr sa-len))))
                 (cond
                   ((and (= len -1)
-                        (member (sb-unix::get-errno)
+                        (member (socket-errno)
                                 (list sockint::EAGAIN sockint::EINTR)))
                    nil)
                   ((= len -1) (socket-error "recvfrom"))
-                  (t (loop for i from 0 below len
+                  (t (loop for i from 0 below (min len length)
                            do (setf (elt buffer i)
                                     (cond
                                       ((or (eql element-type 'character) (eql element-type 'base-char))
@@ -295,7 +304,7 @@ send(2) will be called instead. Returns the number of octets written."))
                                    flags)))))
     (cond
       ((and (= len -1)
-            (member (sb-unix::get-errno)
+            (member (socket-errno)
                     (list sockint::EAGAIN sockint::EINTR)))
        nil)
       ((= len -1)
@@ -367,6 +376,24 @@ Otherwise closes the socket file descriptor using close(2)."))
                 (declare (ignore r))
                 (drop-it))))))))
 
+(defgeneric socket-shutdown (socket &key direction)
+  (:documentation
+   "Indicate that no communication in DIRECTION will be performed on SOCKET.
+
+DIRECTION has to be one of :INPUT, :OUTPUT or :IO.
+
+After a shutdown, no input and/or output of the indicated DIRECTION
+can be performed on SOCKET."))
+
+(defmethod socket-shutdown ((socket socket) &key direction)
+  (let* ((fd  (socket-file-descriptor socket))
+         (how (ecase direction
+                (:input sockint::SHUT_RD)
+                (:output sockint::SHUT_WR)
+                (:io sockint::SHUT_RDWR))))
+    (when (minusp (sockint::shutdown fd how))
+      (socket-error "shutdown"))))
+
 (defgeneric socket-make-stream (socket &key input output
                                        element-type external-format
                                        buffering
@@ -426,7 +453,7 @@ request an input stream and get an output stream in response\)."
                     :external-format external-format
                     :timeout timeout
                     :auto-close auto-close
-                    :serve-events serve-events))
+                    :serve-events (and serve-events #+win32 nil)))
       (setf (slot-value socket 'stream) stream))
     (sb-ext:cancel-finalization socket)
     stream))
@@ -447,7 +474,9 @@ request an input stream and get an output stream in response\)."
                        (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
+                       #+win32 (sb-win32:format-system-message num)
+                       #-win32 (sb-int:strerror num)))))
   (:documentation "Common base class of socket related conditions."))
 
 ;;; watch out for slightly hacky symbol punning: we use both the value
@@ -499,7 +528,7 @@ request an input stream and get an output stream in response\)."
   ;; 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))
+  (let* ((errno (socket-errno))
          (condition (condition-for-errno errno)))
     (error condition :errno errno  :syscall where)))