- usocket-cvs@common-lisp.net - mailman3.common-lisp.net

[usocket-cvs] r703 - usocket/trunk/backend
by ctian＠common-lisp.net 09 Dec '12

09 Dec '12

Author: ctian Date: Sun Dec 9 04:53:52 2012 New Revision: 703 Log: [ECL] Fixed compilation. Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp Sun Dec 9 02:05:24 2012 (r702) +++ usocket/trunk/backend/sbcl.lisp Sun Dec 9 04:53:52 2012 (r703) @@ -485,11 +485,13 @@ ;;; Based on LispWorks version written by Erik Huelsmann. #+win32 ; shared by ECL and SBCL -(progn +(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +wsa-wait-failed+ #xffffffff) (defconstant +wsa-wait-event-0+ 0) - (defconstant +wsa-wait-timeout+ 258) + (defconstant +wsa-wait-timeout+ 258)) +#+win32 ; shared by ECL and SBCL +(progn (defconstant fd-read 1) (defconstant fd-read-bit 0) (defconstant fd-write 2)

1 0

[usocket-cvs] r702 - usocket/trunk
by ctian＠common-lisp.net 09 Dec '12

09 Dec '12

Author: ctian Date: Sun Dec 9 02:05:24 2012 New Revision: 702 Log: Update CHANGES Modified: usocket/trunk/CHANGES Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES Sun Dec 9 02:02:09 2012 (r701) +++ usocket/trunk/CHANGES Sun Dec 9 02:05:24 2012 (r702) @@ -1,8 +1,9 @@ 0.6.0: * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. -* New feature: [UDP] SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. +* New feature: SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. * New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. +* New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers) * Enhancement: [ECL] ECL now list sb-bsd-sockets as a dependency, but rather relies on REQUIRE. Patched from Juanjo. 0.5.5:

1 0

[usocket-cvs] r701 - usocket/trunk/backend
by ctian＠common-lisp.net 09 Dec '12

09 Dec '12

