Changeset 3728

Timestamp:

08/07/08 22:06:50 (4 months ago)

Author:

hans

Message:

revert out usocket update again as it breaks buildbot tests on sbcl

Files:

• trunk/thirdparty/usocket/Makefile (modified) (1 diff)
• trunk/thirdparty/usocket/README (modified) (2 diffs)
• trunk/thirdparty/usocket/TODO (modified) (1 diff)
• trunk/thirdparty/usocket/backend/allegro.lisp (modified) (4 diffs)
• trunk/thirdparty/usocket/backend/armedbear.lisp (modified) (9 diffs)
• trunk/thirdparty/usocket/backend/clisp.lisp (modified) (5 diffs)
• trunk/thirdparty/usocket/backend/cmucl.lisp (modified) (6 diffs)
• trunk/thirdparty/usocket/backend/lispworks.lisp (modified) (12 diffs)
• trunk/thirdparty/usocket/backend/openmcl.lisp (modified) (6 diffs)
• trunk/thirdparty/usocket/backend/sbcl.lisp (modified) (11 diffs)
• trunk/thirdparty/usocket/backend/scl.lisp (modified) (6 diffs)
• trunk/thirdparty/usocket/condition.lisp (modified) (3 diffs)
• trunk/thirdparty/usocket/package.lisp (modified) (5 diffs)
• trunk/thirdparty/usocket/test/package.lisp (modified) (1 diff)
• trunk/thirdparty/usocket/test/test-usocket.lisp (modified) (1 diff)
• trunk/thirdparty/usocket/test/usocket-test.asd (modified) (1 diff)
• trunk/thirdparty/usocket/usocket.asd (modified) (1 diff)
• trunk/thirdparty/usocket/usocket.lisp (modified) (13 diffs)

trunk/thirdparty/usocket/Makefile

@@ -1 +1 @@
-# $Id: Makefile 80 2006-02-12 10:09:49Z ehuelsmann $
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-clean:

trunk/thirdparty/usocket/README

@@ -1 +1 @@
-                                                                -*- text -*-
-
-249 2007-05-20 14:16:12Z ehuelsmann
+334 2008-04-23 21:24:15Z hhubner
-
-Content
@@ -96 +96 @@
-
-
-
-
-Errors:
- - address-in-use-error

trunk/thirdparty/usocket/TODO

@@ -2 +2 @@
-- Implement wait-for-input-internal for
-    * SBCL Win32
+    * LispWorks Win32
-
-- Implement errors for (the alien interface code of)

trunk/thirdparty/usocket/backend/allegro.lisp

