From ctian at common-lisp.net Sat Dec 8 16:35:13 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sat, 08 Dec 2012 08:35:13 -0800 Subject: [usocket-cvs] r700 - in usocket/trunk: . backend Message-ID: 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)))) From ctian at common-lisp.net Sun Dec 9 10:02:24 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sun, 09 Dec 2012 02:02:24 -0800 Subject: [usocket-cvs] r701 - usocket/trunk/backend Message-ID: 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)) From ctian at common-lisp.net Sun Dec 9 10:05:50 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sun, 09 Dec 2012 02:05:50 -0800 Subject: [usocket-cvs] r702 - usocket/trunk Message-ID: 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: From ctian at common-lisp.net Sun Dec 9 12:53:52 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sun, 09 Dec 2012 04:53:52 -0800 Subject: [usocket-cvs] r703 - usocket/trunk/backend Message-ID: 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) From ctian at common-lisp.net Mon Dec 10 06:01:57 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Sun, 09 Dec 2012 22:01:57 -0800 Subject: [usocket-cvs] r704 - usocket/trunk/backend Message-ID: Author: ctian Date: Sun Dec 9 22:01:56 2012 New Revision: 704 Log: [ECL] Now ECL DFFI mode works for hunchentoot! Modified: usocket/trunk/backend/ecl.lisp Modified: usocket/trunk/backend/ecl.lisp ============================================================================== --- usocket/trunk/backend/ecl.lisp Sun Dec 9 04:53:52 2012 (r703) +++ usocket/trunk/backend/ecl.lisp Sun Dec 9 22:01:56 2012 (r704) @@ -27,7 +27,7 @@ (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-foreign-type ws-event :unsigned-int) (ffi:def-struct wsa-network-events (network-events :long) @@ -102,12 +102,12 @@ (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))) + (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events)) + (error-array (ffi:get-slot-pointer network-events 'wsa-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))))))) + (funcall func (ffi:deref-array error-array '(:array :int 10) i))))))) (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) From ctian at common-lisp.net Mon Dec 10 15:14:34 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Mon, 10 Dec 2012 07:14:34 -0800 Subject: [usocket-cvs] r705 - in usocket/trunk: . vendor Message-ID: Author: ctian Date: Mon Dec 10 07:14:33 2012 New Revision: 705 Log: [MCL] Add basic file framework for UDP support. Added: usocket/trunk/vendor/OpenTransportUDP.lisp (contents, props changed) Modified: usocket/trunk/usocket.asd Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd Sun Dec 9 22:01:56 2012 (r704) +++ usocket/trunk/usocket.asd Mon Dec 10 07:14:33 2012 (r705) @@ -16,6 +16,7 @@ (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") #+mcl (:file "kqueue") + #+mcl (:file "OpenTransportUDP") (:file "spawn-thread"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) Added: usocket/trunk/vendor/OpenTransportUDP.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ usocket/trunk/vendor/OpenTransportUDP.lisp Mon Dec 10 07:14:33 2012 (r705) @@ -0,0 +1,9 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;; +;;; OpenTransportUDP.lisp +;;; Copyright 2012 Chun Tian (binghe) + +;;; UDP extension to OpenTransport.lisp + +(in-package "CCL") + From ctian at common-lisp.net Tue Dec 11 06:24:48 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Mon, 10 Dec 2012 22:24:48 -0800 Subject: [usocket-cvs] r706 - in usocket/trunk: backend vendor Message-ID: Author: ctian Date: Mon Dec 10 22:24:47 2012 New Revision: 706 Log: [MCL] Fixed OpenTransport load order for UDP patch. Modified: usocket/trunk/backend/mcl.lisp usocket/trunk/vendor/OpenTransportUDP.lisp Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp Mon Dec 10 07:14:33 2012 (r705) +++ usocket/trunk/backend/mcl.lisp Mon Dec 10 22:24:47 2012 (r706) @@ -4,51 +4,6 @@ ;; MCL backend for USOCKET 0.4.1 ;; Terje Norderhaug , January 1, 2009 -(in-package :ccl) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :opentransport)) - -;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface -;; see http://code.google.com/p/mcl/issues/detail?id=28 for details - -(defparameter *passive-interface-address* NIL - "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream") - -(advise local-interface-ip-address - (or *passive-interface-address* (:do-it)) - :when :around :name 'override-local-interface-ip-address) - -;; MCL Issue 29: Passive TCP connections on OS assigned ports -;; see http://code.google.com/p/mcl/issues/detail?id=29 for details -(advise ot-conn-tcp-passive-connect - (destructuring-bind (conn port &optional (allow-reuse t)) arglist - (declare (ignore allow-reuse)) - (if (eql port #$kOTAnyInetAddress) - ;; Avoids registering a proxy for port 0 but instead registers one for the true port: - (multiple-value-bind (proxy result) - (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL - (result (:do-it)) ;; pushes onto *opentransport-class-proxies* - (proxy (prog1 - (pop *opentransport-class-proxies*) - (assert (not *opentransport-class-proxies*)))) - (context (cdr proxy)) - (tmpconn (make-ot-conn :context context - :endpoint (pref context :ot-context.ref))) - (localaddress (ot-conn-tcp-get-addresses tmpconn))) - (declare (dynamic-extent tmpconn)) - ;; replace original set in body of function - (setf (ot-conn-local-address conn) localaddress) - (values - (cons localaddress context) - result)) - ;; need to be outside local binding of *opentransport-class-proxies* - (without-interrupts - (push proxy *opentransport-class-proxies*)) - result) - (:do-it))) - :when :around :name 'ot-conn-tcp-passive-connect-any-address) - (in-package :usocket) (defun handle-condition (condition &optional socket) Modified: usocket/trunk/vendor/OpenTransportUDP.lisp ============================================================================== --- usocket/trunk/vendor/OpenTransportUDP.lisp Mon Dec 10 07:14:33 2012 (r705) +++ usocket/trunk/vendor/OpenTransportUDP.lisp Mon Dec 10 22:24:47 2012 (r706) @@ -1,9 +1,51 @@ ;;;-*-Mode: LISP; Package: CCL -*- ;; ;;; OpenTransportUDP.lisp -;;; Copyright 2012 Chun Tian (binghe) +;;; Copyright 2012 Chun Tian (binghe) -;;; UDP extension to OpenTransport.lisp +;;; UDP extension to OpenTransport.lisp (with some TCP patches) (in-package "CCL") +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :opentransport)) + +;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface +;; see http://code.google.com/p/mcl/issues/detail?id=28 for details + +(defparameter *passive-interface-address* NIL + "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream") + +(advise local-interface-ip-address + (or *passive-interface-address* (:do-it)) + :when :around :name 'override-local-interface-ip-address) + +;; MCL Issue 29: Passive TCP connections on OS assigned ports +;; see http://code.google.com/p/mcl/issues/detail?id=29 for details +(advise ot-conn-tcp-passive-connect + (destructuring-bind (conn port &optional (allow-reuse t)) arglist + (declare (ignore allow-reuse)) + (if (eql port #$kOTAnyInetAddress) + ;; Avoids registering a proxy for port 0 but instead registers one for the true port: + (multiple-value-bind (proxy result) + (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL + (result (:do-it)) ;; pushes onto *opentransport-class-proxies* + (proxy (prog1 + (pop *opentransport-class-proxies*) + (assert (not *opentransport-class-proxies*)))) + (context (cdr proxy)) + (tmpconn (make-ot-conn :context context + :endpoint (pref context :ot-context.ref))) + (localaddress (ot-conn-tcp-get-addresses tmpconn))) + (declare (dynamic-extent tmpconn)) + ;; replace original set in body of function + (setf (ot-conn-local-address conn) localaddress) + (values + (cons localaddress context) + result)) + ;; need to be outside local binding of *opentransport-class-proxies* + (without-interrupts + (push proxy *opentransport-class-proxies*)) + result) + (:do-it))) + :when :around :name 'ot-conn-tcp-passive-connect-any-address) From ctian at common-lisp.net Wed Dec 26 15:25:07 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 07:25:07 -0800 Subject: [usocket-cvs] r707 - in usocket/trunk: . backend Message-ID: Author: ctian Date: Wed Dec 26 07:25:06 2012 New Revision: 707 Log: Improved SOCKET-OPTION support (for LispWorks, ECL, ...) (preparing for release) Modified: usocket/trunk/CHANGES usocket/trunk/backend/lispworks.lisp usocket/trunk/option.lisp Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES Mon Dec 10 22:24:47 2012 (r706) +++ usocket/trunk/CHANGES Wed Dec 26 07:25:06 2012 (r707) @@ -2,9 +2,11 @@ * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. * 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. +* New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers now) +* Bugfix: [ECL] ECL now list sb-bsd-sockets as a dependency but relies on REQUIRE. (patched by Juanjo) +* Bugfix: [ABCL] Make USOCKET compile warning-free on ABCL again: MAKE-IMMEDIATE-OBJECT was deprecated a while ago in favor of 2 predefined constants. +* Bugfix: [LispWorks] remove redundant call to hcl:flag-special-free-action. (reported by Kamil Shakirov) +* Bugfix: [CLISP] improved HANDLE-CONDITION for more CLISP environments. 0.5.5: @@ -66,3 +68,4 @@ * New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide * New feature: Macintosh Common Lisp (MCL) support Datagram sockets (UDP) +* New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp Mon Dec 10 22:24:47 2012 (r706) +++ usocket/trunk/backend/lispworks.lisp Wed Dec 26 07:25:06 2012 (r707) @@ -155,7 +155,7 @@ seconds))) #-win32 -(defmethod get-socket-receive-timeout (socket-fd) +(defun get-socket-receive-timeout (socket-fd) "Get socket option: RCVTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) @@ -170,7 +170,7 @@ (float (+ tv-sec (/ tv-usec 1000000)))))) #+win32 -(defmethod get-socket-receive-timeout (socket-fd) +(defun get-socket-receive-timeout (socket-fd) "Get socket option: RCVTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout :int) @@ -789,3 +789,27 @@ waiter)) ) ; end of WIN32-block + +(defun set-socket-reuse-address (socket-fd reuse-address-p) + (declare (type integer socket-fd) + (type boolean reuse-address-p)) + (fli:with-dynamic-foreign-objects ((value :int)) + (setf (fli:dereference value) (if reuse-address-p 1 0)) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_so_reuseaddr* + (fli:copy-pointer value + :type '(:pointer :void)) + (fli:size-of :int))) + reuse-address-p))) + +(defun get-socket-reuse-address (socket-fd) + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((value :int) (len :int)) + (if (zerop (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_so_reuseaddr* + (fli:copy-pointer value + :type '(:pointer :void)) + len)) + (= 1 (fli:dereference value))))) Modified: usocket/trunk/option.lisp ============================================================================== --- usocket/trunk/option.lisp Mon Dec 10 22:24:47 2012 (r706) +++ usocket/trunk/option.lisp Wed Dec 26 07:25:06 2012 (r707) @@ -1,13 +1,17 @@ ;;;; $Id$ ;;;; $URL$ -;;;; SOCKET-OPTION, a high-level socket option get/set facility -;;;; Author: Chun Tian (binghe) +;;;; SOCKET-OPTION, a high-level socket option get/set framework ;;;; See LICENSE for licensing information. (in-package :usocket) +;;; Small utility functions +(declaim (inline bool->int) (inline int->bool)) +(defun bool->int (bool) (if bool 1 0)) +(defun int->bool (int) (= 1 int)) + ;;; Interface definition (defgeneric socket-option (socket option &key) @@ -62,7 +66,7 @@ #+sbcl (sb-impl::fd-stream-timeout (socket-stream usocket)) #+scl - ())) + ())) ; TODO (defmethod (setf socket-option) (new-value (usocket stream-usocket) (option (eql :receive-timeout)) &key) @@ -91,13 +95,9 @@ (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) (coerce timeout 'single-float)) #+scl - () + () ; TODO 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) @@ -106,25 +106,23 @@ (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl - () + () ; TODO #+allegro - () + () ; TODO #+clisp - (lisp<-c (socket:socket-options socket :so-reuseaddr)) + (int->bool (socket:socket-options socket :so-reuseaddr)) #+clozure - (lisp<-c (get-socket-option-reuseaddr socket)) + (int->bool (get-socket-option-reuseaddr socket)) #+cmu - () - #+ecl - () + () ; TODO #+lispworks - () + (get-socket-reuse-address socket) #+mcl - () - #+sbcl + () ; TODO + #+(or ecl sbcl) (sb-bsd-sockets:sockopt-reuse-address socket) #+scl - ())) + ())) ; TODO (defmethod (setf socket-option) (new-value (usocket stream-server-usocket) (option (eql :reuse-address)) &key) @@ -132,25 +130,23 @@ (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl - () - #+alloero - () + () ; TODO + #+allegro + (socket:set-socket-options socket option new-value) #+clisp - (socket:socket-options socket :so-reuseaddr (lisp->c new-value)) + (socket:socket-options socket :so-reuseaddr (bool->int new-value)) #+clozure - (set-socket-option-reuseaddr socket (lisp->c new-value)) + (set-socket-option-reuseaddr socket (bool->int new-value)) #+cmu - () - #+ecl - () + () ; TODO #+lispworks - () + (set-socket-reuse-address socket new-value) #+mcl - () - #+sbcl + () ; TODO + #+(or ecl sbcl) (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value) #+scl - () + () ; TODO new-value)) ;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client @@ -161,25 +157,23 @@ (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl - () - #+alloero - () + () ; TODO + #+allegro + () ; TODO #+clisp - (lisp<-c (socket:socket-options socket :so-broadcast)) + (int->bool (socket:socket-options socket :so-broadcast)) #+clozure - (lisp<-c (get-socket-option-broadcast socket)) + (int->bool (get-socket-option-broadcast socket)) #+cmu - () - #+ecl - () + () ; TODO #+lispworks - () + () ; TODO #+mcl - () - #+sbcl + () ; TODO + #+(or ecl sbcl) (sb-bsd-sockets:sockopt-broadcast socket) #+scl - ())) + ())) ; TODO (defmethod (setf socket-option) (new-value (usocket datagram-usocket) (option (eql :broadcast)) &key) @@ -187,23 +181,21 @@ (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl - () - #+alloero - () + () ; TODO + #+allegro + (socket:set-socket-options socket option new-value) #+clisp - (socket:socket-options socket :so-broadcast (lisp->c new-value)) + (socket:socket-options socket :so-broadcast (bool->int new-value)) #+clozure - (set-socket-option-broadcast socket (lisp->c new-value)) + (set-socket-option-broadcast socket (bool->int new-value)) #+cmu - () - #+ecl - () + () ; TODO #+lispworks - () + () ; TODO #+mcl - () - #+sbcl + () ; TODO + #+(or ecl sbcl) (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) #+scl - () + () ; TODO new-value)) From ctian at common-lisp.net Wed Dec 26 15:30:36 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 07:30:36 -0800 Subject: [usocket-cvs] r708 - usocket/tags/0.6.0 Message-ID: Author: ctian Date: Wed Dec 26 07:30:35 2012 New Revision: 708 Log: Created tag 0.6.0. Added: usocket/tags/0.6.0/ - copied from r707, usocket/trunk/ From ctian at common-lisp.net Wed Dec 26 15:47:32 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 07:47:32 -0800 Subject: [usocket-cvs] r709 - in public_html: . releases Message-ID: Author: ctian Date: Wed Dec 26 07:47:31 2012 New Revision: 709 Log: [release] usocket-0.6.0 Added: public_html/releases/usocket-0.6.0.tar.gz (contents, props changed) public_html/releases/usocket-0.6.0.tar.gz.asc Modified: public_html/index.shtml public_html/releases/usocket-latest.tar.gz public_html/releases/usocket-latest.tar.gz.asc Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Wed Dec 26 07:30:35 2012 (r708) +++ public_html/index.shtml Wed Dec 26 07:47:31 2012 (r709) @@ -29,10 +29,9 @@