Author: ctian Date: Sun Dec 9 02:02:09 2012 New Revision: 701 Log: [ECL] Add WAIT-FOR-INPUT support for ECL DFFI mode. Modified: usocket/trunk/backend/ecl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/ecl.lisp ============================================================================== --- usocket/trunk/backend/ecl.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/ecl.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -13,75 +13,142 @@ #+(and ecl-bytecmp windows) (progn + (ffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int + :module "ws2_32") + + (defun get-host-name () + "Returns the hostname" + (ffi:with-foreign-object (name '(:array :unsigned-char 256)) + (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) + (ffi:convert-from-foreign-string name)))) + + (ffi:def-foreign-type ws-socket :unsigned-int) + (ffi:def-foreign-type ws-dword :unsigned-long) + (ffi:def-foreign-type ws-event :pointer-void) + + (ffi:def-struct wsa-network-events + (network-events :long) + (error-code (:array :int 10))) + + (ffi:def-function ("WSACreateEvent" wsa-event-create) + () + :returning ws-event + :module "ws2_32") + + (ffi:def-function ("WSACloseEvent" c-wsa-event-close) + ((event-object ws-event)) + :returning :int + :module "ws2_32") + + (defun wsa-event-close (ws-event) + (not (zerop (c-wsa-event-close ws-event)))) + + (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) + ((socket ws-socket) + (event-object ws-event) + (network-events (* wsa-network-events))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAEventSelect" wsa-event-select) + ((socket ws-socket) + (event-object ws-event) + (network-events :long)) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) + ((number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p :int) + (timeout ws-dword) + (alertable-p :int)) + :returning ws-dword + :module "ws2_32") + + (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) + (c-wsa-wait-for-multiple-events number-of-events + events + (if wait-all-p -1 0) + timeout + (if alertable-p -1 0))) + + (ffi:def-function ("ioctlsocket" wsa-ioctlsocket) + ((socket ws-socket) + (cmd :long) + (argp (* :unsigned-long))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAGetLastError" wsa-get-last-error) + () + :returning :int + :module "ws2_32") + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (wsa-get-last-error) socket))) + + (defun bytes-available-for-read (socket) + (ffi:with-foreign-object (int-ptr :unsigned-long) + (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr) + socket) + (let ((int (ffi:deref-pointer int-ptr :unsigned-long))) + (prog1 int + (when (plusp int) + (setf (state socket) :read)))))) + + (defun map-network-events (func network-events) + (let ((event-map (ffi:get-slot-value network-events 'network-events)) + (error-array (ffi:get-slot-pointer network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (ffi:deref-array error-array :int i))))))) + + (defun update-ready-and-state-slots (sockets) + (dolist (socket sockets) + (if (%ready-p socket) + (progn + (setf (state socket) :READ)) + (ffi:with-foreign-object (network-events 'wsa-network-events) + (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events))) + (if (zerop rv) + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (progn + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket))))))) + + (defun os-wait-list-%wait (wait-list) + (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event)) + + (defun (setf os-wait-list-%wait) (value wait-list) + (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value)) + + (defun free-wait-list (wl) + (when (wait-list-p wl) + (unless (null (wait-list-%wait wl)) + (wsa-event-close (os-wait-list-%wait wl)) + (ffi:free-foreign-object (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil)))) + + (defun %setup-wait-list (wait-list) + (setf (wait-list-%wait wait-list) + (ffi:allocate-foreign-object 'ws-event)) + (setf (os-wait-list-%wait wait-list) + (wsa-event-create)) + (ext:set-finalizer wait-list #'free-wait-list)) -(ffi:def-function ("gethostname" c-gethostname) - ((name (* :unsigned-char)) - (len :int)) - :returning :int - :module "ws2_32") - -(defun get-host-name () - "Returns the hostname" - (ffi:with-foreign-object (name '(:array :unsigned-char 256)) - (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) - (ffi:convert-from-foreign-string name)))) - -(ffi:def-foreign-type ws-socket :signed) -(ffi:def-foreign-type ws-dword :unsigned-long) -(ffi:def-foreign-type ws-event :pointer-void) - -(ffi:def-struct wsa-network-events - (network-events :long) - (error-code (:array :int 10))) - -(ffi:def-function ("WSACreateEvent" wsa-event-create) - () - :returning ws-event - :module "ws2_32") - -(ffi:def-function ("WSACloseEvent" c-wsa-event-close) - ((event-object ws-event)) - :returning :int - :module "ws2_32") - -(defun wsa-event-close (ws-event) - (not (zerop (c-wsa-event-close ws-event)))) - -(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) - ((socket ws-socket) - (event-object ws-event) - (network-events (* wsa-network-events))) - :returning :int - :module "ws2_32") - -(ffi:def-function ("WSAEventSelect" wsa-event-select) - ((socket ws-socket) - (event-object ws-event) - (network-events :long)) - :returning :int - :module "ws2_32") - -(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) - ((number-of-events ws-dword) - (events (* ws-event)) - (wait-all-p :int) - (timeout ws-dword) - (alertable-p :int)) - :returning ws-dword - :module "ws2_32") - -(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) - (c-wsa-wait-for-multiple-events number-of-events - events - (if wait-all-p -1 0) - timeout - (if alertable-p -1 0))) - -(ffi:def-function ("ioctlsocket" wsa-ioctlsocket) - ((socket ws-socket) - (cmd :long) - (argp (* :unsigned-long))) - :returning :int - :module "ws2_32") + (defun os-socket-handle (usocket) + (socket-handle usocket)) ) ; #+(and ecl-bytecmp windows) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/lispworks.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -764,7 +764,8 @@ (defun free-wait-list (wl) (when (wait-list-p wl) (unless (null (wait-list-%wait wl)) - (wsa-event-close (wait-list-%wait wl))))) + (wsa-event-close (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil)))) (eval-when (:load-toplevel :execute) (hcl:add-special-free-action 'free-wait-list)) Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/sbcl.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -525,6 +525,36 @@ (defun waiting-required (sockets) (notany #'socket-ready-p sockets)) + + (defun raise-usock-err (errno &optional socket) + (error 'unknown-error + :socket socket + :real-error errno)) + + (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) + nil (truncate (* 1000 timeout)) nil))) + (ecase rv + ((#.+wsa-wait-event-0+) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + ((#.+wsa-wait-timeout+)) ; do nothing here + ((#.+wsa-wait-failed+) + (maybe-wsa-error rv)))))) + + (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 + (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) (os-wait-list-%wait wait-list) 0) + waiter)) ) ; progn #+(and sbcl win32) @@ -579,11 +609,6 @@ (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))) @@ -599,19 +624,6 @@ (when (plusp int-ptr) (setf (state socket) :read))))) - (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) - nil (truncate (* 1000 timeout)) nil))) - (ecase rv - ((#.+wsa-wait-event-0+) - (update-ready-and-state-slots (wait-list-waiters wait-list))) - ((#.+wsa-wait-timeout+)) ; do nothing here - ((#.+wsa-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)) (error-array (sb-alien:slot network-events 'error-code))) @@ -674,19 +686,6 @@ (unless (null alien) (sb-alien:free-alien alien)))))) - (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 - (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) (os-wait-list-%wait wait-list) 0) - waiter)) ) ; progn #+(and ecl (not win32))

