[usocket-cvs] r248 - in usocket/trunk: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun May 20 12:27:16 UTC 2007
Author: ehuelsmann
Date: Sun May 20 08:27:15 2007
New Revision: 248
Modified:
usocket/trunk/backend/allegro.lisp
usocket/trunk/backend/clisp.lisp
usocket/trunk/backend/cmucl.lisp
usocket/trunk/backend/lispworks.lisp
usocket/trunk/backend/openmcl.lisp
usocket/trunk/backend/sbcl.lisp
usocket/trunk/package.lisp
usocket/trunk/usocket.lisp
Log:
Work-in-progress 'wait-for-input'. Many implementations done,
most notably missing:
- LispWorks Win32
- SBCL Win32
- ABCL
- Scieneer (but can probably be copy-pasted from cmucl).
Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp (original)
+++ usocket/trunk/backend/allegro.lisp Sun May 20 08:27:15 2007
@@ -7,6 +7,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sock)
+ ;; for wait-for-input:
+ (require :process)
;; note: the line below requires ACL 6.2+
(require :osi))
@@ -122,3 +124,18 @@
(with-mapped-conditions ()
(list (hbo-to-vector-quad (socket:lookup-hostname
(host-to-hostname name))))))
+
+(defun wait-for-input-internal (sockets &key timeout)
+ (let ((active-internal-sockets
+ (if timeout
+ (mp:wait-for-input-available (mapcar #'socket sockets)
+ :timeout timeout)
+ (mp:wait-for-input-available (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.
+ ;; [Same code is also used in lispworks.lisp, openmcl.lisp]
+ (remove-if #'(lambda (x)
+ (not (member (socket x) active-internal-sockets)))
+ sockets)))
Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp (original)
+++ usocket/trunk/backend/clisp.lisp Sun May 20 08:27:15 2007
@@ -124,3 +124,22 @@
(defmethod get-peer-port ((usocket stream-usocket))
(nth-value 1 (get-peer-name usocket)))
+
+(defmethod wait-for-input-internal (sockets &key timeout)
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (let* ((musecs (truncate (* 1000000 sec-frac) 1))
+ (request-list (mapcar #'(lambda (x)
+ (if (stream-server-usocket-p x)
+ (socket x)
+ (list (socket x) :input)))
+ sockets))
+ (status-list (if timeout
+ (socket:socket-status request-list secs musecs)
+ (socket:socket-status request-list))))
+ (remove nil
+ (mapcar #'(lambda (x y)
+ (when y x))
+ sockets status-list)))))
+
Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp (original)
+++ usocket/trunk/backend/cmucl.lisp Sun May 20 08:27:15 2007
@@ -162,3 +162,26 @@
(defun get-host-name ()
(unix:unix-gethostname))
+
+(defun wait-for-input-internal (sockets &key timeout)
+ (alien:with-alien ((rfds (alien:struct unix:fd-set)))
+ (dolist (socket sockets)
+ (unix:fd-set (socket socket) rfds))
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (multiple-value-bind
+ (count err)
+ (unix:unix-fast-select (1+ (reduce #'max sockets
+ :key #'socket))
+ (alien:addr rfds) nil nil
+ (when timeout secs) musecs)
+ (if (= 0 err)
+ ;; process the result...
+ (unless (= 0 count)
+ (remove-if #'(lambda (x)
+ (not (unix:fd-isset (socket x) rfds)))
+ sockets))
+ (progn
+ ;;###FIXME generate an error, except for EINTR
+ ))))))
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Sun May 20 08:27:15 2007
@@ -16,7 +16,8 @@
(namelen :int))
:lambda-list (&aux (namelen 256) return-string)
:result-type :int
- #+win32 :module #+win32 "ws2_32")
+ #+win32 :module
+ #+win32 "ws2_32")
(defun get-host-name ()
(multiple-value-bind (retcode name)
@@ -134,3 +135,33 @@
(with-mapped-conditions ()
(mapcar #'hbo-to-vector-quad
(comm:get-host-entry name :fields '(:addresses)))))
+
+(defun os-socket-handle (usocket)
+ (if (stream-usocket-p usocket)
+ (comm:socket-stream-socket (socket usocket))
+ (socket usocket)))
+
+(defun usocket-listen (usocket)
+ (if (stream-usocket-p usocket)
+ (when (listen (socket usocket))
+ usocket)
+ (when (comm::socket-listen (socket usocket))
+ usocket)))
+
+#-win32
+(defun wait-for-input-internal (sockets &key timeout)
+ ;; 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)
+ (mp:process-wait-with-timeout "Waiting for a socket to become active"
+ (truncate timeout)
+ #'(lambda (socks)
+ (some #'usocket-listen socks))
+ sockets)
+ (mapcar #'mp:unnotice-fd sockets
+ :key #'os-socket-handle)
+ (loop for r in (mapcar #'usocket-listen sockets)
+ if r
+ collect r))
Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp (original)
+++ usocket/trunk/backend/openmcl.lisp Sun May 20 08:27:15 2007
@@ -5,6 +5,13 @@
(in-package :usocket)
+(eval-when (:compile-toplevel :execute)
+ ;; also present in OpenMCL l1-sockets.lisp
+ #+linuxppc-target
+ (require "LINUX-SYSCALLS")
+ #+darwinppc-target
+ (require "DARWIN-SYSCALLS"))
+
(defun get-host-name ()
(ccl::%stack-block ((resultbuf 256))
(when (zerop (#_gethostname resultbuf 256))
@@ -36,24 +43,20 @@
(errfds ccl::*fd-set-size*))
(ccl::fd-zero infds)
(ccl::fd-zero errfds)
- (dolist (sock sockets)
- (ccl::fd-set (socket-os-fd sock infds))
- (ccl::fd-set (socket-os-fd sock errfds)))
- (let* ((res (ccl::syscall syscalls::select
- (1+ (apply #'max fds))
- infds (ccl::%null-ptr) errfds
- (if ticks-to-wait tv (ccl::%null-ptr)))))
- (when (> res 0)
- (remove-if #'(lambda (x)
- (not (ccl::fd-is-set (socket-os-fd x) infds)))
- sockets))))))
-
-(defun wait-for-input (sockets &optional ticks-to-wait)
- (let ((wait-end (when ticks-to-wait (+ ticks-to-wait (ccl::get-tick-count)))))
- (do ((res (input-available-p sockets ticks-to-wait)
- (input-available-p sockets ticks-to-wait)))
- ((or res (< wait-end (ccl::get-tick-count)))
- res))))
+ (let ((max-fd -1))
+ (dolist (sock sockets)
+ (let ((fd (openmcl-socket:socket-os-fd sock)))
+ (setf max-fd (max max-fd fd))
+ (ccl::fd-set fd infds)
+ (ccl::fd-set fd errfds)))
+ (let* ((res (ccl::syscall syscalls::select (1+ max-fd)
+ infds (ccl::%null-ptr) errfds
+ (if ticks-to-wait tv (ccl::%null-ptr)))))
+ (when (> res 0)
+ (remove-if #'(lambda (x)
+ (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
+ infds)))
+ sockets)))))))
(defun raise-error-from-id (condition-id socket real-condition)
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
@@ -142,3 +145,19 @@
(with-mapped-conditions ()
(list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
(host-to-hostname name))))))
+
+(defun wait-for-input-internal (sockets &key timeout)
+ (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))
+ (active-internal-sockets
+ (input-available-p (mapcar #'socket sockets)
+ (when timeout ticks-timeout))))
+ ;; 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.
+ ;; [Same code is also used in lispworks.lisp, allegro.lisp]
+ (remove-if #'(lambda (x)
+ (not (member (socket x) active-internal-sockets)))
+ sockets)))
+
+
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Sun May 20 08:27:15 2007
@@ -37,13 +37,21 @@
#+ecl
(progn
+ #-:wsock
(ffi:clines
- #-:wsock
- "#include <sys/socket.h>"
- #+:wsock
+ "#include <sys/socket.h>")
+ #+:wsock
+ (ffi:clines
+ "#ifndef FD_SETSIZE"
+ "#define FD_SETSIZE 1024"
+ "#endif"
"#include <winsock2.h>"
)
+ (defun fd-setsize ()
+ (ffi:c-inline () () fixnum
+ "FD_SETSIZE" :one-liner t))
+
(defun get-host-name ()
(ffi:c-inline
() () t
@@ -54,7 +62,62 @@
@(return) = make_simple_base_string(&buf);
else
@(return) = Cnil;
- }")))
+ }"))
+
+ (defun read-select (read-fds to-secs &optional (to-musecs 0))
+ (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t
+ "{
+ fd_set rfds;
+ cl_object cur_fd = #0;
+ int count;
+ int max_fd = -1;
+ struct timeval tv;
+
+ FD_ZERO(&rfds);
+ while (CONSP(cur_fd)) {
+ int fd = fixint(cur_fd->cons.car);
+ max_fd = (max_fd > fd) ? max_fd : fd;
+ FD_SET(fd, &rfds);
+ cur_fd = cur_fd->cons.cdr;
+ }
+
+ if (#1 != Cnil) {
+ tv.tv_sec = fixnnint(#1);
+ tv.tv_usec = #2;
+ }
+ count = select(max_fd + 1, &rfds, NULL, NULL,
+ (#1 != Cnil) ? &tv : NULL);
+
+ if (count == 0)
+ @(return) = Cnil;
+ else if (count < 0)
+ /*###FIXME: We should be raising an error here...
+
+ except, ofcourse in case of EINTR or EAGAIN */
+
+ @(return) = Cnil;
+ else
+ {
+ cl_object rv = Cnil;
+ cur_fd = #0;
+
+ /* when we're going to use the same code on Windows,
+ as well as unix, we can't be sure it'll fit into
+ a fixnum: these aren't unix filehandle bitmaps sets on
+ Windows... */
+
+ while (CONSP(cur_fd)) {
+ int fd = fixint(cur_fd->cons.car);
+ if (FD_ISSET(fd, &rfds))
+ rv = make_cons(make_integer(fd), rv);
+
+ cur_fd = cur_fd->cons.cdr;
+ }
+ @(return) = rv;
+ }
+}"))
+
+)
(defun map-socket-error (sock-err)
(map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
@@ -187,3 +250,53 @@
(sb-bsd-sockets::host-ent-addresses
(sb-bsd-sockets:get-host-by-name name))))
+#+sbcl
+(progn
+ #-win32
+ (defun wait-for-input-internal (sockets &key timeout)
+ (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
+ (dolist (socket sockets)
+ (sb-unix:fd-set (sb-bsd-sockets:socket-file-descriptor (socket socket))
+ rfds))
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (multiple-value-bind
+ (count err)
+ (sb-unix:unix-fast-select
+ (1+ (reduce #'max (mapcar #'socket sockets)
+ :key #'sb-bsd-sockets:socket-file-descriptor))
+ (sb-alien:addr rfds) nil nil
+ (when timeout secs) musecs)
+ (if (= 0 err)
+ ;; process the result...
+ (unless (= 0 count)
+ (remove-if
+ #'(lambda (x)
+ (not (sb-unix:fd-isset
+ (sb-bsd-sockets:socket-file-descriptor (socket x))
+ rfds)))
+ sockets))
+ (progn
+ ;;###FIXME generate an error, except for EINTR
+ ))))))
+
+ #+win32
+ (warn "wait-for-input not (yet!) supported...")
+ )
+
+#+ecl
+(progn
+ (defun wait-for-input-internal (sockets &key timeout)
+ (multiple-value-bind
+ (secs usecs)
+ (split-timeout (or timeout 1))
+ (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor
+ (mapcar #'socket sockets)))
+ (result-fds (read-select sock-fds (when timeout secs) usecs)))
+ (remove-if #'(lambda (s)
+ (not (member
+ (sb-bsd-sockets:socket-file-descriptor (socket s))
+ result-fds)))
+ sockets))))
+ )
Modified: usocket/trunk/package.lisp
==============================================================================
--- usocket/trunk/package.lisp (original)
+++ usocket/trunk/package.lisp Sun May 20 08:27:15 2007
@@ -15,6 +15,7 @@
#:socket-listen
#:socket-accept
#:socket-close
+ #:wait-for-input
#:get-local-address
#:get-peer-address
#:get-local-port
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp (original)
+++ usocket/trunk/usocket.lisp Sun May 20 08:27:15 2007
@@ -49,6 +49,15 @@
(:documentation "Socket which listens for stream connections to
be initiated from remote sockets."))
+(defun usocket-p (socket)
+ (typep socket 'usocket))
+
+(defun stream-usocket-p (socket)
+ (typep socket 'stream-usocket))
+
+(defun stream-server-usocket-p (socket)
+ (typep socket 'stream-server-usocket))
+
;;Not in use yet:
;;(defclass datagram-usocket (usocket)
;; ()
@@ -167,6 +176,38 @@
, at body))
+(defgeneric wait-for-input (socket-or-sockets
+ &key timeout)
+ (:documentation
+"Waits for one or more streams to become ready for reading from
+the socket. When `timeout' (a non-negative real number) is
+specified, wait `timeout' seconds, or wait indefinitely when
+it isn't specified. A `timeout' value of 0 (zero) means polling.
+
+Returns two values: the first value is the list of streams which
+are readable (or in case of server streams acceptable). NIL may
+be returned for this value either when waiting timed out or when
+it was interrupted (EINTR). The second value is a real number
+indicating the time remaining within the timeout period or NIL if
+none."))
+
+
+(defmethod wait-for-input (socket-or-sockets &key timeout)
+ (let* ((start (get-internal-real-time))
+ ;; the internal routine is responsibe for
+ ;; making sure the wait doesn't block on socket-streams of
+ ;; which the socket isn't ready, but there's space left in the
+ ;; buffer
+ (result (wait-for-input-internal
+ (if (listp socket-or-sockets) socket-or-sockets
+ (list socket-or-sockets))
+ :timeout timeout)))
+ (values result
+ (let ((elapsed (/ (- (get-internal-real-time) start)
+ internal-time-units-per-second)))
+ (when (< elapsed timeout)
+ (- timeout elapsed))))))
+
;;
;; IP(v4) utility functions
;;
@@ -281,6 +322,22 @@
(integer host))))
;;
+;; Other utility functions
+;;
+
+(defun split-timeout (timeout &optional (fractional 1000000))
+ "Split real value timeout into seconds and microseconds.
+Optionally, a different fractional part can be specified."
+ (multiple-value-bind
+ (secs sec-frac)
+ (truncate timeout 1)
+ (values secs
+ (truncate (* fractional sec-frac) 1))))
+
+
+
+
+;;
;; Setting of documentation for backend defined functions
;;
@@ -320,4 +377,3 @@
backward compatibility (but deprecated); when both `reuseaddress' and
`reuse-address' have been specified, the latter takes precedence.
")
-
More information about the usocket-cvs
mailing list