From ehuelsmann at common-lisp.net Mon May 7 17:50:49 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 7 May 2007 13:50:49 -0400 (EDT) Subject: [usocket-cvs] r229 - public_html Message-ID: <20070507175049.2283C13025@common-lisp.net> Author: ehuelsmann Date: Mon May 7 13:50:47 2007 New Revision: 229 Added: public_html/api-docs.shtml (contents, props changed) Log: Add public API documentation (WIP). Added: public_html/api-docs.shtml ============================================================================== --- (empty file) +++ public_html/api-docs.shtml Mon May 7 13:50:47 2007 @@ -0,0 +1,144 @@ + + + + + usocket API documentation + + + + + +

usocket API documentation

+ +

$Id$
+ Work in progress.

+ +

Please note that we're committed to the interface described +below for the entire 0.x phase of the library. When 1.0 comes +some of the functionality may be split up in different functions +and guarantees may change because of it.

+ + +

Conventions

+ + +

Specification of a host parameter

A host parameter may be any one of +

32-bit positive integer, +
a string containing an IP addres in dotted notation, or +
a host name to be resolved through DNS lookup. +

+ +

Functions for socket creation and manipulation

+ +

socket-connect host port &key element-type => socket

Creates a tcp (stream) socket to the host and port specified. The return value is +a socket object of class stream-usocket.

+ +

The element-type argument is used in the +construction of the associated stream.

+socket-listen host port &key reuse-address backlog element-type => socket

Creates and returns a passive ("server") socket associated with host and port. + The object returned is of subtype stream-server-usocket.

host names a local interface.
+ port names a local port, or 0 (zero) to request a random free port.
+ reuse-address is a boolean (t, nil) value signalling reuse of the address is requested (or not).
+ backlog is the length of the queue containing connections which haven't actually been accepted yet.
+ element-type is the default element type used for sockets created by socket-accept. character is + the default when it's not explicitly provided. +

socket-accept socket &key element-type => new-socket

Creates and returns an active ("connected") stream socket new-socket from the + socket passed. The return value is a socket object of class + stream-usocket.

element-type is the element type used to construct the associated stream. If it's not specified, + the element-type of socket (as used when it was created by the call to socket-listen) is + used. +

socket-close socket

Flushes the stream associated with the socket and closes the socket connection.

+ +

Classes

+ +

usocket

Slots: +

socket :accessor socket +: Used to store sockets as used by the current implementation - may be any of socket handles, socket objects and stream objects

stream-usocket

Parent classes: usocket
+ Slots: +

stream :accessor socket-stream +: Used to store the stream associated with the tcp socket connection.
+ When you want to write to the socket stream, use this function.

stream-server-usocket

Parent classes: usocket
+ Slots: +

element-type :reader element-type +: Indicates the default element-type to be used when constructing streams off this socket when + no element type is specified in the call to socket-accept.

+ +

Variables / constants

+ +

*wildcard-host*: The host to use with socket-listen to make the socket listen on all available interfaces.
*auto-port*: The port number to use with socket-listen to make the socket listen on a random available port. The port number assigned can be + retrieved from the returned socket by calling get-local-port.

+ +

+Back to Common-lisp.net. +

+ Valid XHTML 1.0 Strict +

