Changeset 3725

Timestamp:

08/07/08 14:54:38 (4 months ago)

Author:

hans

Message:

Update to 0.4.x branch from usocket svn to let the buildbot try it out.

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) (10 diffs)
• trunk/thirdparty/usocket/backend/clisp.lisp (modified) (4 diffs)
• trunk/thirdparty/usocket/backend/cmucl.lisp (modified) (6 diffs)
• trunk/thirdparty/usocket/backend/lispworks.lisp (modified) (13 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/branches/0.4.x
-
-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/branches/0.4.x
-
-;;;; See LICENSE for licensing information.
@@ -50 +50 @@
-    :binary))
-
-
-
-
-
+
+
+
+
+
+
+
-  (let ((socket))
-    (setf socket
-          (with-mapped-conditions (socket)
+            (if timeout
+                (mp:with-timeout (timeout nil)
+                  (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)
+                                      :nodelay nodelay))
-             (socket:make-socket :remote-host (host-to-hostname host)
-                                 :remote-port port
-
+
+
+
+
-    (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/branches/0.4.x
-
-;;;; 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)
@@ -200 +205 @@
-                                         "open" sock-addr))
-             (sock (jdi:do-jmethod-call jchan "socket")))
-
+
+
+
+
+
+
+
+
-         (setf usock
-               (make-stream-socket
@@ -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.
-
-
+
-          (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "configureBlocking"
-                                          "boolean")
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

trunk/thirdparty/usocket/backend/clisp.lisp

@@ -1 @@
-335 2008-04-23 21:29:50Z hhubner
-://common-lisp.net/project/usocket/svn/usocket/branches/hans
+412 2008-08-01 22:08:45Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/branches/0.4.x
-
-;;;; 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)
-       (setf socket
+            (if timeout
+                (socket:socket-connect port hostname
+                                       :element-type element-type
+                                       :buffered t
+                                       :timeout timeout)
-             (socket:socket-connect port hostname
-                                    :element-type element-type
-:buffered t
+   :buffered t)
-    (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)
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
-;;
-;; UDP/Datagram sockets!
-;;
-
-#+rawsock
-(progn
-
-  (defun make-sockaddr_in ()
-    (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
-
-  (declaim (inline fill-sockaddr_in))
-  (defun fill-sockaddr_in (sockaddr_in ip port)
-    (port-to-octet-buffer sockaddr_in port)
-    (ip-to-octet-buffer sockaddr_in ip :start 2)
-    sockaddr_in)
-
-  (defun socket-create-datagram (local-port
-                                 &key (local-host *wildcard-host*)
-                                      remote-host
-                                      remote-port)
-    (let ((sock (rawsock:socket :inet :dgram 0))
-          (lsock_addr (fill-sockaddr_in (make-sockaddr_in)
-                                        local-host local-port))
-          (rsock_addr (when remote-host
-                        (fill-sockaddr_in (make-sockaddr_in)
-                                          remote-host (or remote-port
-                                                          local-port)))))
-      (bind sock lsock_addr)
-      (when rsock_addr
-        (connect sock rsock_addr))
-      (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
-
-  (defun socket-receive (socket buffer &key (size (length buffer)))
-    "Returns the buffer, the number of octets copied into the buffer (received)
-and the address of the sender as values."
-    (let* ((sock (socket socket))
-           (sockaddr (when (not (connected-p socket))
-                       (rawsock:make-sockaddr)))
-           (rv (if sockaddr
-                   (rawsock:recvfrom sock buffer sockaddr
-                                     :start 0
-                                     :end size)
-                   (rawsock:recv sock buffer
-                                 :start 0
-                                 :end size))))
-      (values buffer
-              rv
-              (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4)
-                    (port-from-octet-buffer (sockaddr-data sockaddr) 2)))))
-
-  (defun socket-send (socket buffer &key address (size (length buffer)))
-    "Returns the number of octets sent."
-    (let* ((sock (socket socket))
-           (sockaddr (when address
-                       (rawsock:make-sockaddr :INET
-                                              (fill-sockaddr_in
-                                               (make-sockaddr_in)
-                                               (host-byte-order
-                                                (second address))
-                                               (first address)))))
-           (rv (if address
-                   (rawsock:sendto sock buffer sockaddr
-                                   :start 0
-                                   :end size)
-                   (rawsock:send sock buffer
-                                 :start 0
-                                 :end size))))
-      rv))
-
-  (defmethod socket-close ((usocket datagram-usocket))
-    (rawsock:sock-close (socket usocket)))
-  
-  )
-
-#-rawsock
-(progn
-  (warn "This image doesn't contain the RAWSOCK package.
-To enable UDP socket support, please be sure to use the -Kfull parameter
-at startup, or to enable RAWSOCK support during compilation.")
-
-  )

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/branches/0.4.x
-
-;;;; 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/branches/0.4.x
-
-;;;; 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
-
+
+
+
+
+
+
+
+
+
+
+
+
-  (with-mapped-conditions ()
-    ;; unfortunately, it's impossible to share code between
-    ;; non-win32 and win32 platforms...
-    ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
-(mapcar #'mp:notice-fd sockets
-    :key #'os-socket-handle
+  (dolist (x (wait-list-waiters wait-list))
+(mp:notice-fd (os-socket-handle x))
-    (mp:process-wait-with-timeout "Waiting for a socket to become active"
-                                  (truncate timeout)
-                                  #'(lambda (socks)
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
@@ -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))
-
-
-
-
-
-
-
-
-
+
+
+
-                                             "Waiting for socket activity" timeout))
-
-
-
+
+
-
-  (defun map-network-events (func 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)
-
-
+
+
+
+
-           (multiple-value-bind
-                 (rv network-events)
@@ -343 +389 @@
-                 (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
+405 2008-07-30 19:26:46Z ehuelsmann
++ssh://common-lisp.net/project/usocket/svn/usocket/branches/0.4.x
-
-;;;; 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))
-          &