From ctian at common-lisp.net Mon Jul 5 09:03:05 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 05 Jul 2010 05:03:05 -0400 Subject: [usocket-cvs] r531 - in usocket/trunk: . backend Message-ID: Author: ctian Date: Mon Jul 5 05:03:05 2010 New Revision: 531 Log: SBCL: commit untested WAIT-FOR-INPUT for win32. Modified: usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/usocket.lisp Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Mon Jul 5 05:03:05 2010 @@ -604,7 +604,8 @@ (fli:define-foreign-type ws-socket () '(:unsigned :int)) (fli:define-foreign-type win32-handle () '(:unsigned :int)) - (fli:define-c-struct wsa-network-events (network-events :long) + (fli:define-c-struct wsa-network-events + (network-events :long) (error-code (:c-array :int 10))) (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source) @@ -669,9 +670,9 @@ 0)))) (defun socket-ready-p (socket) - (if (typep socket 'stream-usocket) - (< 0 (bytes-available-for-read socket)) - (%ready-p socket))) + (if (typep socket 'stream-usocket) + (< 0 (bytes-available-for-read socket)) + (%ready-p socket))) (defun waiting-required (sockets) (notany #'socket-ready-p sockets)) @@ -686,29 +687,27 @@ (let ((event-map (fli:foreign-slot-value network-events 'network-events)) (error-array (fli:foreign-slot-pointer network-events 'error-code))) (unless (zerop event-map) - (dotimes (i fd-max-events) - (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? - (funcall func (fli:foreign-aref error-array i))))))) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? + (funcall func (fli:foreign-aref error-array i))))))) (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) - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0 t) - (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)))))) - - + (dolist (socket sockets) + (if (or (and (stream-usocket-p socket) + (listen (socket-stream socket))) + (%ready-p socket)) + (setf (state socket) :READ) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0 t) + (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)))))) ;; The wait-list part Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Mon Jul 5 05:03:05 2010 @@ -13,6 +13,10 @@ (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 @@ -354,18 +358,15 @@ #+(and sbcl (not win32)) (progn + (defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) -(defun %setup-wait-list (wait-list) - (declare (ignore wait-list))) - -(defun %add-waiter (wait-list waiter) - (push (socket waiter) (wait-list-%wait wait-list))) - -(defun %remove-waiter (wait-list waiter) - (setf (wait-list-%wait wait-list) - (remove (socket waiter) (wait-list-%wait wait-list)))) - + (defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + (defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) (defun wait-for-input-internal (sockets &key timeout) (with-mapped-conditions () @@ -398,8 +399,141 @@ (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. + #+(and sbcl win32) - (warn "wait-for-input not (yet!) supported...") +(progn + (defconstant fd-read 1) + (defconstant fd-read-bit 0) + (defconstant fd-write 2) + (defconstant fd-write-bit 1) + (defconstant fd-oob 4) + (defconstant fd-oob-bit 2) + (defconstant fd-accept 8) + (defconstant fd-accept-bit 3) + (defconstant fd-connect 16) + (defconstant fd-connect-bit 4) + (defconstant fd-close 32) + (defconstant fd-close-bit 5) + (defconstant fd-qos 64) + (defconstant fd-qos-bit 6) + (defconstant fd-group-qos 128) + (defconstant fd-group-qos-bit 7) + (defconstant fd-routing-interface 256) + (defconstant fd-routing-interface-bit 8) + (defconstant fd-address-list-change 512) + (defconstant fd-address-list-change-bit 9) + (defconstant fd-max-events 10) + (defconstant fionread 1074030207) + + (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) + + (sb-alien:define-alien-type nil + (sb-alien:struct wsa-network-events + (network-events sb-alien:long) + (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 + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close) + (sb-alien:boolean #.sb-vm::n-machine-word-bits) + (event-object sb-alien::hinstance)) + + (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events) + sb-alien:int + (socket ws-socket) + (event-object sb-alien::hinstance) + (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) + (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)) + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (sockint::wsa-get-last-error) socket))) + + (defun os-socket-handle (usocket) + (socket usocket)) + + (defun bytes-available-for-read (socket) + (sb-alien:with-alien ((int-ptr sb-alien:long)) + (let ((rv (sockint::win32-ioctl (os-socket-handle socket) fionread int-ptr))) + (prog1 + (if (= 0 rv) (sb-alien:deref int-ptr) 0) + (sb-alien:free-alien int-ptr))))) + + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (< 0 (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)) + (maybe-wsa-error + (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000 timeout))) + wait-list)) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + + (defun map-network-events (func network-events) + (let ((event-map (sb-alien:slot network-events 'network-events)) + (error-array (sb-alien:slot network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? + (funcall func (sb-alien:deref error-array i))))))) + + (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) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0 t) + (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 %setup-wait-list (wait-list) + (setf (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)))))) + + (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)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (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) + waiter)) +) ; progn #+ecl (progn @@ -423,5 +557,4 @@ (defun %remove-waiter (wl w) (declare (ignore wl w))) - - ) +) ; progn Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Mon Jul 5 05:03:05 2010 @@ -35,7 +35,7 @@ The last two remain unused in the current version. ") - #+(and lispworks win32) + #+(and win32 (or sbcl lispworks)) (%ready-p :initform nil :accessor %ready-p From ctian at common-lisp.net Mon Jul 5 09:56:29 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 05 Jul 2010 05:56:29 -0400 Subject: [usocket-cvs] r532 - usocket/trunk/backend Message-ID: Author: ctian Date: Mon Jul 5 05:56:29 2010 New Revision: 532 Log: SBCL: fix compilation errors. Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Mon Jul 5 05:56:29 2010 @@ -459,16 +459,27 @@ (object sb-alien::hinstance) (timeout sb-alien:long)) + (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket) + sb-alien:int + (socket ws-socket) + (cmd sb-alien:long) + (argp (* sb-alien::unsigned-long))) + + (defun raise-usock-err (errno socket) + (error 'unknown-error + :socket socket + :real-error errno)) + (defun maybe-wsa-error (rv &optional socket) (unless (zerop rv) (raise-usock-err (sockint::wsa-get-last-error) socket))) (defun os-socket-handle (usocket) - (socket usocket)) + (sb-bsd-sockets:socket-file-descriptor (socket usocket))) (defun bytes-available-for-read (socket) - (sb-alien:with-alien ((int-ptr sb-alien:long)) - (let ((rv (sockint::win32-ioctl (os-socket-handle socket) fionread int-ptr))) + (sb-alien:with-alien ((int-ptr (* sb-alien:unsigned-long))) + (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) (prog1 (if (= 0 rv) (sb-alien:deref int-ptr) 0) (sb-alien:free-alien int-ptr))))) @@ -504,7 +515,7 @@ (setf (state socket) :READ) (multiple-value-bind (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0 t) + (wsa-enum-network-events (os-socket-handle socket) 0 t) ; ??? (if (zerop rv) (map-network-events #'(lambda (err-code) (if (zerop err-code) From ctian at common-lisp.net Wed Jul 7 08:27:26 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 07 Jul 2010 04:27:26 -0400 Subject: [usocket-cvs] r533 - usocket/trunk/backend Message-ID: Author: ctian Date: Wed Jul 7 04:27:26 2010 New Revision: 533 Log: SBCL: fixed os-socket-handle by using sockint::fd->handle Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed Jul 7 04:27:26 2010 @@ -41,7 +41,6 @@ #+ecl (progn - #-:wsock (ffi:clines "#include " @@ -150,8 +149,7 @@ (socket sock))) (setf (state sock) :READ)))))))) - -) +) ; progn (defun map-socket-error (sock-err) (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) @@ -475,7 +473,7 @@ (raise-usock-err (sockint::wsa-get-last-error) socket))) (defun os-socket-handle (usocket) - (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + (sockint::fd->handle (sb-bsd-sockets:socket-file-descriptor (socket usocket)))) (defun bytes-available-for-read (socket) (sb-alien:with-alien ((int-ptr (* sb-alien:unsigned-long))) @@ -546,7 +544,7 @@ waiter)) ) ; progn -#+ecl +#+(and ecl win32) (progn (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () From ctian at common-lisp.net Wed Jul 7 09:05:21 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 07 Jul 2010 05:05:21 -0400 Subject: [usocket-cvs] r534 - usocket/trunk/backend Message-ID: Author: ctian Date: Wed Jul 7 05:05:20 2010 New Revision: 534 Log: SBCL: fix wrong call of wsa-enum-network-events. Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed Jul 7 05:05:20 2010 @@ -426,6 +426,11 @@ (defconstant fd-max-events 10) (defconstant fionread 1074030207) + ;; For WaitForSingleObject + (defconstant +wait-failed+ -1) ; #xffffffff + (defconstant +wait-object-0+ 0) + (defconstant +wait-timeout+ 258) + (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) (sb-alien:define-alien-type nil @@ -492,9 +497,8 @@ (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) - (maybe-wsa-error - (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000 timeout))) - wait-list)) + (let ((rv (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000000 timeout))))) + (format t "rv: ~A~%" rv))) (update-ready-and-state-slots (wait-list-waiters wait-list))) (defun map-network-events (func network-events) @@ -511,17 +515,16 @@ (listen (socket-stream socket))) (%ready-p socket)) (setf (state socket) :READ) - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0 t) ; ??? - (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)))))) + (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))))))) (defun %setup-wait-list (wait-list) (setf (wait-list-%wait wait-list) (wsa-event-create)) From ctian at common-lisp.net Wed Jul 7 10:18:11 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 07 Jul 2010 06:18:11 -0400 Subject: [usocket-cvs] r535 - in usocket/trunk: . backend Message-ID: Author: ctian Date: Wed Jul 7 06:18:09 2010 New Revision: 535 Log: SBCL: fix for ioctlsocket(). 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 Wed Jul 7 06:18:09 2010 @@ -427,9 +427,10 @@ (defconstant fionread 1074030207) ;; For WaitForSingleObject - (defconstant +wait-failed+ -1) ; #xffffffff - (defconstant +wait-object-0+ 0) - (defconstant +wait-timeout+ 258) + (eval-when (:compile-toplevel) + (defconstant +wait-failed+ -1) ; #xffffffff + (defconstant +wait-object-0+ 0) + (defconstant +wait-timeout+ 258)) (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) @@ -466,7 +467,7 @@ sb-alien:int (socket ws-socket) (cmd sb-alien:long) - (argp (* sb-alien::unsigned-long))) + (argp (* sb-alien:unsigned-long))) (defun raise-usock-err (errno socket) (error 'unknown-error @@ -480,26 +481,34 @@ (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))) - (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) - (prog1 - (if (= 0 rv) (sb-alien:deref int-ptr) 0) - (sb-alien:free-alien int-ptr))))) + (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) - (< 0 (bytes-available-for-read socket)) + (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) + (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))))) - (format t "rv: ~A~%" rv))) - (update-ready-and-state-slots (wait-list-waiters wait-list))) + (ecase rv + ((#.+wait-object-0+ #.+wait-timeout+) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + (#.+wait-failed+ + (raise-usock-err + (sb-win32::get-last-error-message (sb-win32::get-last-error)) + wait-list)))))) (defun map-network-events (func network-events) (let ((event-map (sb-alien:slot network-events 'network-events)) Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Jul 7 06:18:09 2010 @@ -311,13 +311,14 @@ (dolist (x (wait-list-waiters socket-or-sockets)) (when (setf (state x) (if (and (stream-usocket-p x) - (listen (socket-stream x))) + (listen (socket-stream x)) + #+(and sbcl win32) nil) ; TODO: bug?! :READ NIL)) (incf sockets-ready))) - ;; the internal routine is responsibe for - ;; making sure the wait doesn't block on socket-streams of - ;; which theready- socket isn't ready, but there's space left in the - ;; buffer + ;; the internal routine is responsibe for + ;; making sure the wait doesn't block on socket-streams of + ;; which theready- socket isn't ready, but there's space left in the + ;; buffer (wait-for-input-internal socket-or-sockets :timeout (if (zerop sockets-ready) timeout 0)) (let ((to-result (when timeout From ctian at common-lisp.net Wed Jul 7 10:21:55 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 07 Jul 2010 06:21:55 -0400 Subject: [usocket-cvs] r536 - usocket/trunk/backend Message-ID: Author: ctian Date: Wed Jul 7 06:21:55 2010 New Revision: 536 Log: SBCL: fix build due to references of compile-time constants. Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed Jul 7 06:21:55 2010 @@ -402,6 +402,12 @@ ;;; Based on LispWorks version written by Erik Huelsmann. #+(and sbcl win32) +(eval-when (:compile-toplevel) + (defconstant +wait-failed+ -1) ; #xffffffff + (defconstant +wait-object-0+ 0) + (defconstant +wait-timeout+ 258)) + +#+(and sbcl win32) (progn (defconstant fd-read 1) (defconstant fd-read-bit 0) @@ -426,12 +432,6 @@ (defconstant fd-max-events 10) (defconstant fionread 1074030207) - ;; For WaitForSingleObject - (eval-when (:compile-toplevel) - (defconstant +wait-failed+ -1) ; #xffffffff - (defconstant +wait-object-0+ 0) - (defconstant +wait-timeout+ 258)) - (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) (sb-alien:define-alien-type nil From ctian at common-lisp.net Fri Jul 9 07:26:49 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Fri, 09 Jul 2010 03:26:49 -0400 Subject: [usocket-cvs] r537 - usocket/trunk/backend Message-ID: Author: ctian Date: Fri Jul 9 03:26:48 2010 New Revision: 537 Log: ECL: wrong read macro fixed ... Modified: usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Fri Jul 9 03:26:48 2010 @@ -144,6 +144,7 @@ (with-mapped-conditions (usocket) (close (socket usocket)))) +;;; TODO: use send() if already connected. (defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) (with-mapped-conditions (usocket) (openmcl-socket:send-to (socket usocket) buffer length Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Jul 9 03:26:48 2010 @@ -556,7 +556,7 @@ waiter)) ) ; progn -#+(and ecl win32) +#-(and ecl win32) (progn (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () From ctian at common-lisp.net Fri Jul 9 08:38:33 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Fri, 09 Jul 2010 04:38:33 -0400 Subject: [usocket-cvs] r538 - in usocket/trunk: . backend vendor Message-ID: Author: ctian Date: Fri Jul 9 04:38:33 2010 New Revision: 538 Log: CCL: add support for SOCKET-SEND on connected usocket. Added: usocket/trunk/vendor/ccl-send.lisp (contents, props changed) Modified: usocket/trunk/backend/openmcl.lisp usocket/trunk/usocket.asd Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Fri Jul 9 04:38:33 2010 @@ -144,12 +144,14 @@ (with-mapped-conditions (usocket) (close (socket usocket)))) -;;; TODO: use send() if already connected. (defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) (with-mapped-conditions (usocket) - (openmcl-socket:send-to (socket usocket) buffer length - :remote-host (if host (host-to-hbo host)) - :remote-port port))) + (if (and host port) + (openmcl-socket:send-to (socket usocket) buffer length + :remote-host (host-to-hbo host) + :remote-port port) + ;; following functino was defined in "vendor/ccl-send.lisp" + (ccl::send-for-usocket (socket usocket) buffer length)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (with-mapped-conditions (usocket) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Fri Jul 9 04:38:33 2010 @@ -21,7 +21,8 @@ :components ((:file "package") (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") - #+mcl (:file "kqueue"))) + #+mcl (:file "kqueue") + #+clozure (:file "ccl-send"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition") Added: usocket/trunk/vendor/ccl-send.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/ccl-send.lisp Fri Jul 9 04:38:33 2010 @@ -0,0 +1,19 @@ +;;;; -*- Mode: Lisp -*- +;;;; $Id$ + +;;;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets. + +(in-package :ccl) + +(defun c_send-for-usocket (sockfd msgptr len flags) + (ignoring-eintr (check-socket-error (#_send sockfd msgptr len flags)))) + +(defun send-for-usocket (socket msg size &key offset) + "Send a UDP packet over a connected socket." + (let ((fd (socket-device socket))) + (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size)) + (%stack-block ((bufptr size)) + (%copy-ivector-to-ptr msg offset bufptr 0 size) + (socket-call socket "send" + (with-eagain fd :output + (c_send-for-usocket fd bufptr size 0)))))) From ctian at common-lisp.net Fri Jul 9 08:52:37 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Fri, 09 Jul 2010 04:52:37 -0400 Subject: [usocket-cvs] r539 - usocket/trunk/backend Message-ID: Author: ctian Date: Fri Jul 9 04:52:37 2010 New Revision: 539 Log: ECL: wrong read macro fixed ... again Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Jul 9 04:52:37 2010 @@ -556,7 +556,7 @@ waiter)) ) ; progn -#-(and ecl win32) +#+(and ecl (not win32)) (progn (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () From ctian at common-lisp.net Fri Jul 9 14:57:16 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Fri, 09 Jul 2010 10:57:16 -0400 Subject: [usocket-cvs] r540 - in usocket/trunk: backend test Message-ID: Author: ctian Date: Fri Jul 9 10:57:15 2010 New Revision: 540 Log: Tests: handle 'usocket:unsupported condition in tests. Modified: usocket/trunk/backend/openmcl.lisp usocket/trunk/test/test-usocket.lisp Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Fri Jul 9 10:57:15 2010 @@ -190,7 +190,6 @@ (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname (host-to-hostname name)))))) - (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) @@ -205,5 +204,5 @@ (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))) (input-available-p (wait-list-waiters wait-list) - (when timeout ticks-timeout)) + (when timeout ticks-timeout)) wait-list))) Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Fri Jul 9 10:57:15 2010 @@ -23,76 +23,79 @@ (defmacro with-caught-conditions ((expect throw) &body body) `(catch 'caught-error (handler-case - (progn , at body) - (usocket:unknown-error (c) (if (typep c ,expect) - (throw 'caught-error ,throw) - (progn - (describe c) - (describe - (usocket::usocket-real-error c)) - c))) - (error (c) (if (typep c ,expect) - (throw 'caught-error ,throw) - (progn - (describe c) - c))) - (usocket:unknown-condition (c) (if (typep c ,expect) - (throw 'caught-error ,throw) - (progn - (describe c) - (describe - (usocket::usocket-real-condition c)) - c))) - (condition (c) (if (typep c ,expect) - (throw 'caught-error ,throw) - (progn - (describe c) - c)))))) + (handler-bind ((usocket:unsupported + #'(lambda (c) + (declare (ignore c)) (continue)))) + (progn , at body)) + (usocket:unknown-error (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-error c)) + c))) + (error (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c))) + (usocket:unknown-condition (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-condition c)) + c))) + (condition (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c)))))) (deftest make-socket.1 (usocket:socket *fake-usocket*) :my-socket) (deftest make-socket.2 (usocket:socket-stream *fake-usocket*) :my-stream) (deftest socket-no-connect.1 - (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect "127.0.0.0" +unused-local-port+ :timeout 0) - t) + (with-caught-conditions (usocket:socket-error nil) + (usocket:socket-connect "127.0.0.0" +unused-local-port+ :timeout 1) + t) nil) (deftest socket-no-connect.2 - (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect #(127 0 0 0) +unused-local-port+ :timeout 0) + (with-caught-conditions (usocket:socket-error nil) + (usocket:socket-connect #(127 0 0 0) +unused-local-port+ :timeout 1) t) nil) (deftest socket-no-connect.3 - (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 0) ;; == #(127 0 0 0) + (with-caught-conditions (usocket:socket-error nil) + (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) t) nil) (deftest socket-failure.1 (with-caught-conditions (#-(or cmu lispworks armedbear openmcl mcl) - 'usocket:network-unreachable-error + usocket:network-unreachable-error #+(or cmu lispworks armedbear) - 'usocket:unknown-error + usocket:unknown-error #+(or openmcl mcl) - 'usocket:timeout-error + usocket:timeout-error nil) - (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 0) ;; == #(127 0 0 0) + (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) :unreach) nil) (deftest socket-failure.2 (with-caught-conditions (#+(or lispworks armedbear) - 'usocket:unknown-error + usocket:unknown-error #+cmu - 'usocket:network-unreachable-error + usocket:network-unreachable-error #+(or openmcl mcl) - 'usocket:timeout-error + usocket:timeout-error #-(or lispworks armedbear cmu openmcl mcl) - 'usocket:host-unreachable-error + usocket:host-unreachable-error nil) - (usocket:socket-connect +non-existing-host+ 80 :timeout 0) ;; 80 = just a port + (usocket:socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port :unreach) nil) From ctian at common-lisp.net Mon Jul 12 09:47:05 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 12 Jul 2010 05:47:05 -0400 Subject: [usocket-cvs] r541 - usocket/trunk Message-ID: Author: ctian Date: Mon Jul 12 05:47:05 2010 New Revision: 541 Log: Condition: ignore-unsupported-warnings Modified: usocket/trunk/condition.lisp Modified: usocket/trunk/condition.lisp ============================================================================== --- usocket/trunk/condition.lisp (original) +++ usocket/trunk/condition.lisp Mon Jul 12 05:47:05 2010 @@ -204,22 +204,17 @@ ((64 112) . host-down-error) ((65 113) . host-unreachable-error))) - (defun map-errno-condition (errno) (cdr (assoc errno +unix-errno-error-map+ :test #'member))) - (defun map-errno-error (errno) (cdr (assoc errno +unix-errno-error-map+ :test #'member))) - (defparameter +unix-ns-error-map+ `((1 . ns-host-not-found-error) (2 . ns-try-again-condition) (3 . ns-no-recovery-error))) - - (defmacro unsupported (feature context &key minimum) `(cerror "Ignore it and continue" 'unsupported :feature ,feature @@ -228,3 +223,11 @@ (defmacro unimplemented (feature context) `(signal 'unimplemented :feature ,feature :context ,context)) + + +;;; People may want to ignore all unsupported warnings, here it is. +(defmacro ignore-unsupported-warnings (&body body) + `(handler-bind ((unsupported + #'(lambda (c) + (declare (ignore c)) (continue)))) + (progn , at body))) From ctian at common-lisp.net Mon Jul 12 09:47:40 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 12 Jul 2010 05:47:40 -0400 Subject: [usocket-cvs] r542 - in usocket/trunk: . backend vendor Message-ID: Author: ctian Date: Mon Jul 12 05:47:40 2010 New Revision: 542 Log: Server: improved SOCKET-SERVER, for both TCP and UDP now. Added: usocket/trunk/vendor/spawn-thread.lisp (contents, props changed) Modified: usocket/trunk/backend/lispworks.lisp usocket/trunk/package.lisp usocket/trunk/server.lisp usocket/trunk/usocket.asd Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Mon Jul 12 05:47:40 2010 @@ -298,10 +298,10 @@ (:datagram (let ((usocket (make-datagram-socket (if (and host port) - (connect-to-udp-server host port - :local-address local-host + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) :local-port local-port) - (open-udp-socket :local-address local-host + (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) :local-port local-port)) :connected-p t))) (hcl:flag-special-free-action usocket) Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Mon Jul 12 05:47:40 2010 @@ -80,3 +80,19 @@ #:insufficient-implementation ; conditions regarding usocket support level #:unsupported #:unimplemented)) + +(in-package :usocket) + +;;; Logical Pathname Translations, learn from CL-HTTP source code +(eval-when (:load-toplevel :execute) + (let* ((defaults #+asdf (asdf:component-pathname (asdf:find-system :usocket)) + #-asdf *load-truename*) + (home (make-pathname :name :wild :type :wild + :directory (append (pathname-directory defaults) + '(:wild-inferiors)) + :host (pathname-host defaults) + :defaults defaults + :version :newest))) + (setf (logical-pathname-translations "usocket") + `(("**;*.*.newest" ,home) + ("**;*.*" ,home))))) Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Mon Jul 12 05:47:40 2010 @@ -3,43 +3,96 @@ (in-package :usocket) +(defun socket-server (host port function &optional arguments + &key in-new-thread (protocol :stream) + ;; for udp + (timeout 1) (max-buffer-size +max-datagram-packet-size+) + ;; for tcp + element-type reuse-address multi-threading) + (let* ((real-host (or host #(0 0 0 0))) + (socket (ecase protocol + (:stream + (apply #'socket-listen + `(,real-host ,port + ,@(when element-type `(:element-type ,element-type)) + ,@(when reuse-address `(:reuse-address ,reuse-address))))) + (:datagram + (socket-connect nil nil :protocol :datagram + :local-host real-host + :local-port port))))) + (labels ((real-call () + (ecase protocol + (:stream + (tcp-event-loop socket function arguments + :element-type element-type + :multi-threading multi-threading)) + (:datagram + (udp-event-loop socket function arguments + :timeout timeout + :max-buffer-size max-buffer-size))))) + (if in-new-thread + (spawn-thread "USOCKET Server" #'real-call) + (real-call))))) + (defvar *remote-host*) (defvar *remote-port*) -(defun socket-server (host port function &optional arguments - &key (timeout 1) - (max-buffer-size +max-datagram-packet-size+)) - (let ((socket (socket-connect nil nil - :protocol :datagram - :local-host host - :local-port port)) - (buffer (make-array max-buffer-size - :element-type '(unsigned-byte 8) - :initial-element 0))) +(defun default-udp-handler (buffer) ; echo + (declare (type (simple-array (unsigned-byte 8) *) buffer)) + buffer) + +(defun udp-event-loop (socket function &optional arguments + &key timeout max-buffer-size) + (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0)) + (sockets (list socket))) + (unwind-protect + (loop do + (multiple-value-bind (return-sockets real-time) + (wait-for-input sockets :timeout timeout) + (declare (ignore return-sockets)) + (when real-time + (multiple-value-bind (recv n *remote-host* *remote-port*) + (socket-receive socket buffer max-buffer-size) + (declare (ignore recv)) + (if (plusp n) + (progn + (let ((reply + (apply function (subseq buffer 0 n) arguments))) + (when reply + (replace buffer reply) + (let ((n (socket-send socket buffer (length reply) + :host *remote-host* + :port *remote-port*))) + (when (minusp n) + (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))) + +(defun default-tcp-handler (stream) ; null + (declare (type stream stream)) + (terpri stream)) + +(defun tcp-event-loop (socket function &optional arguments + &key element-type multi-threading) + (let ((real-function #'(lambda (client-socket &rest arguments) + (unwind-protect + (apply function (socket-stream client-socket) arguments) + (close (socket-stream client-socket)) + (socket-close client-socket))))) (unwind-protect - (loop (progn - (multiple-value-bind (sockets real-time) - (wait-for-input socket :timeout timeout) - (declare (ignore sockets)) - (when real-time - (multiple-value-bind (recv n *remote-host* *remote-port*) - (socket-receive socket buffer max-buffer-size) - (declare (ignore recv)) - (if (plusp n) - (progn - (let ((reply - (apply function - (cons (subseq buffer 0 n) arguments)))) - (when reply - (replace buffer reply) - (let ((n (socket-send socket buffer (length reply) - :host *remote-host* - :port *remote-port*))) - (when (minusp n) - (error "send error: ~A~%" n)))))) - (error "receive error: ~A" n)))) - #+scl (when thread:*quitting-lisp* - (return)) - #+(and cmu mp) (mp:process-yield)))) + (loop do + (let* ((client-socket (apply #'socket-accept + `(,socket ,@(when element-type `(:element-type ,element-type))))) + (client-stream (socket-stream client-socket))) + (if multi-threading + (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments) + (prog1 (apply real-function client-socket arguments) + (close client-stream) + (socket-close client-socket))) + #+scl (when thread:*quitting-lisp* (return)) + #+(and cmu mp) (mp:process-yield))) (socket-close socket) (values)))) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Mon Jul 12 05:47:40 2010 @@ -22,7 +22,8 @@ (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") #+mcl (:file "kqueue") - #+clozure (:file "ccl-send"))) + #+openmcl (:file "ccl-send") + (:file "spawn-thread"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition") Added: usocket/trunk/vendor/spawn-thread.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/spawn-thread.lisp Mon Jul 12 05:47:40 2010 @@ -0,0 +1,71 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; SPWAN-THREAD from GBBopen's PortableThreads.lisp + +(in-package :usocket) + +#+(and digitool ccl-5.1) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':digitool-mcl *features*)) + +;;; --------------------------------------------------------------------------- +;;; Add clozure feature to legacy OpenMCL: + +#+(and openmcl (not clozure)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':clozure *features*)) + +;;; =========================================================================== +;;; Features & warnings + +#+(or (and clisp (not mt)) + cormanlisp + (and cmu (not mp)) + (and ecl (not threads)) + gcl + (and sbcl (not sb-thread))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew ':threads-not-available *features*)) + +;;; --------------------------------------------------------------------------- + +#+threads-not-available +(defun threads-not-available (operation) + (warn "Threads are not available in ~a running on ~a; ~s was used." + (lisp-implementation-type) + (machine-type) + operation)) + +;;; =========================================================================== +;;; Spawn-Thread + +(defun spawn-thread (name function &rest args) + #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) + (declare (dynamic-extent args)) + #+allegro + (apply #'mp:process-run-function name function args) + #+(and clisp mt) + (mt:make-thread #'(lambda () (apply function args)) + :name name) + #+clozure + (apply #'ccl:process-run-function name function args) + #+(and cmu mp) + (mp:make-process #'(lambda () (apply function args)) + :name name) + #+digitool-mcl + (apply #'ccl:process-run-function name function args) + #+(and ecl threads) + (apply #'mp:process-run-function name function args) + #+lispworks + (apply #'mp:process-run-function name nil function args) + #+(and sbcl sb-thread) + (sb-thread:make-thread #'(lambda () (apply function args)) + :name name) + #+scl + (mp:make-process #'(lambda () (apply function args)) + :name name) + #+threads-not-available + (declare (ignore name function args)) + #+threads-not-available + (threads-not-available 'spawn-thread)) From ctian at common-lisp.net Mon Jul 12 15:46:52 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 12 Jul 2010 11:46:52 -0400 Subject: [usocket-cvs] r543 - usocket/trunk Message-ID: Author: ctian Date: Mon Jul 12 11:46:52 2010 New Revision: 543 Log: Fix build under Rosetta-based Macintosh Common Lisp (RMCL). Modified: usocket/trunk/package.lisp Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Mon Jul 12 11:46:52 2010 @@ -94,5 +94,4 @@ :defaults defaults :version :newest))) (setf (logical-pathname-translations "usocket") - `(("**;*.*.newest" ,home) - ("**;*.*" ,home))))) + `(("**;*.*" ,home))))) From ctian at common-lisp.net Mon Jul 12 16:40:19 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 12 Jul 2010 12:40:19 -0400 Subject: [usocket-cvs] r544 - usocket/trunk Message-ID: 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 - From ctian at common-lisp.net Thu Jul 15 06:02:17 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 15 Jul 2010 02:02:17 -0400 Subject: [usocket-cvs] r545 - in usocket/trunk: . backend Message-ID: 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 , at socket-connect-args)) - ,(if (null stream-var) - `(progn , at body) - `(let ((,stream-var (socket-stream ,socket-var))) - , at body)))) + ,(if (null stream-var) + `(progn , at body) + `(let ((,stream-var (socket-stream ,socket-var))) + , at 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) - , at body)) + , at 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 , at socket-listen-args)) - , at body)) - + , at 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 ;; From ctian at common-lisp.net Fri Jul 16 03:05:28 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 15 Jul 2010 23:05:28 -0400 Subject: [usocket-cvs] r546 - usocket/trunk/backend Message-ID: 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 From ctian at common-lisp.net Fri Jul 16 08:23:11 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Fri, 16 Jul 2010 04:23:11 -0400 Subject: [usocket-cvs] r547 - in usocket/trunk: backend test Message-ID: 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)) From ctian at common-lisp.net Mon Jul 19 11:49:58 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 19 Jul 2010 07:49:58 -0400 Subject: [usocket-cvs] r548 - in usocket/trunk: . backend Message-ID: 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 , 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" From ctian at common-lisp.net Mon Jul 19 13:55:24 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 19 Jul 2010 09:55:24 -0400 Subject: [usocket-cvs] r549 - usocket/trunk/backend Message-ID: 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 From ctian at common-lisp.net Tue Jul 20 04:25:43 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 20 Jul 2010 00:25:43 -0400 Subject: [usocket-cvs] r550 - in usocket/trunk: . backend vendor Message-ID: 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. From ctian at common-lisp.net Tue Jul 20 04:27:18 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 20 Jul 2010 00:27:18 -0400 Subject: [usocket-cvs] r551 - in usocket/trunk: . backend vendor Message-ID: 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 From ctian at common-lisp.net Tue Jul 20 04:29:48 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 20 Jul 2010 00:29:48 -0400 Subject: [usocket-cvs] r552 - in usocket/trunk: . backend test vendor Message-ID: 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) From ctian at common-lisp.net Tue Jul 20 05:48:39 2010 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 20 Jul 2010 01:48:39 -0400 Subject: [usocket-cvs] r553 - in usocket/trunk: . backend vendor Message-ID: 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 , 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))) - `(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))) - (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) - (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 () (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 , 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))) + `(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))) + (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) + (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))