usocket-cvs July 2010

usocket-cvs@common-lisp.net

1 participants
23 discussions

[usocket-cvs] r553 - in usocket/trunk: . backend vendor
by Chun Tian 20 Jul '10

20 Jul '10

Author: ctian Date: Tue Jul 20 01:48:39 2010 New Revision: 553 Log: ABCL: move JDI into vendor directory. Added: usocket/trunk/vendor/abcl-jdi.lisp (contents, props changed) Modified: usocket/trunk/backend/armedbear.lisp usocket/trunk/usocket.asd Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Tue Jul 20 01:48:39 2010 @@ -5,178 +5,6 @@ (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))))) - -(declaim (inline jop-deref)) -(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 ,@arguments)) - -(defmacro do-jmethod (&rest arguments) - `(do-jmethod-call ,@arguments)) - -;; - -(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 ,@arg-spec) - (java:jclass ,class-sym) ,@args)))) - -(defmacro jmethod-call (instance-and-class (method &rest arg-spec) &rest args) - (let ((isym (gensym))) - (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 ,@arg-spec) - ,isym ,@args))))) - -(defun jequals (x 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 ,@arg-spec) - ,@args)) - - - -(in-package :usocket) - (defun get-host-name () (jdi:do-jmethod-call (jdi:do-jstatic-call "java.net.InetAddress" "getLocalHost") Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Tue Jul 20 01:48:39 2010 @@ -23,6 +23,7 @@ :components ((:file "split-sequence") #+mcl (:file "kqueue") #+openmcl (:file "ccl-send") + #+armedbear (:file "abcl-jdi") (:file "spawn-thread"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) Added: usocket/trunk/vendor/abcl-jdi.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/abcl-jdi.lisp Tue Jul 20 01:48:39 2010 @@ -0,0 +1,170 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; Proposed contribution to the JAVA package, by Erik Huelsmann + +(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))))) + +(declaim (inline jop-deref)) +(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 ,@arguments)) + +(defmacro do-jmethod (&rest arguments) + `(do-jmethod-call ,@arguments)) + +;; + +(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 ,@arg-spec) + (java:jclass ,class-sym) ,@args)))) + +(defmacro jmethod-call (instance-and-class (method &rest arg-spec) &rest args) + (let ((isym (gensym))) + (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 ,@arg-spec) + ,isym ,@args))))) + +(defun jequals (x 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 ,@arg-spec) + ,@args))

1 0

[usocket-cvs] r552 - in usocket/trunk: . backend test vendor
by Chun Tian 20 Jul '10

20 Jul '10

Author: ctian Date: Tue Jul 20 00:29:48 2010 New Revision: 552 Log: Update ignore properties for ECL. Modified: usocket/trunk/ (props changed) usocket/trunk/backend/ (props changed) usocket/trunk/test/ (props changed) usocket/trunk/vendor/ (props changed)

1 0

[usocket-cvs] r551 - in usocket/trunk: . backend vendor
by Chun Tian 20 Jul '10

20 Jul '10

Author: ctian Date: Tue Jul 20 00:27:18 2010 New Revision: 551 Log: Remove wrongly committed obj files Removed: usocket/trunk/backend/sbcl.obj usocket/trunk/condition.obj usocket/trunk/package.obj usocket/trunk/server.obj usocket/trunk/usocket.obj usocket/trunk/vendor/spawn-thread.obj usocket/trunk/vendor/split-sequence.obj

1 0

[usocket-cvs] r550 - in usocket/trunk: . backend vendor
by Chun Tian 20 Jul '10

20 Jul '10

