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 @@ ,@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. ") -