Because trivial-sockets has been declared dead and its author has said he will declare usocket its successor if there is a zero effort path of migration, - I'm also - working - on trivial-usocket which is supposed to be a - sub-optimal, but zero effort migration from trivial-sockets.

+ I'm also working on trivial-usocket which is + supposed to be a sub-optimal, but zero effort migration from + trivial-sockets.

If your lisp isn't mentioned in the list below, please feel free to submit a request for it at the mailing list mentioned below.

Comparison to other socket libraries

@@ -51,6 +50,7 @@

Documentation

See the documentation page for the API + description.

Supported implementations

Currently these implementations are supported:

@@ -96,6 +96,7 @@

Active + development is taking place in the Subversion repository. To be kept up to date, please . To use the latest development version, make sure you have Subversion installed and execute this command:

@@ -141,6 +143,7 @@ +
Investigate + interfaces provided. DONE DONE @@ -232,6 +236,7 @@ Investigate + interfaces provided DONE DONE @@ -317,6 +322,7 @@ Investigate + interfaces provided DONE DONE @@ -375,6 +381,7 @@ Investigate + API's provided DONE DONE @@ -420,6 +427,15 @@ Summary + Dec 26, 2012
+ + 0.6.0
+ + New API: SOCKET-OPTION; Add support + for ECL DFFI mode; bugfix for LispWorks, CLISP, ABCL, ECL.
+ + + Feb 27, 2012
0.5.5
@@ -562,7 +578,7 @@ Dec 18, 2006 - 0.2.0 + 0.2.0 Add support for Scieneer Common Lisp, fix Back to + Common-lisp.net.
Valid XHTML 1.0 Added: public_html/releases/usocket-0.6.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/usocket-0.6.0.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/usocket-0.6.0.tar.gz.asc Wed Dec 26 07:47:31 2012 (r709) @@ -0,0 +1,8 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG/MacGPG2 v2.0.18 (Darwin) +Comment: GPGTools - http://gpgtools.org + +iEYEABECAAYFAlDbG8UACgkQny6v4+l8uLAyGQCfX1G3mHXTYTnvweG0nyppqmPQ +mD8An1ids1vVVVzcayOQQD0crsFKL8q3 +=CBJU +-----END PGP SIGNATURE----- Modified: public_html/releases/usocket-latest.tar.gz ============================================================================== --- public_html/releases/usocket-latest.tar.gz Wed Dec 26 07:30:35 2012 (r708) +++ public_html/releases/usocket-latest.tar.gz Wed Dec 26 07:47:31 2012 (r709) @@ -1 +1 @@ -link usocket-0.5.5.tar.gz \ No newline at end of file +link usocket-0.6.0.tar.gz \ No newline at end of file Modified: public_html/releases/usocket-latest.tar.gz.asc ============================================================================== --- public_html/releases/usocket-latest.tar.gz.asc Wed Dec 26 07:30:35 2012 (r708) +++ public_html/releases/usocket-latest.tar.gz.asc Wed Dec 26 07:47:31 2012 (r709) @@ -1 +1 @@ -link usocket-0.5.5.tar.gz.asc \ No newline at end of file +link usocket-0.6.0.tar.gz.asc \ No newline at end of file From ctian at common-lisp.net Thu Dec 27 03:13:05 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 19:13:05 -0800 Subject: [usocket-cvs] r710 - usocket/trunk Message-ID: Author: ctian Date: Wed Dec 26 19:13:03 2012 New Revision: 710 Log: [ECL] fixed compiling in ECL, there's no sb-bsd-sockets:sockopt-broadcast in ECL!!! Modified: usocket/trunk/option.lisp Modified: usocket/trunk/option.lisp ============================================================================== --- usocket/trunk/option.lisp Wed Dec 26 07:47:31 2012 (r709) +++ usocket/trunk/option.lisp Wed Dec 26 19:13:03 2012 (r710) @@ -166,11 +166,13 @@ (int->bool (get-socket-option-broadcast socket)) #+cmu () ; TODO + #+ecl + () ; TODO #+lispworks () ; TODO #+mcl () ; TODO - #+(or ecl sbcl) + #+sbcl (sb-bsd-sockets:sockopt-broadcast socket) #+scl ())) ; TODO @@ -190,11 +192,13 @@ (set-socket-option-broadcast socket (bool->int new-value)) #+cmu () ; TODO + #+ecl + () ; TODO #+lispworks () ; TODO #+mcl () ; TODO - #+(or ecl sbcl) + #+sbcl (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) #+scl () ; TODO From ctian at common-lisp.net Thu Dec 27 03:13:55 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 19:13:55 -0800 Subject: [usocket-cvs] r711 - usocket/tags/0.6.0.1 Message-ID: Author: ctian Date: Wed Dec 26 19:13:54 2012 New Revision: 711 Log: Created tag 0.6.0.1. Added: usocket/tags/0.6.0.1/ - copied from r710, usocket/trunk/ From ctian at common-lisp.net Thu Dec 27 03:16:07 2012 From: ctian at common-lisp.net (ctian at common-lisp.net) Date: Wed, 26 Dec 2012 19:16:07 -0800 Subject: [usocket-cvs] r712 - public_html/releases Message-ID: Author: ctian Date: Wed Dec 26 19:16:06 2012 New Revision: 712 Log: [release] usocket-0.6.0.1 Added: public_html/releases/usocket-0.6.0.1.tar.gz (contents, props changed) public_html/releases/usocket-0.6.0.1.tar.gz.asc Modified: public_html/releases/usocket-latest.tar.gz public_html/releases/usocket-latest.tar.gz.asc Added: public_html/releases/usocket-0.6.0.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/usocket-0.6.0.1.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/usocket-0.6.0.1.tar.gz.asc Wed Dec 26 19:16:06 2012 (r712) @@ -0,0 +1,8 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG/MacGPG2 v2.0.18 (Darwin) +Comment: GPGTools - http://gpgtools.org + +iEYEABECAAYFAlDbvWAACgkQny6v4+l8uLADQwCePofB6O4uVSe0r8+O8k42RwOH +a2cAoMyOeNRMZiph3AcSpF5tWwU7CsmW +=G038 +-----END PGP SIGNATURE----- Modified: public_html/releases/usocket-latest.tar.gz ============================================================================== --- public_html/releases/usocket-latest.tar.gz Wed Dec 26 19:13:54 2012 (r711) +++ public_html/releases/usocket-latest.tar.gz Wed Dec 26 19:16:06 2012 (r712) @@ -1 +1 @@ -link usocket-0.6.0.tar.gz \ No newline at end of file +link usocket-0.6.0.1.tar.gz \ No newline at end of file Modified: public_html/releases/usocket-latest.tar.gz.asc ============================================================================== --- public_html/releases/usocket-latest.tar.gz.asc Wed Dec 26 19:13:54 2012 (r711) +++ public_html/releases/usocket-latest.tar.gz.asc Wed Dec 26 19:16:06 2012 (r712) @@ -1 +1 @@ -link usocket-0.6.0.tar.gz.asc \ No newline at end of file +link usocket-0.6.0.1.tar.gz.asc \ No newline at end of file