+ + + From ehuelsmann at common-lisp.net Tue May 8 20:17:50 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 16:17:50 -0400 (EDT) Subject: [usocket-cvs] r230 - public_html Message-ID: <20070508201750.15E134E008@common-lisp.net> Author: ehuelsmann Date: Tue May 8 16:17:49 2007 New Revision: 230 Modified: public_html/implementation-comparison.shtml Log: Add IOLib to the list. Modified: public_html/implementation-comparison.shtml ============================================================================== --- public_html/implementation-comparison.shtml (original) +++ public_html/implementation-comparison.shtml Tue May 8 16:17:49 2007 @@ -23,30 +23,30 @@ Supported implementations comparison Implementationtrivial-socketsACL-COMPAT - s-sysdepsusocketkmrcl + s-sysdepsusocketkmrclIOLib -SBCLyesyesyesyesyes +SBCLyesyesyesyesyesyes -CMUCLyesyesyesyesyes +CMUCLyesyesyesyesyesyes -ArmedBearyesnonoyesno +ArmedBearyesnonoyesnono -clispyesyesnoyesyes +clispyesyesnoyesyesyes -Allegroyesnot relevantnoyesyes +Allegroyesnot relevantnoyesyesno -LispWorksyesyesyesyesyes +LispWorksyesyesyesyesyesno -OpenMCLyesyesyesyesyes +OpenMCLyesyesyesyesyesno -ECLnononoyesno +ECLnononoyesnono -Scieneernoyesnoyesno +Scieneernoyesnoyesnono -GCLnononono (to come)no +GCLnononono (to come)nono -Cormannoyesnono (to come)no +Cormannoyesnono (to come)nono From ehuelsmann at common-lisp.net Tue May 8 20:20:58 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 16:20:58 -0400 (EDT) Subject: [usocket-cvs] r231 - usocket/trunk Message-ID: <20070508202058.738355202B@common-lisp.net> Author: ehuelsmann Date: Tue May 8 16:20:57 2007 New Revision: 231 Modified: usocket/trunk/usocket.lisp Log: Update docstring for the 'new' :element-type key parameter. Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Tue May 8 16:20:57 2007 @@ -279,7 +279,7 @@ ;; Documentation for the function ;; -;; (defun SOCKET-CONNECT (host port) ..) +;; (defun SOCKET-CONNECT (host port &key element-type) ..) ;; (setf (documentation 'socket-connect 'function) @@ -287,6 +287,9 @@ an IP address represented in vector notation, such as #(192 168 1 1). `port' is assumed to be an integer. +`element-type' specifies the element type to use when constructing the +stream associated with the socket. The default is 'character. + Returns a usocket object.") ;; Documentation for the function From ehuelsmann at common-lisp.net Tue May 8 20:24:29 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 16:24:29 -0400 (EDT) Subject: [usocket-cvs] r232 - usocket/trunk Message-ID: <20070508202429.11FAA5202B@common-lisp.net> Author: ehuelsmann Date: Tue May 8 16:24:28 2007 New Revision: 232 Modified: usocket/trunk/README Log: Add remarks on licensing. Modified: usocket/trunk/README ============================================================================== --- usocket/trunk/README (original) +++ usocket/trunk/README Tue May 8 16:24:28 2007 @@ -6,6 +6,7 @@ ======= * Introduction + * Remarks on licensing * Non-support for :external-format * API definition * Test suite @@ -21,7 +22,7 @@ - SBCL - CMUCL - - ArmedBear (post feb 11th, 2006 versions) + - ArmedBear (post feb 11th, 2006 CVS or 0.0.10 and higher) - clisp - Allegro Common Lisp - LispWorks @@ -40,6 +41,16 @@ tricks to use the checkout directly.) +Remarks on licensing +==================== + +Even though the source code has an MIT style license attached to it, +when compiling this code with some of the supported lisp implementations +you may not end up with an MIT style binary version due to the licensing +of the implementations themselves. ECL is such an example and - when +it will become supported - GCL is like that too. + + Non-support of :external-format =============================== From ehuelsmann at common-lisp.net Tue May 8 21:53:59 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 17:53:59 -0400 (EDT) Subject: [usocket-cvs] r233 - public_html Message-ID: <20070508215359.6CD4174387@common-lisp.net> Author: ehuelsmann Date: Tue May 8 17:53:57 2007 New Revision: 233 Modified: public_html/index.shtml Log: Update project homepage with latest project status. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue May 8 17:53:57 2007 @@ -32,6 +32,10 @@

See the feature comparison with trivial-sockets in order to find out which one you should use.

Documentation

+ +

See the documentation page for the API description.

Supported implementations

Currently these implementations are supported:

@@ -39,10 +43,10 @@

SBCL
CMUCL
Armedbear (newer than 0.0.9)
Armedbear (0.0.10 and up)
clisp
Allegro
LispWorks
LispWorks (5.0 and up)
OpenMCL
ECL
Scieneer

Now that common-lisp.net supports Trac, the future part of the - table below may be moved there in the near future.

Status for the currently targeted backends
Implementation test-suite status	PASS	PASS	pass	PASS	PASS	PASS	PASS	TODO
Implement more uncommon api calls - for tcp streams.	send, recv	Implement efficient waiting for multiple sockets + in one function call (select() like behaviour).	Investigate interfaces provided	WIP	WIP	WIP	WIP	WIP	WIP	WIP	WIP	WIP
Implement more uncommon api calls - for tcp streams.	Implement wait-for-input api.		TODO	TODO	TODO	TODO
shutdown	Implement more uncommon api calls + for tcp streams.	send, recv	TODO	TODO	TODO	TODO
Implement udp socket support.	Implement more uncommon api calls + for tcp streams.	Investigate API's provided and build on top of that - (or custom ffi).	shutdown	TODO	TODO	TODO	TODO	TODO
Implement udp socket support.	Investigate API's provided and build on top of that + (or custom ffi).	WIP	WIP	WIP	WIP	WIP	WIP	WIP	WIP	WIP

0.3.0Server sockets + 0.3.0Server sockets Jan 19, 2007 0.2.5Allegro compilation fix. Jan 17, 2007 From ehuelsmann at common-lisp.net Tue May 8 21:58:19 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 17:58:19 -0400 (EDT) Subject: [usocket-cvs] r235 - public_html Message-ID: <20070508215819.5C08BA141@common-lisp.net> Author: ehuelsmann Date: Tue May 8 17:58:17 2007 New Revision: 235 Modified: public_html/index.shtml Log: Fix more xhtml compliance. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue May 8 17:58:17 2007 @@ -370,7 +370,7 @@ Feb 26, 2007 re-release Re-release of 0.2.3, 0.2.4, 0.2.5 and 0.3.0 tarballs - because the originals included Subversion administration areas. + because the originals included Subversion administration areas. Jan 21, 2007 0.3.0Server sockets Jan 19, 2007 From ehuelsmann at common-lisp.net Tue May 8 22:05:53 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 8 May 2007 18:05:53 -0400 (EDT) Subject: [usocket-cvs] r236 - usocket/trunk Message-ID: <20070508220553.818423C00B@common-lisp.net> Author: ehuelsmann Date: Tue May 8 18:05:52 2007 New Revision: 236 Modified: usocket/trunk/usocket.lisp Log: Add generic function for socket-accept. Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Tue May 8 18:05:52 2007 @@ -89,6 +89,13 @@ :socket socket :element-type element-type)) +(defgeneric socket-accept (socket &key element-type) + (:documentation + "Accepts a connection from `socket', returning a `stream-socket'. + +The stream associated with the socket returned has `element-type' when +explicitly specified, or the element-type passed to `socket-listen' otherwise.")) + (defgeneric socket-close (usocket) (:documentation "Close a previously opened `usocket'.")) @@ -314,11 +321,3 @@ `reuse-address' have been specified, the latter takes precedence. ") -;; Documentation for the function -;; -;; (defun SOCKET-ACCEPT (socket &key element-type) -(setf (documentation 'socket-accept 'function) - "Accepts a connection from `socket', returning a `stream-socket'. - -The stream associated with the socket returned has `element-type' when -explicitly specified, or the element-type passed to `socket-listen' otherwise.") From ehuelsmann at common-lisp.net Wed May 16 06:42:53 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 16 May 2007 02:42:53 -0400 (EDT) Subject: [usocket-cvs] r237 - usocket/trunk/backend Message-ID: <20070516064253.483F26510B@common-lisp.net> Author: ehuelsmann Date: Wed May 16 02:42:52 2007 New Revision: 237 Modified: usocket/trunk/backend/lispworks.lisp Log: Add cl-smtp 'requirement': get-host-name (Lispworks backend). Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Wed May 16 02:42:52 2007 @@ -9,6 +9,22 @@ (require "comm")) #+win32 +(fli:register-module "ws2_32") + +(fli:define-foreign-function (get-host-name-internal "gethostname" :source) + ((return-string (:reference-return (:ef-mb-string :limit 257))) + (namelen :int)) + :lambda-list (&aux (namelen 256) return-string) + :result-type :int + #+win32 :module #+win32 "ws2_32") + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal) + (when (= 0 retcode) + name))) + +#+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) (cons (mapcar #'(lambda (y) From ehuelsmann at common-lisp.net Wed May 16 06:49:26 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 16 May 2007 02:49:26 -0400 (EDT) Subject: [usocket-cvs] r238 - usocket/trunk/backend Message-ID: <20070516064926.7F0246510B@common-lisp.net> Author: ehuelsmann Date: Wed May 16 02:49:25 2007 New Revision: 238 Modified: usocket/trunk/backend/cmucl.lisp Log: Add cl-smtp 'requirement': get-host-name (CMUCL backend). Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Wed May 16 02:49:25 2007 @@ -160,3 +160,5 @@ (lookup-host-entry name))) (condition (condition) (handle-condition condition)))) +(defun get-host-name () + (unix:unix-gethostname)) From ehuelsmann at common-lisp.net Wed May 16 22:15:46 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 16 May 2007 18:15:46 -0400 (EDT) Subject: [usocket-cvs] r239 - usocket/trunk/backend Message-ID: <20070516221546.48E4837016@common-lisp.net> Author: ehuelsmann Date: Wed May 16 18:15:45 2007 New Revision: 239 Modified: usocket/trunk/backend/sbcl.lisp Log: Add cl-smtp 'requirement': get-host-name (SBCL backend). Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed May 16 18:15:45 2007 @@ -13,6 +13,29 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require :sockets)) +#+sbcl +(progn + #-win32 + (defun get-host-name () + (sb-unix:unix-gethostname)) + + ;; we assume winsock has already been loaded, after all, + ;; we already loaded sb-bsd-sockets and sb-alien + #+win32 + (defun get-host-name () + (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) + (let ((result (sb-alien:alien-funcall + (sb-alien:extern-alien "gethostname" + (sb-alien:function sb-alien:int + (* sb-alien:char) + sb-alien:int)) + (sb-alien:cast buf (* sb-alien:char)) + 256))) + (when (= result 0) + (cast buf sb-alien:c-string)))))) + + + (defun map-socket-error (sock-err) (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) From ehuelsmann at common-lisp.net Wed May 16 23:06:11 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 16 May 2007 19:06:11 -0400 (EDT) Subject: [usocket-cvs] r240 - usocket/trunk/backend Message-ID: <20070516230611.E97FE650D3@common-lisp.net> Author: ehuelsmann Date: Wed May 16 19:06:09 2007 New Revision: 240 Modified: usocket/trunk/backend/sbcl.lisp Log: Add cl-smtp 'requirement': get-host-name (ECL backend). Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed May 16 19:06:09 2007 @@ -35,6 +35,26 @@ (cast buf sb-alien:c-string)))))) +#+ecl +(progn + (ffi:clines + #-:wsock + "#include " + #+:wsock + "#include " + ) + + (defun get-host-name () + (ffi:c-inline + () () t + "{ char buf[256]; + int r = gethostname(&buf,256); + + if (r == 0) + @(return) = make_simple_base_string(&buf); + else + @(return) = Cnil; + }"))) (defun map-socket-error (sock-err) (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) From ehuelsmann at common-lisp.net Thu May 17 07:27:17 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 17 May 2007 03:27:17 -0400 (EDT) Subject: [usocket-cvs] r241 - usocket/trunk/backend Message-ID: <20070517072717.C06D84E021@common-lisp.net> Author: ehuelsmann Date: Thu May 17 03:27:16 2007 New Revision: 241 Modified: usocket/trunk/backend/clisp.lisp Log: Add cl-smtp 'requirement': get-host-name (clisp backend). Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Thu May 17 03:27:16 2007 @@ -6,6 +6,23 @@ (in-package :usocket) +;; utility routine for looking up the current host name +(FFI:DEF-CALL-OUT get-host-name-internal + (:name "gethostname") + (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) + :OUT :ALLOCA) + (len ffi:int)) + #+win32 (:library "WS2_32") + (:return-type ffi:int)) + + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal) + (when (= retcode 0) + name))) + + #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) From ehuelsmann at common-lisp.net Thu May 17 20:54:48 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 17 May 2007 16:54:48 -0400 (EDT) Subject: [usocket-cvs] r242 - usocket/trunk/backend Message-ID: <20070517205448.A3B5874016@common-lisp.net> Author: ehuelsmann Date: Thu May 17 16:54:47 2007 New Revision: 242 Modified: usocket/trunk/backend/allegro.lisp Log: Add cl-smtp 'requirement': get-host-name (Allegro backend). Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Thu May 17 16:54:47 2007 @@ -6,7 +6,13 @@ (in-package :usocket) (eval-when (:compile-toplevel :load-toplevel :execute) - (require :sock)) + (require :sock) + ;; note: the line below requires ACL 6.2+ + (require :osi)) + +(defun get-host-name () + ;; note: the line below requires ACL 7.0+ to actually *work* on windows + (excl.osi:gethostname)) (defparameter +allegro-identifier-error-map+ '((:address-in-use . address-in-use-error) From ehuelsmann at common-lisp.net Thu May 17 21:21:11 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 17 May 2007 17:21:11 -0400 (EDT) Subject: [usocket-cvs] r243 - usocket/trunk/backend Message-ID: <20070517212111.85A051C008@common-lisp.net> Author: ehuelsmann Date: Thu May 17 17:21:11 2007 New Revision: 243 Modified: usocket/trunk/backend/armedbear.lisp Log: Add cl-smtp 'requirement': get-host-name (ArmedBear backend). Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Thu May 17 17:21:11 2007 @@ -17,6 +17,14 @@ `(java:jnew (java:jconstructor ,class , at arg-spec) , at args)) +(defun get-host-name () + (let ((localAddress (java:jstatic + (java:jmethod "java.net.InetAddress" + "getLocalHost") + (java:jclass "java.net.InetAddress")))) + (java:jcall (java:jmethod "java.net.InetAddress" "getHostName") + localAddress))) + (defun handle-condition (condition &optional socket) (typecase condition (error (error 'unknown-error :socket socket :real-error condition)))) From ehuelsmann at common-lisp.net Thu May 17 22:00:05 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 17 May 2007 18:00:05 -0400 (EDT) Subject: [usocket-cvs] r244 - usocket/trunk/backend Message-ID: <20070517220005.205861A0A6@common-lisp.net> Author: ehuelsmann Date: Thu May 17 18:00:04 2007 New Revision: 244 Modified: usocket/trunk/backend/openmcl.lisp Log: Add cl-smtp 'requirement': get-host-name (OpenMCL backend). Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Thu May 17 18:00:04 2007 @@ -5,7 +5,10 @@ (in-package :usocket) - +(defun get-host-name () + (ccl::%stack-block ((resultbuf 256)) + (when (zerop (#_gethostname resultbuf 256)) + (ccl::%get-cstring resultbuf)))) (defparameter +openmcl-error-map+ '((:address-in-use . address-in-use-error) @@ -23,6 +26,35 @@ (:access-denied . operation-not-permitted-error))) +;; we need something which the openmcl implementors 'forgot' to do: +;; wait for more than one socket-or-fd + +(defun input-available-p (sockets &optional ticks-to-wait) + (ccl::rletZ ((tv :timeval)) + (ccl::ticks-to-timeval ticks-to-wait tv) + (ccl::%stack-block ((infds ccl::*fd-set-size*) + (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)))) + (defun raise-error-from-id (condition-id socket real-condition) (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) (if usock-err From ehuelsmann at common-lisp.net Thu May 17 22:03:56 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 17 May 2007 18:03:56 -0400 (EDT) Subject: [usocket-cvs] r245 - usocket/trunk/backend Message-ID: <20070517220356.0D7F77E008@common-lisp.net> Author: ehuelsmann Date: Thu May 17 18:03:55 2007 New Revision: 245 Modified: usocket/trunk/backend/scl.lisp Log: Add cl-smtp 'requirement': get-host-name (SCL backend); needs verification. Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Thu May 17 18:03:55 2007 @@ -129,3 +129,6 @@ (t (error 'ns-unknown-error :host-or-ip name :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) From ehuelsmann at common-lisp.net Fri May 18 20:19:00 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 18 May 2007 16:19:00 -0400 (EDT) Subject: [usocket-cvs] r246 - usocket/trunk Message-ID: <20070518201900.160553420F@common-lisp.net> Author: ehuelsmann Date: Fri May 18 16:18:59 2007 New Revision: 246 Modified: usocket/trunk/package.lisp Log: Prefix package construction with Common Lisp package designator. Add 2 missing external symbols. Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Fri May 18 16:18:59 2007 @@ -3,14 +3,15 @@ ;;;; See the LICENSE file for licensing information. -(in-package :cl-user) +#+lispworks (cl:require "comm") -#+lispworks (require "comm") - -(eval-when (:execute :load-toplevel :compile-toplevel) - (defpackage :usocket +(cl:eval-when (:execute :load-toplevel :compile-toplevel) + (cl:defpackage :usocket (:use :cl) - (:export #:socket-connect ; socket constructors and methods + (:export #:*wildcard-host* + #:*auto-port* + + #:socket-connect ; socket constructors and methods #:socket-listen #:socket-accept #:socket-close From ehuelsmann at common-lisp.net Sun May 20 10:51:59 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 20 May 2007 06:51:59 -0400 (EDT) Subject: [usocket-cvs] r247 - in usocket/trunk: . backend test Message-ID: <20070520105159.81B23650D3@common-lisp.net> Author: ehuelsmann Date: Sun May 20 06:51:58 2007 New Revision: 247 Modified: usocket/trunk/ (props changed) usocket/trunk/backend/ (props changed) usocket/trunk/test/ (props changed) Log: Add ignore value for LispWorks 5.0 ufasls. From ehuelsmann at common-lisp.net Sun May 20 12:27:16 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 20 May 2007 08:27:16 -0400 (EDT) Subject: [usocket-cvs] r248 - in usocket/trunk: . backend Message-ID: <20070520122716.D7F833200B@common-lisp.net> 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 " - #+:wsock + "#include ") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" "#include " ) + (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. ") - From ehuelsmann at common-lisp.net Sun May 20 14:16:12 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 20 May 2007 10:16:12 -0400 (EDT) Subject: [usocket-cvs] r249 - usocket/trunk Message-ID: <20070520141612.7C479431B7@common-lisp.net> Author: ehuelsmann Date: Sun May 20 10:16:12 2007 New Revision: 249 Modified: usocket/trunk/README Log: Update README. Modified: usocket/trunk/README ============================================================================== --- usocket/trunk/README (original) +++ usocket/trunk/README Sun May 20 10:16:12 2007 @@ -123,6 +123,8 @@ - interrupted-condition - unkown-condition +(for a description of the API methods and functions see + http://common-lisp.net/project/usocket/api-docs.shtml.) Test suite ========== @@ -146,11 +148,6 @@ meaning there's no way to tell different error conditions apart. All errors are mapped to unknown-error on CMUCL. -- When running the test suite through the run-usocket-tests.sh shell - script, ArmedBear 0.0.9 will report failure - even when it didn't. - You need a CVS version later than 2006-02-11, or later than 0.0.9 - release version for the script to work correctly. - - The ArmedBear backend doesn't do any error mapping (yet). Java defines exceptions at the wrong level (IMO), since the exception reported bares a relation to the function failing, not the actual @@ -160,3 +157,21 @@ map 'BindException' to a meaningfull error in usocket. [This does not mean the backend should not at least map to 'unknown-error'!] +- When using the library with ECL, you need the C compiler installed + to be able to compile and load the Foreign Function Interface. + Not all ECL targets support DFFI yet, so on some targets this would + be the case anyway. By depending on this technique, usocket can + reuse the FFI code on all platforms (including Windows). This benefit + currently outweighs the additional requirement. (hey, it's *Embeddable* + Common Lisp, so, you probably wanted to embed it all along, right?) + +- LispWorks has a bug(?) in wait-for-input-streams which make it + unsuited for waiting for input on stream socket servers, making it + necessary to resort to different means. With the absence of notice-fd + on Windows, that currenty leaves Windows unsupported. + +- SBCL can't use select() on Windows because it would mean porting + the FD_* macros and the select structures which I'm not sure + is the right way yet (if I need to write custom Win32 code anyway...) + The alternative is to use WSAEventSelect() and friends (which don't + have a limited number of sockets). From ehuelsmann at common-lisp.net Mon May 21 20:29:06 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 21 May 2007 16:29:06 -0400 (EDT) Subject: [usocket-cvs] r250 - usocket/trunk/backend Message-ID: <20070521202906.1D1123202E@common-lisp.net> Author: ehuelsmann Date: Mon May 21 16:29:05 2007 New Revision: 250 Modified: usocket/trunk/backend/armedbear.lisp Log: ABCL 'wait-for-input'. Victory\! Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Mon May 21 16:29:05 2007 @@ -6,12 +6,32 @@ (in-package :usocket) -(defmacro jmethod-call (instance (method &rest arg-spec) &rest args) +(defmacro jstatic-call (class-name (method-name &rest arg-spec) + &rest args) + (let ((class-sym (gensym))) + `(let ((,class-sym ,class-name)) + (java:jstatic + (java:jmethod ,class-sym ,method-name , at arg-spec) + (java:jclass ,class-sym) , at args)))) + +(defmacro jmethod-call (instance-and-class (method &rest arg-spec) &rest args) (let ((isym (gensym))) - `(let* ((,isym ,instance) - (class-name (java:jclass-name (java:jclass-of ,isym)))) - (java:jcall (java:jmethod class-name ,method , at arg-spec) - ,isym , at args)))) + (multiple-value-bind + (instance class-name) + (if (listp instance-and-class) + (values (first instance-and-class) + (second instance-and-class)) + (values instance-and-class)) + (when (null class-name) + (setf class-name `(java:jclass-name (java:jclass-of ,isym)))) + `(let* ((,isym ,instance)) + (java:jcall (java:jmethod ,class-name ,method , at arg-spec) + ,isym , at args))))) + +(defun jequals (x y) + (jmethod-call (x "java.lang.Object") + ("equals" "java.lang.Object") + y)) (defmacro jnew-call ((class &rest arg-spec) &rest args) `(java:jnew (java:jconstructor ,class , at arg-spec) @@ -48,7 +68,10 @@ (sock-addr (jnew-call ("java.net.InetSocketAddress" "java.lang.String" "int") (host-to-hostname host) port)) - (sock (jnew-call ("java.net.ServerSocket")))) + (chan (jstatic-call "java.nio.channels.ServerSocketChannel" ("open"))) + (sock (java:jcall + (java:jmethod "java.nio.channels.ServerSocketChannel" + "socket") chan))) (when reuseaddress (jmethod-call sock ("setReuseAddress" "boolean") @@ -102,3 +125,153 @@ (defmethod get-peer-name ((usocket stream-usocket)) (values (get-peer-address usocket) (get-peer-port usocket))) + + +#| +Pseudo code version of what we're trying to do: + +We're being called with 2 args: + + - sockets (list) + - timeout (non-negative real) + +Selector := java.nio.channels.Selector.open() + +For all usockets + get the java socket + get its channel + register the channel with the selector + with ops (operations) OP_READ and OP_ACCEPT + +make the selector wait trunc(timeout*1000) miliseconds, + unless (null timeout), because then: + selectNow() + +retrieve the selectedKeys() set from the selector + unless select() returned 0 selected keys. + +for set-iterator.hasNextKey() + with that key + retrieve the channel + retrieve the channel's socket + add the retrieved socket to the list of ready sockets + +for all usockets + check if the associated java object + is in the list of ready sockets + it is? add it to the function result list + +close() the selector + +return the function result list. + +|# + +(defun jsocket-channel (jsocket) + (jmethod-call jsocket ("getChannel"))) + +(defun jselkey-channel (jselectionkey) + (jmethod-call (jselectionkey "java.nio.channels.SelectionKey") + ("channel"))) + +(defun op-read () + (java:jfield (java:jclass "java.nio.channels.SelectionKey") + "OP_READ")) + +(defun op-accept () + (java:jfield (java:jclass "java.nio.channels.SelectionKey") + "OP_ACCEPT")) + +(defun op-connect () + (java:jfield (java:jclass "java.nio.channels.SelectionKey") + "OP_CONNECT")) + +(defun valid-ops (jchannel) + (jmethod-call (jchannel "java.nio.channels.SelectableChannel") + ("validOps"))) + +(defun register (jchannel jselector ops) + (jmethod-call (jchannel "java.nio.channels.SelectableChannel") + ("register" "java.nio.channels.Selector" "int") + jselector ops)) + +(defun toggle-blocking (jchannel mode) + (jmethod-call (jchannel "java.nio.channels.SelectableChannel") + ("configureBlocking" "boolean") + mode)) + +(defun jselector-select (jselector timeout) + (let ((to (truncate (* (or timeout 0) 1000)))) + (if (/= timeout 0) + (jmethod-call (jselector "java.nio.channels.Selector") + ("select" "long") to) + (jmethod-call (jselector "java.nio.channels.Selector") + ("selectNow"))))) + +(defun jselector-selected-keys (jselector) + (jmethod-call (jselector "java.nio.channels.Selector") + ("selectedKeys"))) + +(defun jset-iterator (jset) + (jmethod-call (jset "java.util.Set") ("iterator"))) + +(defun jiterator-has-next (jiterator) + (jmethod-call (jiterator "java.util.Iterator") ("hasNext"))) + +(defun jiterator-next (jiterator) + (jmethod-call (jiterator "java.util.Iterator") ("next"))) + +(defun channel-class (jchannel) + (let ((valid-ops (valid-ops jchannel))) + (cond ((/= 0 (logand valid-ops (op-connect))) + "java.nio.channels.SocketChannel") + ((/= 0 (logand valid-ops (op-accept))) + "java.nio.channels.ServerSocketChannel") + (t + "java.nio.channels.DatagramChannel")))) + +(defun wait-for-input-internal (sockets &key timeout) + (let* ((ops (logior (op-read) (op-accept))) + (selector (jstatic-call "java.nio.channels.Selector" ("open"))) + (channels + (mapcar #'(lambda (s) + (jsocket-channel (socket s))) + sockets))) + (unwind-protect + (progn + (let ((jfalse (java:make-immediate-object nil :boolean))) + (dolist (channel channels) + (toggle-blocking channel jfalse) + (register channel selector (logand ops (valid-ops channel))))) + (let ((ready-count + (jselector-select selector timeout))) + (when (< 0 ready-count) + ;; we actually have work to do + (let* ((selkeys (jselector-selected-keys selector)) + (selkey-iterator (jset-iterator selkeys)) + ready-sockets) + (loop while (jiterator-has-next selkey-iterator) + do (let* ((key (jiterator-next selkey-iterator)) + (chan (jselkey-channel key))) + (push (jmethod-call (chan (channel-class chan)) + ("socket")) + ready-sockets))) + (print ready-sockets) + (print (remove-if #'(lambda (s) + (not (member (socket s) ready-sockets + :test #'jequals))) + sockets)))))) + ;; cancel all Selector registrations + (let* ((keys (jmethod-call (selector "java.nio.channels.Selector") + ("keys"))) + (iter (jset-iterator keys))) + (loop while (jiterator-has-next iter) + do (jmethod-call ((jiterator-next iter) + "java.nio.channels.SelectionKey") + ("cancel")))) + ;; close the selectorx + (jmethod-call (selector "java.nio.channels.Selector") ("close")) + ;; make all sockets blocking again. + (let ((jtrue (java:make-immediate-object t :boolean))) + (dolist (chan channels) + (toggle-blocking chan jtrue)))))) From ehuelsmann at common-lisp.net Mon May 21 21:52:48 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 21 May 2007 17:52:48 -0400 (EDT) Subject: [usocket-cvs] r251 - public_html Message-ID: <20070521215248.78FA09@common-lisp.net> Author: ehuelsmann Date: Mon May 21 17:52:47 2007 New Revision: 251 Modified: public_html/index.shtml Log: Update website with progress. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon May 21 17:52:47 2007 @@ -287,14 +287,14 @@ Implement wait-for-input api. - TODO - TODO - TODO - TODO - TODO - TODO - TODO - TODO + WIP + DONE + DONE + DONE + DONE + WIP + DONE + DONE TODO From ehuelsmann at common-lisp.net Mon May 21 21:54:29 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 21 May 2007 17:54:29 -0400 (EDT) Subject: [usocket-cvs] r252 - public_html Message-ID: <20070521215429.61E079@common-lisp.net> Author: ehuelsmann Date: Mon May 21 17:54:28 2007 New Revision: 252 Modified: public_html/index.shtml Log: Update website with progress. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Mon May 21 17:54:28 2007 @@ -275,15 +275,15 @@ in one function call (select() like behaviour). Investigate interfaces provided - WIP - WIP - WIP - WIP - WIP - WIP - WIP - WIP - WIP + WIP + DONE + DONE + DONE + DONE + WIP + DONE + DONE + TODO Implement wait-for-input api. From ehuelsmann at common-lisp.net Tue May 22 21:35:59 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 22 May 2007 17:35:59 -0400 (EDT) Subject: [usocket-cvs] r253 - usocket/trunk/backend Message-ID: <20070522213559.70CFA1D0CC@common-lisp.net> Author: ehuelsmann Date: Tue May 22 17:35:58 2007 New Revision: 253 Modified: usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp Log: Small but important changes to various backends as a result of more heavy testing. Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Tue May 22 17:35:58 2007 @@ -165,6 +165,7 @@ (defun wait-for-input-internal (sockets &key timeout) (alien:with-alien ((rfds (alien:struct unix:fd-set))) + (unix:fd-zero rfds) (dolist (socket sockets) (unix:fd-set (socket socket) rfds)) (multiple-value-bind @@ -176,12 +177,11 @@ :key #'socket)) (alien:addr rfds) nil nil (when timeout secs) musecs) - (if (= 0 err) + (if (<= 0 count) ;; process the result... - (unless (= 0 count) - (remove-if #'(lambda (x) - (not (unix:fd-isset (socket x) rfds))) - sockets)) + (remove-if #'(lambda (x) + (not (unix:fd-isset (socket x) rfds))) + sockets) (progn ;;###FIXME generate an error, except for EINTR )))))) Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Tue May 22 17:35:58 2007 @@ -39,18 +39,15 @@ (defun input-available-p (sockets &optional ticks-to-wait) (ccl::rletZ ((tv :timeval)) (ccl::ticks-to-timeval ticks-to-wait tv) - (ccl::%stack-block ((infds ccl::*fd-set-size*) - (errfds ccl::*fd-set-size*)) + (ccl::%stack-block ((infds ccl::*fd-set-size*)) (ccl::fd-zero infds) - (ccl::fd-zero errfds) (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))) + (ccl::fd-set fd infds))) (let* ((res (ccl::syscall syscalls::select (1+ max-fd) - infds (ccl::%null-ptr) errfds + infds (ccl::%null-ptr) (ccl::%null-ptr) (if ticks-to-wait tv (ccl::%null-ptr))))) (when (> res 0) (remove-if #'(lambda (x) Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Tue May 22 17:35:58 2007 @@ -255,6 +255,7 @@ #-win32 (defun wait-for-input-internal (sockets &key timeout) (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) + (sb-unix:fd-zero rfds) (dolist (socket sockets) (sb-unix:fd-set (sb-bsd-sockets:socket-file-descriptor (socket socket)) rfds)) @@ -268,18 +269,19 @@ :key #'sb-bsd-sockets:socket-file-descriptor)) (sb-alien:addr rfds) nil nil (when timeout secs) musecs) - (if (= 0 err) + (if (<= 0 count) ;; 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)) + (remove-if + #'(lambda (x) + (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets) (progn + (unless (= err sb-unix:EINTR) + (error (map-errno-error err)))) ;;###FIXME generate an error, except for EINTR - )))))) + ))))) #+win32 (warn "wait-for-input not (yet!) supported...") From ehuelsmann at common-lisp.net Tue May 22 21:38:11 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 22 May 2007 17:38:11 -0400 (EDT) Subject: [usocket-cvs] r254 - public_html Message-ID: <20070522213811.9D83121042@common-lisp.net> Author: ehuelsmann Date: Tue May 22 17:38:08 2007 New Revision: 254 Modified: public_html/index.shtml Log: Resize the table font and add some references. Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Tue May 22 17:38:08 2007 @@ -105,7 +105,7 @@ current state of development.
- +
@@ -273,7 +273,8 @@ - + @@ -325,9 +326,9 @@ - - + + @@ -338,6 +339,18 @@ + + + + + + + + + + + +
Status for the currently targeted backends