1 0

[usocket-cvs] r700 - in usocket/trunk: . backend
by ctian＠common-lisp.net 08 Dec '12

08 Dec '12

Author: ctian Date: Sat Dec 8 08:35:12 2012 New Revision: 700 Log: [ECL] Add the framework for ECL DFFI support Added: usocket/trunk/backend/ecl.lisp (contents, props changed) Modified: usocket/trunk/backend/sbcl.lisp usocket/trunk/usocket.asd Added: usocket/trunk/backend/ecl.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ usocket/trunk/backend/ecl.lisp Sat Dec 8 08:35:12 2012 (r700) @@ -0,0 +1,87 @@ +;;;; -*- Mode: Lisp -*- +;;;; $Id$ +;;;; $URL$ + +;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only. +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+(and ecl-bytecmp windows) +(eval-when (:load-toplevel :execute) + (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32")) + +#+(and ecl-bytecmp windows) +(progn + +(ffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int + :module "ws2_32") + +(defun get-host-name () + "Returns the hostname" + (ffi:with-foreign-object (name '(:array :unsigned-char 256)) + (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) + (ffi:convert-from-foreign-string name)))) + +(ffi:def-foreign-type ws-socket :signed) +(ffi:def-foreign-type ws-dword :unsigned-long) +(ffi:def-foreign-type ws-event :pointer-void) + +(ffi:def-struct wsa-network-events + (network-events :long) + (error-code (:array :int 10))) + +(ffi:def-function ("WSACreateEvent" wsa-event-create) + () + :returning ws-event + :module "ws2_32") + +(ffi:def-function ("WSACloseEvent" c-wsa-event-close) + ((event-object ws-event)) + :returning :int + :module "ws2_32") + +(defun wsa-event-close (ws-event) + (not (zerop (c-wsa-event-close ws-event)))) + +(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) + ((socket ws-socket) + (event-object ws-event) + (network-events (* wsa-network-events))) + :returning :int + :module "ws2_32") + +(ffi:def-function ("WSAEventSelect" wsa-event-select) + ((socket ws-socket) + (event-object ws-event) + (network-events :long)) + :returning :int + :module "ws2_32") + +(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) + ((number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p :int) + (timeout ws-dword) + (alertable-p :int)) + :returning ws-dword + :module "ws2_32") + +(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) + (c-wsa-wait-for-multiple-events number-of-events + events + (if wait-all-p -1 0) + timeout + (if alertable-p -1 0))) + +(ffi:def-function ("ioctlsocket" wsa-ioctlsocket) + ((socket ws-socket) + (cmd :long) + (argp (* :unsigned-long))) + :returning :int + :module "ws2_32") + +) ; #+(and ecl-bytecmp windows) Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp Sat Nov 17 17:44:09 2012 (r699) +++ usocket/trunk/backend/sbcl.lisp Sat Dec 8 08:35:12 2012 (r700) @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp -*- ;;;; $Id$ ;;;; $URL$ @@ -26,7 +27,7 @@ (when (= result 0) (sb-alien:cast buf sb-alien:c-string)))))) -#+ecl +#+(and ecl (not ecl-bytecmp)) (progn #-:wsock (ffi:clines @@ -548,10 +549,6 @@ (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create) 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) (boolean #.sb-vm::n-machine-word-bits) (event-object ws-event)) @@ -716,7 +713,7 @@ (declare (ignore wl w))) ) ; progn -#+(and ecl win32) +#+(and ecl win32 (not ecl-bytecmp)) (progn (defun maybe-wsa-error (rv &optional syscall) (unless (zerop rv) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd Sat Nov 17 17:44:09 2012 (r699) +++ usocket/trunk/usocket.asd Sat Dec 8 08:35:12 2012 (r700) @@ -16,20 +16,22 @@ (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") #+mcl (:file "kqueue") - (:file "spawn-thread"))) - (:file "usocket" :depends-on ("vendor")) - (:file "condition" :depends-on ("usocket")) + (:file "spawn-thread"))) + (:file "usocket" :depends-on ("vendor")) + (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition") :components (#+abcl (:file "abcl") #+clisp (:file "clisp") #+cmu (:file "cmucl") #+scl (:file "scl") - #+(or sbcl ecl) (:file "sbcl") + #+ecl (:file "ecl") + #+(or sbcl ecl) (:file "sbcl" + :depends-on (#+ecl "ecl")) #+lispworks (:file "lispworks") #+mcl (:file "mcl") #+openmcl (:file "openmcl") #+allegro (:file "allegro"))) - (:file "option" :depends-on ("backend")) + (:file "option" :depends-on ("backend")) (:file "server" :depends-on ("backend" "option")))) (defmethod perform ((op test-op) (c (eql (find-system :usocket))))

1 0

[usocket-cvs] r699 - in usocket/trunk: . backend
by ctian＠common-lisp.net 18 Nov '12

18 Nov '12

Author: ctian Date: Sat Nov 17 17:44:09 2012 New Revision: 699 Log: [ECL] now list sb-bsd-sockets as a dependency, but rather relies on REQUIRE. Patched from Juanjo <juanjose.garciaripoll(a)gmail.com> Modified: usocket/trunk/CHANGES usocket/trunk/backend/sbcl.lisp (contents, props changed) usocket/trunk/usocket.asd (contents, props changed) Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES Sat Nov 10 08:15:14 2012 (r698) +++ usocket/trunk/CHANGES Sat Nov 17 17:44:09 2012 (r699) @@ -3,6 +3,7 @@ * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. * New feature: [UDP] SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. * New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. +* Enhancement: [ECL] ECL now list sb-bsd-sockets as a dependency, but rather relies on REQUIRE. Patched from Juanjo. 0.5.5: Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp Sat Nov 10 08:15:14 2012 (r698) +++ usocket/trunk/backend/sbcl.lisp Sat Nov 17 17:44:09 2012 (r699) @@ -5,14 +5,6 @@ (in-package :usocket) -;; There's no way to preload the sockets library other than by requiring it -;; -;; ECL sockets has been forked off sb-bsd-sockets and implements the -;; same interface. We use the same file for now. -#+ecl -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :sockets)) - #+sbcl (progn #-win32 Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd Sat Nov 10 08:15:14 2012 (r698) +++ usocket/trunk/usocket.asd Sat Nov 17 17:44:09 2012 (r699) @@ -11,7 +11,7 @@ :version "0.6.0" :licence "MIT" :description "Universal socket library for Common Lisp" - :depends-on (#+sbcl :sb-bsd-sockets) + :depends-on (#+(or sbcl ecl) :sb-bsd-sockets) :components ((:file "package") (:module "vendor" :depends-on ("package") :components ((:file "split-sequence")

1 0

[usocket-cvs] r698 - usocket/trunk
by ctian＠common-lisp.net 10 Nov '12

10 Nov '12

Author: ctian Date: Sat Nov 10 08:15:14 2012 New Revision: 698 Log: Update CHANGES Modified: usocket/trunk/CHANGES Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES Sat Nov 10 08:14:33 2012 (r697) +++ usocket/trunk/CHANGES Sat Nov 10 08:15:14 2012 (r698) @@ -2,9 +2,12 @@ * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. * New feature: [UDP] SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. -* (on the way) New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. -* Enhancement: SOCKET-CONNECT argument :nodelay now support :if-supported as value (patch from Anton Vodonosov). -* Enhancement: Add *remote-host* *remote-port* to SOCKET-SERVER stream handler (suggested by Matthew Curry). +* New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. + +0.5.5: + +* Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov). +* Enhancement: [Server] adding *remote-host* *remote-port* to socket-server stream handler functions (suggested by Matthew Curry) * Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard by Martin Simmons). * Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard). * Bugfix: [LispWorks] Fixed SOCKET-CONNECT on Windows, now LOCAL-PORT never have *auto-port* (0) as default value.