@@ -1 @@
-405 2008-07-30 19:26:46Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -50 +50 @@
-    :binary))
-
-
-
-
-
-
-
-
+
+
+
+
-  (let ((socket))
-    (setf socket
-          (with-mapped-conditions (socket)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-    (make-stream-socket :socket socket :stream socket)))
-
@@ -81 +67 @@
-(defmethod socket-close ((usocket usocket))
-  "Close socket."
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (close (socket usocket))))
@@ -147 +131 @@
-                               (host-to-hostname name))))))
-
-
-
-
-
-
-
-
-
-
-
-
+
-  (with-mapped-conditions ()
-    (let ((active-internal-sockets
-           (if timeout
-wait-list-%wait wait-list
+mapcar #'socket sockets
-                                            :timeout timeout)
-wait-list-%wait wait-list
+mapcar #'socket sockets
-      ;; this is quadratic, but hey, the active-internal-sockets
-      ;; list is very short and it's only quadratic in the length of that one.
-      ;; When I have more time I could recode it to something of linear
-      ;; complexity.
-
-
-
-
-
+
+
+
+

trunk/thirdparty/usocket/backend/armedbear.lisp

@@ -1 @@
-409 2008-07-31 05:50:06Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -89 +89 @@
-    (java:jclass-name (jop-class instance)))))
-
-(declaim (inline jop-deref))
-(defun jop-deref (instance)
-  (if (java-object-proxy-p instance)
@@ -187 +186 @@
-    (error (error 'unknown-error :socket socket :real-error condition))))
-
-
-
-
-
-
-
-
-
+
+
+
+
-  (let ((usock))
-    (with-mapped-conditions (usock)
-      (let* ((sock-addr (jdi:jcoerce
-                         (jdi:do-jnew-call "java.net.InetSocketAddress"
-
-
+                
+                
-                         "java.net.SocketAddress"))
-             (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
-
+                   
-             (sock (jdi:do-jmethod-call jchan "socket")))
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
-
-(defun socket-listen (host port
@@ -261 +249 @@
-
-(defmethod socket-close ((usocket usocket))
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (jdi:do-jmethod (socket usocket) "close")))
@@ -270 +256 @@
-;; its buffers *and* closes the socket.
-(defmethod socket-close ((usocket stream-usocket))
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (close (socket-stream usocket))))
-
-(defmethod get-local-address ((usocket usocket))
-
-
-
-
+
-
-(defmethod get-peer-address ((usocket stream-usocket))
-
-
-
-
+
-
-(defmethod get-local-port ((usocket usocket))
-
-
+
-
-(defmethod get-peer-port ((usocket stream-usocket))
-
-
+
-
-(defmethod get-local-name ((usocket usocket))
@@ -377 +353 @@
-    "java.nio.channels.DatagramChannel")))
-
-
-
-
+
+
-         (selector (jdi:do-jstatic "java.nio.channels.Selector" "open"))
-         (channels (mapcar #'socket sockets)))
-    (unwind-protect
-        (with-mapped-conditions ()
-
+
+
-            (dolist (channel channels)
-              (let ((chan (jdi:jop-deref channel)))
@@ -390 +366 @@
-                                          "configureBlocking"
-                                          "boolean")
-(java:make-immediate-object nil :boolean)
+jfalse
-                (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "register"
@@ -404 +380 @@
-                (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
-                       (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
-(%wait (wait-list-%wait wait-list))
+ready-sockets
-                  (loop while (java:jcall
-                               (java:jmethod "java.util.Iterator" "hasNext")
@@ -413 +389 @@
-                                  (chan (jdi:jop-deref
-                                         (jdi:do-jmethod key "channel"))))
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-      (java:jcall (java:jmethod "java.nio.channels.Selector" "close")
-                  (jdi:jop-deref selector))
-      ;; make all sockets blocking again.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+

trunk/thirdparty/usocket/backend/clisp.lisp

@@ -1 @@
-405 2008-07-30 19:26:46Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -56 +56 @@
-               (signal usock-err :socket socket)))))))
-
-
-
-
+
-  (declare (ignore nodelay))
-
-
-
-
-
-
-
+
+
-  (let ((socket)
-        (hostname (host-to-hostname host)))
-    (with-mapped-conditions (socket)
-
-
-
-
-
-
-
-
-
+
+
+
+
-    (make-stream-socket :socket socket
-                        :stream socket))) ;; the socket is a stream too
@@ -112 +100 @@
-(defmethod socket-close ((usocket usocket))
-  "Close socket."
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (close (socket usocket))))
-
-(defmethod socket-close ((usocket stream-server-usocket))
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (socket:socket-server-close (socket usocket)))
-
@@ -147 +131 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-  (with-mapped-conditions ()
-    (multiple-value-bind
-        (secs musecs)
-        (split-timeout (or timeout 1))
-
-
-
+
+
+
+
+
-             (status-list (if timeout
-                              (socket:socket-status request-list secs musecs)
-
-
-
-
-
-
-
-
+
+
+
+
+
-
-
@@ -247 +220 @@
-
-  (defmethod socket-close ((usocket datagram-usocket))
-    (when (wait-list usocket)
-       (remove-waiter (wait-list usocket) usocket))
-    (rawsock:sock-close (socket usocket)))
-  

trunk/thirdparty/usocket/backend/cmucl.lisp

@@ -1 @@
-405 2008-07-30 19:26:46Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -51 +51 @@
-                                               :condition condition))))
-
-
-
-
+
-  (declare (ignore nodelay))
-
-
-
-
-
-
-
+
+
-  (let* ((socket))
-    (setf socket
@@ -108 +101 @@
-(defmethod socket-close ((usocket stream-usocket))
-  "Close socket."
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (close (socket-stream usocket))))
@@ -115 +106 @@
-(defmethod socket-close ((usocket usocket))
-  "Close socket."
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (ext:close-socket (socket usocket))))
@@ -177 +166 @@
-  (unix:unix-gethostname))
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-  (with-mapped-conditions ()
-    (alien:with-alien ((rfds (alien:struct unix:fd-set)))
-       (unix:fd-zero rfds)
-(wait-list-%wait wait-list)
-socket
+sockets
+(socket socket)
-       (multiple-value-bind
-           (secs musecs)
@@ -198 +184 @@
-         (multiple-value-bind
-             (count err)
-
-(wait-list-%wait wait-list)
+ sockets
+:key #'socket
-                                    (alien:addr rfds) nil nil
-                                    (when timeout secs) musecs)
-           (if (<= 0 count)
-               ;; process the result...
-dolist (x (wait-list-waiters wait-list)
-(when (unix:fd-isset (socket x) rfds
-(setf (state x) :READ))
+remove-if #'(lambda (x
+             (not (unix:fd-isset (socket x) rfds))
+       sockets
-             (progn
-               ;;###FIXME generate an error, except for EINTR

trunk/thirdparty/usocket/backend/lispworks.lisp

@@ -1 @@
-406 2008-07-30 20:56:49Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -74 +74 @@
-                    (raise-usock-err errno socket condition)))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
-  (let ((hostname (host-to-hostname host))
-        (stream))
@@ -93 +83 @@
-          (with-mapped-conditions ()
-             (comm:open-tcp-stream hostname port
-
-
-
-
-
-
-
-
+
-    (if stream
-        (make-stream-socket :socket (comm:socket-stream-socket stream)
@@ -111 +94 @@
-                           (backlog 5)
-                           (element-type 'base-char))
-  #+lispworks4.1
-  (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
-  #+lispworks4.1
-  (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
-
-  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
-         (comm::*use_so_reuseaddr* reuseaddress)
@@ -143 +121 @@
-(defmethod socket-close ((usocket stream-usocket))
-  "Close socket."
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (close (socket-stream usocket)))
-
-(defmethod socket-close ((usocket usocket))
-  (when (wait-list usocket)
-     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-     (comm::close-socket (socket usocket))))
@@ -187 +161 @@
-(defun usocket-listen (usocket)
-  (if (stream-usocket-p usocket)
--stream
+
-        usocket)
-    (when (comm::socket-listen (socket usocket))
@@ -199 +173 @@
-
-#-win32
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
@@ -273 +232 @@
-  (defconstant fionread 1074030207)
-
-
-  ;; Note:
-  ;;
-  ;;  If special finalization has to occur for a given
-  ;;  system resource (handle), an associated object should
-  ;;  be created.  A special cleanup action should be added
-  ;;  to the system and a special cleanup action should
-  ;;  be flagged on all objects created for resources like it
-  ;;
-  ;;  We have 2 functions to do so:
-  ;;   * hcl:add-special-free-action (function-symbol)
-  ;;   * hcl:flag-special-free-action (object)
-  ;;
-  ;;  Note that the special free action will be called on all
-  ;;  objects which have been flagged for special free, so be
-  ;;  sure to check for the right argument type!
-  
-  (fli:define-foreign-type ws-socket () '(:unsigned :int))
-  (fli:define-foreign-type win32-handle () '(:unsigned :int))
@@ -334 +276 @@
-  ;; Now that we have access to the system calls, this is the plan:
-
-wait-list with associated sockets to wait for
+list of sockets to listen to
-  ;; 2. Add all those sockets to an event handle
-  ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that)
@@ -354 +296 @@
-          0))))
-
+  (defun add-socket-to-event (socket event-object)
+    (let ((events (etypecase socket
+                    (stream-server-usocket (logior fd-connect fd-accept fd-close))
+                    (stream-usocket (logior fd-connect fd-read fd-oob fd-close)))))
+      (maybe-wsa-error
+       (wsa-event-select (os-socket-handle socket) event-object events)
+       socket)))
+
-  (defun socket-ready-p (socket)
-     (if (typep socket 'stream-usocket)
@@ -362 +312 @@
-    (notany #'socket-ready-p sockets))
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-  (defun map-network-events (func network-events)
-    (let ((event-map (fli:foreign-slot-value network-events 'network-events))
@@ -374 +330 @@
-      (unless (zerop event-map)
-          (dotimes (i fd-max-events)
- ;;### could be faster with ash and logand?
+
-              (funcall func (fli:foreign-aref error-array i)))))))
-
-and-state-
+
-     (dolist (socket sockets)
-
-
-
-
-
-
-
-
+
+
+
+
+
+
-                 (map-network-events #'(lambda (err-code)
-                                          (if (zerop err-code)
-
-
+
-                                             (raise-usock-err err-code socket)))
-                                     network-events)
-                 (maybe-wsa-error rv socket))))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-  
-  );; end of WIN32-block

trunk/thirdparty/usocket/backend/openmcl.lisp

@@ -1 @@
-414 2008-08-07 18:50:26Z ehuelsmann
-+ssh://common-lisp.net/project/usocket/svn/usocket/trunk
+335 2008-04-23 21:29:50Z hhubner
+://common-lisp.net/project/usocket/svn/usocket/branches/hans
-
-;;;; See LICENSE for licensing information.
@@ -33 +33 @@
-  (ccl::rletZ ((tv :timeval))
-    (ccl::ticks-to-timeval ticks-to-wait tv)
-    ;;### The trickery below can be moved to the wait-list now...
-    (ccl::%stack-block ((infds ccl::*fd-set-size*))
-      (ccl::fd-zero infds)
-      (let ((max-fd -1))
-        (dolist (sock sockets)
-(socket sock)
+sock
-            (setf max-fd (max max-fd fd))
-            (ccl::fd-set fd infds)))
@@ -45 +44 @@
-                              (if ticks-to-wait tv (ccl::%null-ptr)))))
-          (when (> res 0)
-
-
-
-
-
+
+
+
+
-
-(defun raise-error-from-id (condition-id socket real-condition)
@@ -75 +73 @@
-    :binary))
-
-
-
+
-  (with-mapped-conditions ()
-    (let ((mcl-sock
-           (openmcl-socket:make-socket :remote-host (host-to-hostname host)
-                                       :remote-port port
-                                       :local-host (when local-host (host-to-hostname local-host))
-                                       :local-port local-port
-                                       :format (to-format element-type)
-                                       :deadline deadline
@@ -118 +113 @@
-;; by the same object.
-(defmethod socket-