Implement efficient waiting for multiple sockets in one function call (select() like behaviour). Investigate interfaces provided + Investigate interfaces provided WIP DONE TODO

Implement udp socket support. Investigate API's provided and build on top of that - (or custom ffi). Implement udp socket support. + Investigate API's provided WIP WIP WIP WIP WIP
Build on top of that (or custom ffi). TODO TODO TODO TODO TODO TODO TODO TODO TODO

From ehuelsmann at common-lisp.net Tue May 22 21:51:26 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 22 May 2007 17:51:26 -0400 (EDT) Subject: [usocket-cvs] r255 - usocket/trunk/backend Message-ID: <20070522215126.B93F67B498@common-lisp.net> Author: ehuelsmann Date: Tue May 22 17:51:25 2007 New Revision: 255 Modified: usocket/trunk/backend/clisp.lisp Log: Small but important changes to clisp backend as a result of more heavy testing. Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Tue May 22 17:51:25 2007 @@ -129,8 +129,7 @@ (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (let* ((musecs (truncate (* 1000000 sec-frac) 1)) - (request-list (mapcar #'(lambda (x) + (let* ((request-list (mapcar #'(lambda (x) (if (stream-server-usocket-p x) (socket x) (list (socket x) :input))) From ehuelsmann at common-lisp.net Fri May 25 22:27:49 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 25 May 2007 18:27:49 -0400 (EDT) Subject: [usocket-cvs] r256 - usocket/trunk/backend Message-ID: <20070525222749.23E28362A6@common-lisp.net> Author: ehuelsmann Date: Fri May 25 18:27:48 2007 New Revision: 256 Modified: usocket/trunk/backend/armedbear.lisp Log: Finish ArmedBear backend implementation by changing socket-connect to java.nio.channels too. At the same time implement a somewhat more readable FFI. (We'll later abstract it out and make it even better by making it require even fewer type casts\!) Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Fri May 25 18:27:48 2007 @@ -6,6 +6,142 @@ (in-package :usocket) +;;;;; Proposed contribution to the JAVA package + +(defpackage :jdi + (:use :cl) + (:export #:jcoerce + #:jop-deref + #:do-jmethod-call + #:do-jmethod + #:do-jstatic-call + #:do-jstatic + #:do-jnew-call + #:do-jfield + #:jequals)) +;; but still requires the :java package. + +(in-package :jdi) + +(defstruct (java-object-proxy (:conc-name :jop-) + :copier) + value + class) + +(defvar *jm-get-return-type* + (java:jmethod "java.lang.reflect.Method" "getReturnType")) + +(defvar *jf-get-type* + (java:jmethod "java.lang.reflect.Field" "getType")) + +(defvar *jc-get-declaring-class* + (java:jmethod "java.lang.reflect.Constructor" "getDeclaringClass")) + +(declaim (inline make-return-type-proxy)) +(defun make-return-type-proxy (jmethod jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jm-get-return-type* jmethod))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun make-field-type-proxy (jfield jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jf-get-type* jfield))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun make-constructor-type-proxy (jconstructor jreturned-value) + (if (java:java-object-p jreturned-value) + (let ((rt (java:jcall *jc-get-declaring-class* jconstructor))) + (make-java-object-proxy :value jreturned-value + :class rt)) + jreturned-value)) + +(defun jcoerce (instance &optional output-type-spec) + (cond + ((java-object-proxy-p instance) + (let ((new-instance (copy-structure (the java-object-proxy instance)))) + (setf (jop-class new-instance) + (java:jclass output-type-spec)) + new-instance)) + ((java:java-object-p instance) + (make-java-object-proxy :class (java:jclass output-type-spec) + :value instance)) + ((stringp instance) + (make-java-object-proxy :class "java.lang.String" + :value instance)) + ((keywordp output-type-spec) + ;; all that remains is creating an immediate type... + (let ((jval (java:make-immediate-object instance output-type-spec))) + (make-java-object-proxy :class output-type-spec + :value jval))) + )) + +(defun jtype-of (instance) ;;instance must be a jop + (cond + ((stringp instance) + "java.lang.String") + ((keywordp (jop-class instance)) + (string-downcase (symbol-name (jop-class instance)))) + (t + (java:jclass-name (jop-class instance))))) + +(defun jop-deref (instance) + (if (java-object-proxy-p instance) + (jop-value instance) + instance)) + +(defun java-value-and-class (object) + (values (jop-deref object) + (jtype-of object))) + +(defun do-jmethod-call (object method-name &rest arguments) + (multiple-value-bind + (instance class-name) + (java-value-and-class object) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jmethod class-name method-name argument-types)) + (rv (apply #'java:jcall jm instance + (mapcar #'jop-deref arguments)))) + (make-return-type-proxy jm rv)))) + +(defun do-jstatic-call (class-name method-name &rest arguments) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jmethod class-name method-name argument-types)) + (rv (apply #'java:jstatic jm (java:jclass class-name) + (mapcar #'jop-deref arguments)))) + (make-return-type-proxy jm rv))) + +(defun do-jnew-call (class-name &rest arguments) + (let* ((argument-types (mapcar #'jtype-of arguments)) + (jm (apply #'java:jconstructor class-name argument-types)) + (rv (apply #'java:jnew jm (mapcar #'jop-deref arguments)))) + (make-constructor-type-proxy jm rv))) + +(defun do-jfield (class-or-instance-or-name field-name) + (let* ((class (cond + ((stringp class-or-instance-or-name) + (java:jclass class-or-instance-or-name)) + ((java:java-object-p class-or-instance-or-name) + (java:jclass-of class-or-instance-or-name)) + ((java-object-proxy-p class-or-instance-or-name) + (java:jclass (jtype-of class-or-instance-or-name))))) + (jf (java:jcall (java:jmethod "java.lang.Class" "getField" + "java.lang.String") + class field-name))) + (make-field-type-proxy jf + (java:jfield class field-name)))) ;;class)))) + +(defmacro do-jstatic (&rest arguments) + `(do-jstatic-call , at arguments)) + +(defmacro do-jmethod (&rest arguments) + `(do-jmethod-call , at arguments)) + +;; + (defmacro jstatic-call (class-name (method-name &rest arg-spec) &rest args) (let ((class-sym (gensym))) @@ -29,21 +165,21 @@ ,isym , at args))))) (defun jequals (x y) - (jmethod-call (x "java.lang.Object") - ("equals" "java.lang.Object") - y)) + (do-jmethod-call (jcoerce x "java.lang.Object") "equals" + (jcoerce y "java.lang.Object"))) (defmacro jnew-call ((class &rest arg-spec) &rest args) `(java:jnew (java:jconstructor ,class , at arg-spec) , at args)) + + +(in-package :usocket) + (defun get-host-name () - (let ((localAddress (java:jstatic - (java:jmethod "java.net.InetAddress" - "getLocalHost") - (java:jclass "java.net.InetAddress")))) - (java:jcall (java:jmethod "java.net.InetAddress" "getHostName") - localAddress))) + (jdi:do-jmethod-call (jdi:do-jstatic-call "java.net.InetAddress" + "getLocalHost") + "getHostName")) (defun handle-condition (condition &optional socket) (typecase condition @@ -52,11 +188,19 @@ (defun socket-connect (host port &key (element-type 'character)) (let ((usock)) (with-mapped-conditions (usock) - (let ((sock (ext:make-socket (host-to-hostname host) port))) + (let* ((sock-addr (jdi:jcoerce + (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int)) + "java.net.SocketAddress")) + (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel" + "open" sock-addr)) + (sock (jdi:do-jmethod-call jchan "socket"))) + (describe sock) (setf usock (make-stream-socket :socket sock - :stream (ext:get-socket-stream sock + :stream (ext:get-socket-stream (jdi:jop-deref sock) :element-type element-type))))))) (defun socket-listen (host port @@ -65,27 +209,28 @@ (backlog 5) (element-type 'character)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) - (sock-addr (jnew-call ("java.net.InetSocketAddress" - "java.lang.String" "int") - (host-to-hostname host) port)) - (chan (jstatic-call "java.nio.channels.ServerSocketChannel" ("open"))) - (sock (java:jcall - (java:jmethod "java.nio.channels.ServerSocketChannel" - "socket") chan))) + (sock-addr (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int))) + (chan (jdi:do-jstatic-call "java.nio.channels.ServerSocketChannel" + "open")) + (sock (jdi:do-jmethod-call chan "socket"))) (when reuseaddress - (jmethod-call sock - ("setReuseAddress" "boolean") - (java:make-immediate-object reuseaddress :boolean))) - (jmethod-call sock - ("bind" "java.net.SocketAddress" "int") - sock-addr backlog) + (jdi:do-jmethod-call sock + "setReuseAddress" + (jdi:jcoerce reuseaddress :boolean))) + (jdi:do-jmethod-call sock + "bind" + (jdi:jcoerce sock-addr + "java.net.SocketAddress") + (jdi:jcoerce backlog :int)) (make-stream-server-socket sock :element-type element-type))) (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (let* ((jsock (socket socket)) - (jacc-sock (jmethod-call jsock ("accept"))) + (jacc-sock (jdi:do-jmethod-call jsock "accept")) (jacc-stream - (ext:get-socket-stream jacc-sock + (ext:get-socket-stream (jdi:jop-deref jacc-sock) :element-type (or element-type (element-type socket))))) (make-stream-socket :socket jacc-sock @@ -167,59 +312,20 @@ |# -(defun jsocket-channel (jsocket) - (jmethod-call jsocket ("getChannel"))) - -(defun jselkey-channel (jselectionkey) - (jmethod-call (jselectionkey "java.nio.channels.SelectionKey") - ("channel"))) - (defun op-read () - (java:jfield (java:jclass "java.nio.channels.SelectionKey") - "OP_READ")) + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_READ")) (defun op-accept () - (java:jfield (java:jclass "java.nio.channels.SelectionKey") - "OP_ACCEPT")) + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_ACCEPT")) (defun op-connect () - (java:jfield (java:jclass "java.nio.channels.SelectionKey") - "OP_CONNECT")) + (jdi:do-jfield "java.nio.channels.SelectionKey" + "OP_CONNECT")) (defun valid-ops (jchannel) - (jmethod-call (jchannel "java.nio.channels.SelectableChannel") - ("validOps"))) - -(defun register (jchannel jselector ops) - (jmethod-call (jchannel "java.nio.channels.SelectableChannel") - ("register" "java.nio.channels.Selector" "int") - jselector ops)) - -(defun toggle-blocking (jchannel mode) - (jmethod-call (jchannel "java.nio.channels.SelectableChannel") - ("configureBlocking" "boolean") - mode)) - -(defun jselector-select (jselector timeout) - (let ((to (truncate (* (or timeout 0) 1000)))) - (if (/= timeout 0) - (jmethod-call (jselector "java.nio.channels.Selector") - ("select" "long") to) - (jmethod-call (jselector "java.nio.channels.Selector") - ("selectNow"))))) - -(defun jselector-selected-keys (jselector) - (jmethod-call (jselector "java.nio.channels.Selector") - ("selectedKeys"))) - -(defun jset-iterator (jset) - (jmethod-call (jset "java.util.Set") ("iterator"))) - -(defun jiterator-has-next (jiterator) - (jmethod-call (jiterator "java.util.Iterator") ("hasNext"))) - -(defun jiterator-next (jiterator) - (jmethod-call (jiterator "java.util.Iterator") ("next"))) + (jdi:do-jmethod-call jchannel "validOps")) (defun channel-class (jchannel) (let ((valid-ops (valid-ops jchannel))) @@ -232,46 +338,56 @@ (defun wait-for-input-internal (sockets &key timeout) (let* ((ops (logior (op-read) (op-accept))) - (selector (jstatic-call "java.nio.channels.Selector" ("open"))) + (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) (channels (mapcar #'(lambda (s) - (jsocket-channel (socket s))) + (jdi:jcoerce (jdi:do-jmethod-call (socket s) "getChannel") + "java.nio.channels.SocketChannel")) sockets))) (unwind-protect - (progn - (let ((jfalse (java:make-immediate-object nil :boolean))) + (with-mapped-conditions () + (let ((jfalse (jdi:jcoerce nil :boolean))) (dolist (channel channels) - (toggle-blocking channel jfalse) - (register channel selector (logand ops (valid-ops channel))))) + (jdi:do-jmethod channel "configureBlocking" jfalse) + (jdi:do-jmethod channel "register" + selector + (jdi:jcoerce (logand ops (valid-ops channel)) + :int)))) (let ((ready-count - (jselector-select selector timeout))) + (jdi:do-jmethod selector "select" (jdi:jcoerce + (truncate (* timeout 1000)) + :long)))) (when (< 0 ready-count) ;; we actually have work to do - (let* ((selkeys (jselector-selected-keys selector)) - (selkey-iterator (jset-iterator selkeys)) + (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) + (selkey-iterator (jdi:do-jmethod selkeys "iterator")) ready-sockets) - (loop while (jiterator-has-next selkey-iterator) - do (let* ((key (jiterator-next selkey-iterator)) - (chan (jselkey-channel key))) - (push (jmethod-call (chan (channel-class chan)) - ("socket")) + (loop while (jdi:do-jmethod selkey-iterator "hasNext") + do (let* ((key (jdi:jcoerce + (jdi:do-jmethod selkey-iterator "next") + "java.nio.channels.SelectionKey")) + (chan (jdi:do-jmethod key "channel"))) + (push (jdi:do-jmethod + (jdi:jcoerce chan + (channel-class chan)) + "socket") ready-sockets))) - (print ready-sockets) - (print (remove-if #'(lambda (s) - (not (member (socket s) ready-sockets - :test #'jequals))) - sockets)))))) + (remove-if #'(lambda (s) + (not (member (socket s) ready-sockets + :key #'jdi:jop-deref + :test #'jdi:jequals))) + sockets))))) ;; cancel all Selector registrations - (let* ((keys (jmethod-call (selector "java.nio.channels.Selector") - ("keys"))) - (iter (jset-iterator keys))) - (loop while (jiterator-has-next iter) - do (jmethod-call ((jiterator-next iter) - "java.nio.channels.SelectionKey") - ("cancel")))) - ;; close the selectorx - (jmethod-call (selector "java.nio.channels.Selector") ("close")) + (let* ((keys (jdi:do-jmethod selector "keys")) + (iter (jdi:do-jmethod keys "iterator"))) + (loop while (jdi:do-jmethod iter "hasNext") + do (jdi:do-jmethod (jdi:jcoerce (jdi:do-jmethod iter "next") + "java.nio.channels.SelectionKey") + "cancel"))) + ;; close the selector + (jdi:do-jmethod selector "close") ;; make all sockets blocking again. - (let ((jtrue (java:make-immediate-object t :boolean))) + (let ((jtrue (jdi:jcoerce t :boolean))) (dolist (chan channels) - (toggle-blocking chan jtrue)))))) + (jdi:do-jmethod chan "configureBlocking" jtrue)))))) + From ehuelsmann at common-lisp.net Wed May 30 21:10:11 2007 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 30 May 2007 17:10:11 -0400 (EDT) Subject: [usocket-cvs] r257 - usocket/trunk/backend Message-ID: <20070530211011.44EA4590A5@common-lisp.net> Author: ehuelsmann Date: Wed May 30 17:10:10 2007 New Revision: 257 Modified: usocket/trunk/backend/armedbear.lisp Log: Two changes: 1) Change socket slot to contain a channel instead of a socket. 2) Optimize wait-for-input-internal for comming abcl optimization where (jmethod ...) is considered constant when it has only string arguments. Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Wed May 30 17:10:10 2007 @@ -199,7 +199,7 @@ (describe sock) (setf usock (make-stream-socket - :socket sock + :socket jchan :stream (ext:get-socket-stream (jdi:jop-deref sock) :element-type element-type))))))) @@ -224,16 +224,17 @@ (jdi:jcoerce sock-addr "java.net.SocketAddress") (jdi:jcoerce backlog :int)) - (make-stream-server-socket sock :element-type element-type))) + (make-stream-server-socket chan :element-type element-type))) (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (let* ((jsock (socket socket)) - (jacc-sock (jdi:do-jmethod-call jsock "accept")) + (jacc-chan (jdi:do-jmethod-call jsock "accept")) (jacc-stream - (ext:get-socket-stream (jdi:jop-deref jacc-sock) + (ext:get-socket-stream (jdi:jop-deref + (jdi:do-jmethod-call jacc-chan "socket")) :element-type (or element-type (element-type socket))))) - (make-stream-socket :socket jacc-sock + (make-stream-socket :socket jacc-chan :stream jacc-stream))) ;;(defun print-java-exception (e) @@ -242,7 +243,7 @@ (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) - (ext:socket-close (socket usocket)))) + (jdi:do-method (socket usocket) "close"))) ;; Socket streams are different objects than ;; socket streams. Closing the stream flushes @@ -336,58 +337,79 @@ (t "java.nio.channels.DatagramChannel")))) +(defun socket-channel-class (socket) + (cond + ((stream-usocket-p socket) + "java.nio.channels.SocketChannel") + ((stream-server-usocket-p socket) + "java.nio.channels.ServerSocketChannel") + ((datagram-usocket-p socket) + "java.nio.channels.DatagramChannel"))) + (defun wait-for-input-internal (sockets &key timeout) (let* ((ops (logior (op-read) (op-accept))) (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) - (channels - (mapcar #'(lambda (s) - (jdi:jcoerce (jdi:do-jmethod-call (socket s) "getChannel") - "java.nio.channels.SocketChannel")) - sockets))) + (channels (mapcar #'socket sockets))) (unwind-protect - (with-mapped-conditions () - (let ((jfalse (jdi:jcoerce nil :boolean))) +;; (with-mapped-conditions () + (progn + (let ((jfalse (java:make-immediate-object nil :boolean)) + (sel (jdi:jop-deref selector))) (dolist (channel channels) - (jdi:do-jmethod channel "configureBlocking" jfalse) - (jdi:do-jmethod channel "register" - selector - (jdi:jcoerce (logand ops (valid-ops channel)) - :int)))) - (let ((ready-count - (jdi:do-jmethod selector "select" (jdi:jcoerce - (truncate (* timeout 1000)) - :long)))) - (when (< 0 ready-count) - ;; we actually have work to do - (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) - (selkey-iterator (jdi:do-jmethod selkeys "iterator")) - ready-sockets) - (loop while (jdi:do-jmethod selkey-iterator "hasNext") - do (let* ((key (jdi:jcoerce - (jdi:do-jmethod selkey-iterator "next") - "java.nio.channels.SelectionKey")) - (chan (jdi:do-jmethod key "channel"))) - (push (jdi:do-jmethod - (jdi:jcoerce chan - (channel-class chan)) - "socket") - ready-sockets))) - (remove-if #'(lambda (s) - (not (member (socket s) ready-sockets - :key #'jdi:jop-deref - :test #'jdi:jequals))) - sockets))))) + (let ((chan (jdi:jop-deref channel))) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + chan jfalse) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "register" + "java.nio.channels.Selector" "int") + chan sel (logand ops (valid-ops channel))))) + (let ((ready-count + (java:jcall (java:jmethod "java.nio.channels.Selector" + "select" + "long") + sel (truncate (* timeout 1000))))) + (when (< 0 ready-count) + ;; we actually have work to do + (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) + (selkey-iterator (jdi:do-jmethod selkeys "iterator")) + ready-sockets) + (loop while (java:jcall + (java:jmethod "java.util.Iterator" "hasNext") + (jdi:jop-deref selkey-iterator)) + do (let* ((key (jdi:jcoerce + (jdi:do-jmethod selkey-iterator "next") + "java.nio.channels.SelectionKey")) + (chan (jdi:jop-deref + (jdi:do-jmethod key "channel")))) + (push chan ready-sockets))) + (remove-if #'(lambda (s) + (not (member (jdi:jop-deref (socket s)) + ready-sockets + :test #'(lambda (x y) + (java:jcall (java:jmethod "java.lang.Object" + "equals" + "java.lang.Object") + x y))))) + sockets)))))) ;; cancel all Selector registrations (let* ((keys (jdi:do-jmethod selector "keys")) (iter (jdi:do-jmethod keys "iterator"))) - (loop while (jdi:do-jmethod iter "hasNext") - do (jdi:do-jmethod (jdi:jcoerce (jdi:do-jmethod iter "next") - "java.nio.channels.SelectionKey") - "cancel"))) + (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") + (jdi:jop-deref iter)) + do (java:jcall + (java:jmethod "java.nio.channels.SelectionKey" "cancel") + (java:jcall (java:jmethod "java.util.Iterator" "next") + (jdi:jop-deref iter))))) ;; close the selector - (jdi:do-jmethod selector "close") + (java:jcall (java:jmethod "java.nio.channels.Selector" "close") + (jdi:jop-deref selector)) ;; make all sockets blocking again. - (let ((jtrue (jdi:jcoerce t :boolean))) + (let ((jtrue (java:make-immediate-object t :boolean))) (dolist (chan channels) - (jdi:do-jmethod chan "configureBlocking" jtrue)))))) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + (jdi:jop-deref chan) jtrue))))))

Implement efficient waiting for multiple sockets in one function call (select() like behaviour).	Investigate interfaces provided	+ Investigate interfaces provided	WIP	DONE	TODO
	Implement udp socket support.	Investigate API's provided and build on top of that - (or custom ffi).	Implement udp socket support.	+ Investigate API's provided	WIP	WIP	WIP	WIP	WIP
Build on top of that (or custom ffi).	TODO	TODO	Implement udp socket support.	TODO	TODO	TODO	TODO	TODO	TODO	TODO