Author: ctian Date: Tue Jul 20 00:25:42 2010 New Revision: 550 Log: ECL: first working WAIT-FOR-INPUT implementation on win32. Added: usocket/trunk/backend/sbcl.obj (contents, props changed) usocket/trunk/condition.obj (contents, props changed) usocket/trunk/package.obj (contents, props changed) usocket/trunk/server.obj (contents, props changed) usocket/trunk/usocket.obj (contents, props changed) usocket/trunk/vendor/spawn-thread.obj (contents, props changed) usocket/trunk/vendor/split-sequence.obj (contents, props changed) Modified: usocket/trunk/backend/sbcl.lisp usocket/trunk/usocket.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Tue Jul 20 00:25:42 2010 @@ -393,14 +393,12 @@ ;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe)) ;;; Based on LispWorks version written by Erik Huelsmann. -#+(and sbcl win32) -(eval-when (:compile-toplevel) +#+win32 ; shared by ECL and SBCL +(progn (defconstant +wsa-wait-failed+ #xffffffff) (defconstant +wsa-wait-event-0+ 0) - (defconstant +wsa-wait-timeout+ 258)) + (defconstant +wsa-wait-timeout+ 258) -#+(and sbcl win32) -(progn (defconstant fd-read 1) (defconstant fd-read-bit 0) (defconstant fd-write 2) @@ -424,6 +422,22 @@ (defconstant fd-max-events 10) (defconstant fionread 1074030207) + ;; Note: for ECL, socket-handle will return raw Windows Handle, + ;; while SBCL returns OSF Handle instead. + (defun socket-handle (usocket) + (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (plusp (bytes-available-for-read socket)) + (%ready-p socket))) + + (defun waiting-required (sockets) + (notany #'socket-ready-p sockets)) +) ; progn + +#+(and sbcl win32) +(progn (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) (sb-alien:define-alien-type ws-event sb-alien::hinstance) @@ -482,23 +496,12 @@ (defun os-socket-handle (usocket) (sockint::fd->handle (sb-bsd-sockets:socket-file-descriptor (socket usocket)))) - (defun socket-handle (usocket) - (sb-bsd-sockets:socket-file-descriptor (socket usocket))) - (defun bytes-available-for-read (socket) (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long)) (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr)) socket) int-ptr)) - (defun socket-ready-p (socket) - (if (typep socket 'stream-usocket) - (plusp (bytes-available-for-read socket)) - (%ready-p socket))) - - (defun waiting-required (sockets) - (notany #'socket-ready-p sockets)) - (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) @@ -589,3 +592,87 @@ (defun %remove-waiter (wl w) (declare (ignore wl w))) ) ; progn + +#+(and ecl win32) +(progn + (defun maybe-wsa-error (rv &optional syscall) + (unless (zerop rv) + (sb-bsd-sockets::socket-error syscall))) + + (defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (ffi:c-inline () () :int + "WSAEVENT event; + event = WSACreateEvent(); + @(return) = event;"))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events) + (:fixnum :fixnum :fixnum) :fixnum + "int result; + result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2); + @(return) = result;") + '%add-waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list)) + (:fixnum :fixnum) :fixnum + "int result; + result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L); + @(return) = result;") + '%remove-waiter)) + + ;; TODO: how to handle error (result) in this call? + (defun bytes-available-for-read (socket) + (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum + "u_long nbytes; + int result; + nbytes = 0L; + result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes); + @(return) = nbytes;")) + + (defun update-ready-and-state-slots (sockets) + (dolist (socket sockets) + (if (or (and (stream-usocket-p socket) + (listen (socket-stream socket))) + (%ready-p socket)) + (setf (state socket) :READ) + (let ((events (etypecase socket + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + ;; TODO: check the iErrorCode array + (if (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) :bool + "WSANETWORKEVENTS network_events; + int i, result; + result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events); + if (!result) { + @(return) = (#1 & network_events.lNetworkEvents)? Ct : Cnil; + } else + @(return) = Cnil;") + (setf (%ready-p socket) t + (state socket) :READ) + (sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))) + + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (let ((rv (ffi:c-inline ((wait-list-%wait wait-list) (truncate (* 1000 timeout))) + (:fixnum :fixnum) :fixnum + "DWORD result; + WSAEVENT events[1]; + events[0] = (WSAEVENT)#0; + result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL); + @(return) = result;"))) + (ecase rv + ((#.+wsa-wait-event-0+ #.+wsa-wait-timeout+) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + ((#.+wsa-wait-failed+) + (sb-bsd-sockets::socket-error 'wait-for-input-internal)))))) + +) ; progn Added: usocket/trunk/backend/sbcl.obj ============================================================================== Binary file. No diff available. Added: usocket/trunk/condition.obj ============================================================================== Binary file. No diff available. Added: usocket/trunk/package.obj ============================================================================== Binary file. No diff available. Added: usocket/trunk/server.obj ============================================================================== Binary file. No diff available. Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Tue Jul 20 00:25:42 2010 @@ -35,7 +35,7 @@ The last two remain unused in the current version. ") - #+(and win32 (or sbcl lispworks)) + #+(and win32 (or sbcl ecl lispworks)) (%ready-p :initform nil :accessor %ready-p @@ -304,11 +304,11 @@ (values (if ready-only socks socket-or-sockets) to))))) (let* ((start (get-internal-real-time)) (sockets-ready 0)) + #-(and win32 (or sbcl ecl)) (dolist (x (wait-list-waiters socket-or-sockets)) (when (setf (state x) (if (and (stream-usocket-p x) - (listen (socket-stream x)) - #+(and sbcl win32) nil) ; TODO: bug?! + (listen (socket-stream x))) :READ NIL)) (incf sockets-ready))) ;; the internal routine is responsibe for Added: usocket/trunk/usocket.obj ============================================================================== Binary file. No diff available. Added: usocket/trunk/vendor/spawn-thread.obj ============================================================================== Binary file. No diff available. Added: usocket/trunk/vendor/split-sequence.obj ============================================================================== Binary file. No diff available.