1 0

[usocket-cvs] r697 - in usocket/trunk: . backend
by ctian＠common-lisp.net 10 Nov '12

10 Nov '12

Author: ctian Date: Sat Nov 10 08:14:33 2012 New Revision: 697 Log: Add basic support of SO_BROADCAST and SO_REUSEADDR for SOCKET-OPTION Modified: usocket/trunk/backend/openmcl.lisp usocket/trunk/option.lisp Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp Sat Nov 10 07:24:33 2012 (r696) +++ usocket/trunk/backend/openmcl.lisp Sat Nov 10 08:14:33 2012 (r697) @@ -222,3 +222,20 @@ (input-available-p (wait-list-waiters wait-list) (when timeout ticks-timeout)) wait-list))) + +;;; Helper functions for option.lisp +(defun get-socket-option-reuseaddr (socket) + (ccl::int-getsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_REUSEADDR)) + +(defun set-socket-option-reuseaddr (socket value) + (ccl::int-setsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_REUSEADDR value)) + +(defun get-socket-option-broadcast (socket) + (ccl::int-getsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_BROADCAST)) + +(defun set-socket-option-broadcast (socket value) + (ccl::int-setsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_BROADCAST value)) Modified: usocket/trunk/option.lisp ============================================================================== --- usocket/trunk/option.lisp Sat Nov 10 07:24:33 2012 (r696) +++ usocket/trunk/option.lisp Sat Nov 10 08:14:33 2012 (r697) @@ -36,12 +36,11 @@ (declare (ignore new-value)) (socket-option socket option)) -;;; Option: RECEIVE-TIMEOUT (RCVTIMEO) -;;; Scope: TCP & UDP +;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO) (defmethod socket-option ((usocket stream-usocket) (option (eql :receive-timeout)) &key) - (declare (ignore option)) + (declare (ignorable option)) (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl @@ -67,8 +66,7 @@ (defmethod (setf socket-option) (new-value (usocket stream-usocket) (option (eql :receive-timeout)) &key) - (declare (type number new-value) - (ignore option)) + (declare (type number new-value) (ignorable new-value option)) (let ((socket (socket usocket)) (timeout new-value)) (declare (ignorable socket timeout)) @@ -95,3 +93,117 @@ #+scl () new-value)) + +(declaim (inline lisp->c) (inline lisp<-c)) +(defun lisp->c (bool) (if bool 1 0)) +(defun lisp<-c (int) (= 1 int)) + +;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server + +(defmethod socket-option ((usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () + #+allegro + () + #+clisp + (lisp<-c (socket:socket-options socket :so-reuseaddr)) + #+clozure + (lisp<-c (get-socket-option-reuseaddr socket)) + #+cmu + () + #+ecl + () + #+lispworks + () + #+mcl + () + #+sbcl + (sb-bsd-sockets:sockopt-reuse-address socket) + #+scl + ())) + +(defmethod (setf socket-option) (new-value (usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () + #+alloero + () + #+clisp + (socket:socket-options socket :so-reuseaddr (lisp->c new-value)) + #+clozure + (set-socket-option-reuseaddr socket (lisp->c new-value)) + #+cmu + () + #+ecl + () + #+lispworks + () + #+mcl + () + #+sbcl + (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value) + #+scl + () + new-value)) + +;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client + +(defmethod socket-option ((usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () + #+alloero + () + #+clisp + (lisp<-c (socket:socket-options socket :so-broadcast)) + #+clozure + (lisp<-c (get-socket-option-broadcast socket)) + #+cmu + () + #+ecl + () + #+lispworks + () + #+mcl + () + #+sbcl + (sb-bsd-sockets:sockopt-broadcast socket) + #+scl + ())) + +(defmethod (setf socket-option) (new-value (usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () + #+alloero + () + #+clisp + (socket:socket-options socket :so-broadcast (lisp->c new-value)) + #+clozure + (set-socket-option-broadcast socket (lisp->c new-value)) + #+cmu + () + #+ecl + () + #+lispworks + () + #+mcl + () + #+sbcl + (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) + #+scl + () + new-value))

1 0

[usocket-cvs] r696 - usocket/trunk/backend
by ctian＠common-lisp.net 10 Nov '12

10 Nov '12

Author: ctian Date: Sat Nov 10 07:24:33 2012 New Revision: 696 Log: [CLISP] improved HANDLE-CONDITION for CLISP Modified: usocket/trunk/backend/clisp.lisp Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp Sat Nov 10 07:22:25 2012 (r695) +++ usocket/trunk/backend/clisp.lisp Sat Nov 10 07:24:33 2012 (r696) @@ -93,17 +93,17 @@ "Dispatch correct usocket condition." (let (error-keyword error-string) (typecase condition - #+ffi ; because OS:ERRNO and OS:STRERROR is only present if FFI is present. - (system::simple-os-error + (ext:os-error (let ((errno (car (simple-condition-format-arguments condition)))) + #+ffi (setq error-keyword (os:errno errno) error-string (os:strerror errno)))) - #+ffi ; because OS:ERRNO and OS:STRERROR is only present if FFI is present. (simple-error (let ((keyword (car (simple-condition-format-arguments condition)))) - (setq error-keyword keyword - error-string (os:strerror keyword)))) + (setq error-keyword keyword) + #+ffi + (setq error-string (os:strerror keyword)))) (error (error 'unknown-error :real-error condition)) (condition (signal 'unknown-condition :real-condition condition))) (when error-keyword

1 0

[usocket-cvs] r695 - usocket/trunk/backend
by ctian＠common-lisp.net 10 Nov '12

10 Nov '12

Author: ctian Date: Sat Nov 10 07:22:25 2012 New Revision: 695 Log: Merge r692 from 0.5.x branch Modified: usocket/trunk/backend/lispworks.lisp (contents, props changed) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp Sat Aug 18 14:04:22 2012 (r694) +++ usocket/trunk/backend/lispworks.lisp Sat Nov 10 07:22:25 2012 (r695) @@ -313,29 +313,29 @@ (ecase protocol (:stream (let ((hostname (host-to-hostname host)) - (stream)) + (stream)) (setf stream - (with-mapped-conditions () - (comm:open-tcp-stream hostname port - :element-type element-type - #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 - #-(and lispworks4 (not lispworks4.4)) - :timeout timeout - #-lispworks4 #-lispworks4 - #-lispworks4 #-lispworks4 - :local-address (when local-host (host-to-hostname local-host)) - :local-port local-port - #-(or lispworks4 lispworks5.0) ; >= 5.1 - #-(or lispworks4 lispworks5.0) - :nodelay nodelay))) + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type + #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 + #-(and lispworks4 (not lispworks4.4)) + :timeout timeout + #-lispworks4 #-lispworks4 + #-lispworks4 #-lispworks4 + :local-address (when local-host (host-to-hostname local-host)) + :local-port local-port + #-(or lispworks4 lispworks5.0) ; >= 5.1 + #-(or lispworks4 lispworks5.0) + :nodelay nodelay))) (if stream - (make-stream-socket :socket (comm:socket-stream-socket stream) - :stream stream) + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout (error 'timeout-error)))) (:datagram (let ((usocket (make-datagram-socket - (if (and host port) + (if (and host port) (with-mapped-conditions () (connect-to-udp-server (host-to-hostname host) port :local-address (and local-host (host-to-hostname local-host)) @@ -345,8 +345,7 @@ (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) :local-port local-port :read-timeout timeout))) - :connected-p (and host port t)))) - (hcl:flag-special-free-action usocket) + :connected-p (and host port t)))) usocket)))) (defun socket-listen (host port

1 0

[usocket-cvs] r694 - usocket/branches/0.5.x/backend
by ehuelsmann＠common-lisp.net 18 Aug '12

18 Aug '12

Author: ehuelsmann Date: Sat Aug 18 14:04:22 2012 New Revision: 694 Log: Backport r693 from trunk to the 0.5.x release branch. Modified: usocket/branches/0.5.x/backend/abcl.lisp Modified: usocket/branches/0.5.x/backend/abcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/abcl.lisp Sat Aug 18 13:59:33 2012 (r693) +++ usocket/branches/0.5.x/backend/abcl.lisp Sat Aug 18 14:04:22 2012 (r694) @@ -116,8 +116,6 @@ (defvar $+op-read (jfield $*SelectionKey "OP_READ")) (defvar $+op-write (jfield $*SelectionKey "OP_WRITE")) -(defconstant +java-true+ (make-immediate-object t :boolean)) -(defconstant +java-false+ (make-immediate-object nil :boolean)) ;;; Wrapper functions (return-type: java-object) (defun %get-address (address) @@ -212,8 +210,8 @@ (setq stream (ext:get-socket-stream socket :element-type element-type) usocket (make-stream-socket :stream stream :socket socket)) (when nodelay-supplied-p - (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean +java-true+ - +java-true+ +java-false+))) + (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+ + java:+true+ java:+false+))) (when timeout (jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout)))))) (:datagram ; UDP @@ -245,7 +243,7 @@ (channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel)) (socket (jcall $@socket/ServerSocketChannel/0 channel)) (endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0)))) - (jcall $@setReuseAddress/1 socket (if reuseaddress +java-true+ +java-false+)) + (jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+)) (with-mapped-conditions (socket) (if backlog-supplied-p (jcall $@bind/ServerSocket/2 socket endpoint backlog) @@ -399,7 +397,7 @@ (unwind-protect (with-mapped-conditions () (dolist (channel channels) - (jcall $@configureBlocking/1 channel +java-false+) + (jcall $@configureBlocking/1 channel java:+false+) (jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel)))) (let ((ready-count (if timeout (jcall $@select/1 selector (truncate (* timeout 1000))) @@ -414,7 +412,7 @@ (setf (state (gethash channel %wait)) :read))))))) (jcall $@close/Selector/0 selector) (dolist (channel channels) - (jcall $@configureBlocking/1 channel +java-true+))))) + (jcall $@configureBlocking/1 channel java:+true+))))) ;;; WAIT-LIST

1 0