Changeset 3727

Timestamp:

08/07/08 21:30:29 (4 months ago)

Author:

hans

Message:

retry with fixed usocket-0.4.x

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) (14 diffs)

trunk/thirdparty/usocket/Makefile

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

trunk/thirdparty/usocket/README

@@ -1 +1 @@
-                                                                -*- text -*-
-
-334 2008-04-23 21:24:15Z hhubner
+249 2007-05-20 14:16:12Z ehuelsmann
-
-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 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+405 2008-07-30 19:26:46Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; See LICENSE for licensing information.
@@ -50 +50 @@
-    :binary))
-
-
-
-
-
+
+
+
+
+
+
+
-  (let ((socket))
-    (setf socket
-          (with-mapped-conditions (socket)
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-    (make-stream-socket :socket socket :stream socket)))
-
@@ -67 +81 @@
-(defmethod socket-close ((usocket usocket))
-  "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
-  (with-mapped-conditions (usocket)
-    (close (socket usocket))))
@@ -131 +147 @@
-                               (host-to-hostname name))))))
-
-
+
+
+
+
+
+
+
+
+
+
+
-  (with-mapped-conditions ()
-    (let ((active-internal-sockets
-           (if timeout
-mapcar #'socket sockets
+wait-list-%wait wait-list
-                                            :timeout timeout)
-mapcar #'socket sockets
+wait-list-%wait wait-list
-      ;; 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 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+409 2008-07-31 05:50:06Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; 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)
@@ -186 +187 @@
-    (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
@@ -249 +261 @@
-
-(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")))
@@ -256 +270 @@
-;; 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))
@@ -353 +377 @@
-    "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)))
@@ -366 +390 @@
-                                          "configureBlocking"
-                                          "boolean")
-jfalse
+(java:make-immediate-object nil :boolean)
-                (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "register"
@@ -380 +404 @@
-                (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
-                       (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
-ready-sockets
+(%wait (wait-list-%wait wait-list))
-                  (loop while (java:jcall
-                               (java:jmethod "java.util.Iterator" "hasNext")
@@ -389 +413 @@
-                                  (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 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+405 2008-07-30 19:26:46Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; 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
@@ -100 +112 @@
-(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)))
-
@@ -131 +147 @@
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-  (with-mapped-conditions ()
-    (multiple-value-bind
-        (secs musecs)
-        (split-timeout (or timeout 1))
-
-
-
-
-
+
+
+
-             (status-list (if timeout
-                              (socket:socket-status request-list secs musecs)
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
@@ -220 +247 @@
-
-  (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 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+405 2008-07-30 19:26:46Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; See LICENSE for licensing information.
@@ -51 +51 @@
-                                               :condition condition))))
-
-
+
+
+
-  (declare (ignore nodelay))
-
-
+
+
+
+
+
+
+
-  (let* ((socket))
-    (setf socket
@@ -101 +108 @@
-(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))))
@@ -106 +115 @@
-(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))))
@@ -166 +177 @@
-  (unix:unix-gethostname))
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-  (with-mapped-conditions ()
-    (alien:with-alien ((rfds (alien:struct unix:fd-set)))
-       (unix:fd-zero rfds)
-sockets
-(socket socket)
+(wait-list-%wait wait-list)
+socket
-       (multiple-value-bind
-           (secs musecs)
@@ -184 +198 @@
-         (multiple-value-bind
-             (count err)
- sockets
-:key #'socket
+
+(wait-list-%wait wait-list)
-                                    (alien:addr rfds) nil nil
-                                    (when timeout secs) musecs)
-           (if (<= 0 count)
-               ;; process the result...
-remove-if #'(lambda (x
-             (not (unix:fd-isset (socket x) rfds))
-       sockets
+dolist (x (wait-list-waiters wait-list)
+(when (unix:fd-isset (socket x) rfds
+(setf (state x) :READ))
-             (progn
-               ;;###FIXME generate an error, except for EINTR

trunk/thirdparty/usocket/backend/lispworks.lisp

@@ -1 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+406 2008-07-30 20:56:49Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; See LICENSE for licensing information.
@@ -74 +74 @@
-                    (raise-usock-err errno socket condition)))))
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-  (let ((hostname (host-to-hostname host))
-        (stream))
@@ -83 +93 @@
-          (with-mapped-conditions ()
-             (comm:open-tcp-stream hostname port
-
+
+
+
+
+
+
+
+
-    (if stream
-        (make-stream-socket :socket (comm:socket-stream-socket stream)
@@ -94 +111 @@
-                           (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)
@@ -121 +143 @@
-(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))))
@@ -161 +187 @@
-(defun usocket-listen (usocket)
-  (if (stream-usocket-p usocket)
-
+-stream
-        usocket)
-    (when (comm::socket-listen (socket usocket))
@@ -173 +199 @@
-
-#-win32
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
@@ -232 +273 @@
-  (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))
@@ -276 +334 @@
-  ;; Now that we have access to the system calls, this is the plan:
-
-list of sockets to listen to
+wait-list with associated sockets to wait for
-  ;; 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)
@@ -296 +354 @@
-          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)
@@ -312 +362 @@
-    (notany #'socket-ready-p sockets))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-  (defun map-network-events (func network-events)
-    (let ((event-map (fli:foreign-slot-value network-events 'network-events))
@@ -330 +374 @@
-      (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 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+414 2008-08-07 18:50:26Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/trunk
-
-;;;; 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)
-sock
+(socket sock)
-            (setf max-fd (max max-fd fd))
-            (ccl::fd-set fd infds)))
@@ -44 +45 @@
-                              (if ticks-to-wait tv (ccl::%null-ptr)))))
-          (when (> res 0)
-
-
-
-
+
+
+
+
+
-
-(defun raise-error-from-id (condition-id socket real-condition)
@@ -73 +75 @@
-    :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
@@ -113 +118 @@
-;; by the same object.
-(defmethod socket-close ((usocket usocket))