1 0

[usocket-cvs] r549 - usocket/trunk/backend
by Chun Tian 19 Jul '10

19 Jul '10

Author: ctian Date: Mon Jul 19 09:55:24 2010 New Revision: 549 Log: MCL: mark UDP (datagram) as unsupported. Modified: usocket/trunk/backend/mcl.lisp Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Mon Jul 19 09:55:24 2010 @@ -72,7 +72,9 @@ (raise-error))))) (defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay - local-host local-port) + local-host local-port (protocol :stream)) + (when (eq protocol :datagram) + (unsupported '(protocol :datagram) 'socket-connect)) (with-mapped-conditions () (let* ((socket (make-instance 'active-socket

1 0

[usocket-cvs] r548 - in usocket/trunk: . backend
by Chun Tian 19 Jul '10

19 Jul '10

Author: ctian Date: Mon Jul 19 07:49:57 2010 New Revision: 548 Log: Cleaned MCL test code. Modified: usocket/trunk/backend/mcl.lisp (contents, props changed) usocket/trunk/usocket.asd Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Mon Jul 19 07:49:57 2010 @@ -1,3 +1,6 @@ +;;;; $Id$ +;;;; $URL$ + ;; MCL backend for USOCKET 0.4.1 ;; Terje Norderhaug <terje(a)in-progress.com>, January 1, 2009 @@ -264,106 +267,3 @@ #'ready-sockets (wait-list-waiters wait-list))) (nreverse result)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#| Test for wait-for-input -(let* ((sock1 (usocket:socket-connect "in-progress.com" 80)) - (sock2 (usocket:socket-connect "common-lisp.net" 80)) - (sockets (list sock1 sock2))) - (dolist (sock sockets) - (format (usocket:socket-stream sock) - "GET / HTTP/1.0~A~A~A~A" - #\Return #\Linefeed #\Return #\Linefeed) - (force-output (usocket:socket-stream sock))) - (wait-for-input sockets :timeout 5000)) -|# - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#| TEST (from test-usocket.lisp) - - -(defparameter +non-existing-host+ "192.168.1.1") -(defparameter +unused-local-port+ 15213) -(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket - :stream :my-stream)) -(defparameter +common-lisp-net+ #(208 72 159 207)) ;; common-lisp.net IP - - -(usocket:socket *soc1*) - -(usocket:socket-connect "127.0.0.0" +unused-local-port+) - -(usocket:socket-connect #(127 0 0 0) +unused-local-port+) - -(usocket:socket-connect 2130706432 +unused-local-port+) - - (let ((sock (usocket:socket-connect "common-lisp.net" 80))) - (unwind-protect - (typep sock 'usocket:usocket) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) - (unwind-protect - (typep sock 'usocket:usocket) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) - (unwind-protect - (typep sock 'usocket:usocket) - (usocket:socket-close sock))) - -(let ((sock (usocket:socket-connect "common-lisp.net" 80))) - (unwind-protect - (progn - (format (usocket:socket-stream sock) - "GET / HTTP/1.0~A~A~A~A" - #\Return #\Linefeed #\Return #\Linefeed) - (force-output (usocket:socket-stream sock)) - (read-line (usocket:socket-stream sock))) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) - (unwind-protect - (usocket::get-peer-address sock) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) - (unwind-protect - (usocket::get-peer-port sock) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) - (unwind-protect - (usocket::get-peer-name sock) - (usocket:socket-close sock))) - - (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) - (unwind-protect - (usocket::get-local-address sock) - (usocket:socket-close sock))) - -|# - - -#| - -(defun socket-server (host port) - (let ((socket (socket-listen host port))) - (unwind-protect - (loop - (with-open-stream (stream (socket-stream (socket-accept socket))) - (ccl::telnet-write-line stream "~A" - (reverse (ccl::telnet-read-line stream))) - (ccl::force-output stream))) - (close socket)))) - -(ccl::process-run-function "Socket Server" #'socket-server NIL 4088) - -(let* ((sock (socket-connect nil 4088)) - (stream (usocket:socket-stream sock))) - (assert (streamp stream)) - (ccl::telnet-write-line stream "hello ~A" (random 10)) - (ccl::force-output stream) - (ccl::telnet-read-line stream)) - -|# Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Mon Jul 19 07:49:57 2010 @@ -4,12 +4,12 @@ ;;;; See the LICENSE file for licensing information. -(in-package #:cl-user) +(in-package :cl-user) -(defpackage #:usocket-system - (:use #:cl #:asdf)) +(defpackage usocket-system + (:use :cl :asdf)) -(in-package #:usocket-system) +(in-package :usocket-system) (defsystem usocket :name "usocket"

1 0

[usocket-cvs] r547 - in usocket/trunk: backend test
by Chun Tian 16 Jul '10

16 Jul '10

Author: ctian Date: Fri Jul 16 04:23:10 2010 New Revision: 547 Log: SBCL: fixed type error in calling of wsa-enum-network-events Modified: usocket/trunk/backend/sbcl.lisp usocket/trunk/test/test-usocket.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Jul 16 04:23:10 2010 @@ -521,20 +521,21 @@ (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) - (if (or (and (stream-usocket-p socket) - (listen (socket-stream socket))) - (%ready-p socket)) - (setf (state socket) :READ) - (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events))) - (let ((rv (wsa-enum-network-events (os-socket-handle socket) 0 network-events))) - (if (zerop rv) - (map-network-events #'(lambda (err-code) - (if (zerop err-code) - (setf (%ready-p socket) t - (state socket) :READ) - (raise-usock-err err-code socket))) - network-events) - (maybe-wsa-error rv socket))))))) + (if (or (and (stream-usocket-p socket) + (listen (socket-stream socket))) + (%ready-p socket)) + (setf (state socket) :READ) + (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events))) + (let ((rv (wsa-enum-network-events (os-socket-handle socket) 0 + (sb-alien:addr network-events)))) + (if (zerop rv) + (map-network-events #'(lambda (err-code) + (if (zerop err-code) + (setf (%ready-p socket) t + (state socket) :READ) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket))))))) (defun os-wait-list-%wait (wait-list) (sb-alien:deref (wait-list-%wait wait-list))) Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Fri Jul 16 04:23:10 2010 @@ -196,5 +196,20 @@ (usocket:socket-close sock)))) #.*wait-for-input-timeout*) +(deftest wait-for-input.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect *common-lisp-net* 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~c~c~c~c" + #\Return #\linefeed #\Return #\linefeed) + (force-output (usocket:socket-stream sock)) + (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) + (read-line (usocket:socket-stream sock))) + (usocket:socket-close sock)))) + #+(or mcl clisp) "HTTP/1.1 200 OK" + #-(or mcl clisp) #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + (defun run-usocket-tests () (do-tests))

1 0

[usocket-cvs] r546 - usocket/trunk/backend
by Chun Tian 16 Jul '10

16 Jul '10

Author: ctian Date: Thu Jul 15 23:05:27 2010 New Revision: 546 Log: SBCL: first working WAIT-FOR-INPUT implementation. Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Thu Jul 15 23:05:27 2010 @@ -13,10 +13,6 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require :sockets)) -#+(and sbcl win32) ; for "WaitForSingleObject" -(eval-when (:compile-toplevel :load-toplevel :execute) - (sb-alien:load-shared-object "kernel32.dll")) - #+sbcl (progn #-win32 @@ -399,9 +395,9 @@ #+(and sbcl win32) (eval-when (:compile-toplevel) - (defconstant +wait-failed+ -1) ; #xffffffff - (defconstant +wait-object-0+ 0) - (defconstant +wait-timeout+ 258)) + (defconstant +wsa-wait-failed+ #xffffffff) + (defconstant +wsa-wait-event-0+ 0) + (defconstant +wsa-wait-timeout+ 258)) #+(and sbcl win32) (progn @@ -429,6 +425,8 @@ (defconstant fionread 1074030207) (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) + (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) + (sb-alien:define-alien-type ws-event sb-alien::hinstance) (sb-alien:define-alien-type nil (sb-alien:struct wsa-network-events @@ -436,28 +434,35 @@ (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create) - sb-alien::hinstance) ; return type only + ws-event) ; return type only + + (sb-alien:define-alien-routine ("WSAResetEvent" wsa-event-reset) + (boolean #.sb-vm::n-machine-word-bits) + (event-object ws-event)) (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close) - (sb-alien:boolean #.sb-vm::n-machine-word-bits) - (event-object sb-alien::hinstance)) + (boolean #.sb-vm::n-machine-word-bits) + (event-object ws-event)) (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events) sb-alien:int (socket ws-socket) - (event-object sb-alien::hinstance) + (event-object ws-event) (network-events (* (sb-alien:struct wsa-network-events)))) (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) sb-alien:int (socket ws-socket) - (event-object sb-alien::hinstance) + (event-object ws-event) (network-events sb-alien:long)) - (sb-alien:define-alien-routine ("WaitForSingleObject" wait-for-single-object) - sb-alien:long - (object sb-alien::hinstance) - (timeout sb-alien:long)) + (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events) + ws-dword + (number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p (boolean #.sb-vm::n-machine-word-bits)) + (timeout ws-dword) + (alertable-p (boolean #.sb-vm::n-machine-word-bits))) (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket) sb-alien:int @@ -496,11 +501,12 @@ (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) - (let ((rv (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000000 timeout))))) + (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) + nil (truncate (* 1000 timeout)) nil))) (ecase rv - ((#.+wait-object-0+ #.+wait-timeout+) + ((#.+wsa-wait-event-0+ #.+wsa-wait-timeout+) (update-ready-and-state-slots (wait-list-waiters wait-list))) - (#.+wait-failed+ + ((#.+wsa-wait-failed+) (raise-usock-err (sb-win32::get-last-error-message (sb-win32::get-last-error)) wait-list)))))) @@ -530,24 +536,32 @@ network-events) (maybe-wsa-error rv socket))))))) + (defun os-wait-list-%wait (wait-list) + (sb-alien:deref (wait-list-%wait wait-list))) + + (defun (setf os-wait-list-%wait) (value wait-list) + (setf (sb-alien:deref (wait-list-%wait wait-list)) value)) + (defun %setup-wait-list (wait-list) - (setf (wait-list-%wait wait-list) (wsa-event-create)) + (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event)) + (setf (os-wait-list-%wait wait-list) (wsa-event-create)) (sb-ext:finalize wait-list #'(lambda () (unless (null (wait-list-%wait wait-list)) - (wsa-event-close (wait-list-%wait wait-list)))))) + (wsa-event-close (os-wait-list-%wait wait-list)) + (sb-alien:free-alien (wait-list-%wait wait-list)))))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter (stream-server-usocket (logior fd-connect fd-accept fd-close)) - (stream-usocket (logior fd-connect fd-read fd-oob fd-close)) + (stream-usocket (logior fd-read)) (datagram-usocket (logior fd-read))))) (maybe-wsa-error - (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events) + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events) waiter))) (defun %remove-waiter (wait-list waiter) (maybe-wsa-error - (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0) + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0) waiter)) ) ; progn

1 0

[usocket-cvs] r545 - in usocket/trunk: . backend
by Chun Tian 15 Jul '10

15 Jul '10

Author: ctian Date: Thu Jul 15 02:02:17 2010 New Revision: 545 Log: Server: fix wrong parensises in UDP-EVENT-LOOP Modified: usocket/trunk/backend/sbcl.lisp usocket/trunk/server.lisp usocket/trunk/usocket.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Thu Jul 15 02:02:17 2010 @@ -38,7 +38,6 @@ (when (= result 0) (sb-alien:cast buf sb-alien:c-string)))))) - #+ecl (progn #-:wsock @@ -148,7 +147,6 @@ (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor (socket sock))) (setf (state sock) :READ)))))))) - ) ; progn (defun map-socket-error (sock-err) @@ -343,7 +341,6 @@ (defmethod get-peer-port ((usocket stream-usocket)) (nth-value 1 (get-peer-name usocket))) - (defun get-host-by-address (address) (with-mapped-conditions () (sb-bsd-sockets::host-ent-name @@ -397,7 +394,6 @@ (setf (state x) :READ)))))))))) ) ; progn - ;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe)) ;;; Based on LispWorks version written by Erik Huelsmann. @@ -499,7 +495,6 @@ (notany #'socket-ready-p sockets)) (defun wait-for-input-internal (wait-list &key timeout) - (format t "timeout: ~A, ~A~%" timeout (truncate (* 1000000 timeout))) (when (waiting-required (wait-list-waiters wait-list)) (let ((rv (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000000 timeout))))) (ecase rv Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Thu Jul 15 02:02:17 2010 @@ -67,9 +67,9 @@ (error "send error: ~A~%" n)))))) (error "receive error: ~A" n)))) #+scl (when thread:*quitting-lisp* (return)) - #+(and cmu mp) (mp:process-yield)))) - (socket-close socket) - (values))) + #+(and cmu mp) (mp:process-yield))) + (socket-close socket) + (values)))) (defun default-tcp-handler (stream) ; null (declare (type stream stream)) Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Thu Jul 15 02:02:17 2010 @@ -215,10 +215,10 @@ the arguments `socket-connect-args' to `socket-var' and if `stream-var' is non-nil, bind the associated socket stream to it." `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) - ,(if (null stream-var) - `(progn ,@body) - `(let ((,stream-var (socket-stream ,socket-var))) - ,@body)))) + ,(if (null stream-var) + `(progn ,@body) + `(let ((,stream-var (socket-stream ,socket-var))) + ,@body)))) (defmacro with-server-socket ((var server-socket) &body body) "Bind `server-socket' to `var', ensuring socket destruction on exit. @@ -227,21 +227,19 @@ The `body' is an implied progn form." `(with-connected-socket (,var ,server-socket) - ,@body)) + ,@body)) (defmacro with-socket-listener ((socket-var &rest socket-listen-args) &body body) "Bind the socket resulting from a call to `socket-listen' with arguments `socket-listen-args' to `socket-var'." `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) - ,@body)) - + ,@body)) (defstruct (wait-list (:constructor %make-wait-list)) %wait ;; implementation specific waiters ;; the list of all usockets - map ;; maps implementation sockets to usockets - ) + map) ;; maps implementation sockets to usockets ;; Implementation specific: ;; @@ -253,9 +251,8 @@ (let ((wl (%make-wait-list))) (setf (wait-list-map wl) (make-hash-table)) (%setup-wait-list wl) - (dolist (x waiters) - (add-waiter wl x)) - wl)) + (dolist (x waiters wl) + (add-waiter wl x)))) (defun add-waiter (wait-list input) (setf (gethash (socket input) (wait-list-map wait-list)) input @@ -276,7 +273,6 @@ (setf (wait-list-waiters wait-list) nil) (clrhash (wait-list-map wait-list))) - (defun wait-for-input (socket-or-sockets &key timeout ready-only) "Waits for one or more streams to become ready for reading from the socket. When `timeout' (a non-negative real number) is @@ -353,7 +349,6 @@ (setf (ldb (byte 8 i) integer) (aref buffer b))))) - (defmacro port-to-octet-buffer (port buffer &key (start 0)) `(integer-to-octet-buffer ,port ,buffer 2 ,start)) @@ -508,9 +503,6 @@ (values secs (truncate (* fractional sec-frac) 1)))) - - - ;; ;; Setting of documentation for backend defined functions ;;

1 0

[usocket-cvs] r544 - usocket/trunk
by Chun Tian 12 Jul '10

12 Jul '10

Author: ctian Date: Mon Jul 12 12:40:18 2010 New Revision: 544 Log: Fixed Makefile, based on patch from Desmond O. Chang. Modified: usocket/trunk/Makefile Modified: usocket/trunk/Makefile ============================================================================== --- usocket/trunk/Makefile (original) +++ usocket/trunk/Makefile Mon Jul 12 12:40:18 2010 @@ -2,8 +2,7 @@ # $URL$ clean: - find -name -o -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.fasl" -o -name "*.faslmt" -o -name "*.ufsl" -o -name "*.abcl" | xargs rm + find . $ -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.*fasl" -o -name "*.faslmt" -o -name "*.abcl" -o -name "*.*fsl" -o -name "*.o" -o -name "*.sse2f" $ -delete commit: make clean; svn up; svn ci -

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

usocket-cvs July 2010