usocket-cvs March 2011

usocket-cvs@common-lisp.net

2 participants
53 discussions

[usocket-cvs] r597 - usocket/branches/0.5.x/backend
by Chun Tian 29 Mar '11

29 Mar '11

Author: ctian Date: Tue Mar 29 09:01:08 2011 New Revision: 597 Log: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. Modified: usocket/branches/0.5.x/backend/cmucl.lisp Modified: usocket/branches/0.5.x/backend/cmucl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/cmucl.lisp (original) +++ usocket/branches/0.5.x/backend/cmucl.lisp Tue Mar 29 09:01:08 2011 @@ -106,7 +106,7 @@ (with-mapped-conditions (socket) (ext:create-inet-socket protocol))))) (if socket - (let ((usocket (make-datagram-socket socket))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) usocket) @@ -159,9 +159,28 @@ (defmethod socket-close :after ((socket datagram-usocket)) (setf (%open-p socket) nil)) +#+unicode +(defun %unix-send (fd buffer length flags) + (alien:alien-funcall + (alien:extern-alien "send" + (function c-call:int + c-call:int + system:system-area-pointer + c-call:int + c-call:int)) + fd + (system:vector-sap buffer) + length + flags)) + (defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) (with-mapped-conditions (usocket) - (ext:inet-sendto (socket usocket) buffer length (if host (host-to-hbo host)) port))) + (if (and host port) + (ext:inet-sendto (socket usocket) buffer length (host-to-hbo host) port) + #-unicode + (unix:unix-send (socket usocket) buffer length 0) + #+unicode + (%unix-send (socket usocket) buffer length 0)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (let ((real-buffer (or buffer

1 0

[usocket-cvs] r596 - usocket/branches/0.5.x/backend
by Chun Tian 29 Mar '11

29 Mar '11

Author: ctian Date: Tue Mar 29 07:49:05 2011 New Revision: 596 Log: [SBCL] switch to a async unwind safe version of %WITH-TIMEOUT (Nikodemus Siivola) Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Tue Mar 29 07:49:05 2011 @@ -210,21 +210,42 @@ (close stream) stream)) -;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads. -;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29 +;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch +;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS +;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than +;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus(a)random-state.net> #+sbcl -(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body) - (let ((tag-sym (gensym)) - (timer-sym (gensym))) - `(block ,tag-sym - (let ((,timer-sym - (sb-ext:make-timer - #'(lambda () - (return-from ,tag-sym (progn ,@timeout-body)))))) - (sb-ext:schedule-timer ,timer-sym ,seconds) - (unwind-protect (progn ,@timed-body) - (sb-ext:unschedule-timer ,timer-sym)))))) +(defmacro %with-timeout ((seconds timeout-form) &body body) + "Runs BODY as an implicit PROGN with timeout of SECONDS. If +timeout occurs before BODY has finished, BODY is unwound and +TIMEOUT-FORM is executed with its values returned instead. + +Note that BODY is unwound asynchronously when a timeout occurs, +so unless all code executed during it -- including anything +down the call chain -- is asynch unwind safe, bad things will +happen. Use with care." + (let ((exec (gensym)) (unwind (gensym)) (timer (gensym)) + (timeout (gensym)) (block (gensym))) + `(block ,block + (tagbody + (flet ((,unwind () + (go ,timeout)) + (,exec () + ,@body)) + (declare (dynamic-extent #',exec #',unwind)) + (let ((,timer (sb-ext:make-timer #',unwind))) + (declare (dynamic-extent ,timer)) + (sb-sys:without-interrupts + (unwind-protect + (progn + (sb-ext:schedule-timer ,timer ,seconds) + (return-from ,block + (sb-sys:with-local-interrupts + (,exec)))) + (sb-ext:unschedule-timer ,timer))))) + ,timeout + (return-from ,block ,timeout-form))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified)

1 0

[usocket-cvs] r595 - usocket/branches/0.5.x
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 19:22:25 2011 New Revision: 595 Log: Update ChangeLog Modified: usocket/branches/0.5.x/CHANGES Modified: usocket/branches/0.5.x/CHANGES ============================================================================== --- usocket/branches/0.5.x/CHANGES (original) +++ usocket/branches/0.5.x/CHANGES Mon Mar 28 19:22:25 2011 @@ -5,3 +5,18 @@ * Add WAIT-FOR-INPUT support for SBCL and ECL on win32. * Simple TCP and UDP server API: SOCKET-SERVER * Lots of bug fixed since 0.4.1 + +0.5.1: + +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko <anton(a)sw4me.com> +* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. +* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". +* Enhancement: [LispWorks] Better network error type detection on LispWorks. + +[TODO] + +* Bugfix: now SOCKET-CONNECT/Datagram works on CLISP +* New feature: CLISP support UDP without RAWSOCK (using FFI interface) +* 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)

1 0

[usocket-cvs] r594 - usocket/branches/0.5.x/backend
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 19:09:39 2011 New Revision: 594 Log: [SBCL] change the use of WITH-TIMEOUT into a nested version for safe purpose. Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 19:09:39 2011 @@ -210,6 +210,22 @@ (close stream) stream)) +;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads. +;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29 + +#+sbcl +(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body) + (let ((tag-sym (gensym)) + (timer-sym (gensym))) + `(block ,tag-sym + (let ((,timer-sym + (sb-ext:make-timer + #'(lambda () + (return-from ,tag-sym (progn ,@timeout-body)))))) + (sb-ext:schedule-timer ,timer-sym ,seconds) + (unwind-protect (progn ,@timed-body) + (sb-ext:unschedule-timer ,timer-sym)))))) + (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port @@ -254,7 +270,7 @@ (labels ((connect () (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) (if timeout - (sb-ext:with-timeout timeout (connect)) + (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) (connect))) #+ecl (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port)

1 0

[usocket-cvs] r593 - usocket/branches/0.5.x/backend
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 19:02:54 2011 New Revision: 593 Log: Fixed for ECL (always forget this) Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 19:02:54 2011 @@ -250,11 +250,14 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) + #+sbcl (labels ((connect () (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) (if timeout (sb-ext:with-timeout timeout (connect)) (connect))) + #+ecl + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket

1 0

[usocket-cvs] r592 - usocket/branches/0.5.x/backend
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 14:30:35 2011 New Revision: 592 Log: [LispWorks] Detect networking error types by (LW:ERRNO-VALUE). Modified: usocket/branches/0.5.x/backend/lispworks.lisp Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Mon Mar 28 14:30:35 2011 @@ -9,7 +9,7 @@ (require "comm") #+lispworks3 - (error "LispWorks 3 is not supported by USOCKET.")) + (error "LispWorks 3 is not supported by USOCKET any more.")) ;;; --------------------------------------------------------------------------- ;;; Warn if multiprocessing is not running on Lispworks @@ -40,17 +40,15 @@ #+win32 "ws2_32") (defun get-host-name () - (multiple-value-bind (retcode name) + (multiple-value-bind (return-code name) (get-host-name-internal) - (when (= 0 retcode) + (when (zerop return-code) name))) #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) - (cons (mapcar #'(lambda (y) - (+ 10000 y)) - (car x)) + (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) (cdr x))) z)) @@ -62,7 +60,7 @@ (append +unix-errno-condition-map+ +unix-errno-error-map+)) -(defun raise-or-signal-socket-error (errno socket) +(defun raise-usock-err (errno socket &optional condition) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) (if usock-err @@ -71,27 +69,13 @@ (signal usock-err :socket socket)) (error 'unknown-error :socket socket - :real-error nil)))) - -(defun raise-usock-err (errno socket &optional condition) - (let* ((usock-err - (cdr (assoc errno +lispworks-error-map+ - :test #'member)))) - (if usock-err - (if (subtypep usock-err 'error) - (error usock-err :socket socket) - (signal usock-err :socket)) - (error 'unknown-error - :socket socket :real-error condition)))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (typecase condition - (simple-error (destructuring-bind (&optional host port err-msg errno) - (simple-condition-format-arguments condition) - (declare (ignore host port err-msg)) - (raise-usock-err errno socket condition))))) + (condition (let ((errno (lispworks:errno-value))) + (raise-usock-err errno socket condition))))) (defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.") @@ -294,17 +278,20 @@ (if stream (make-stream-socket :socket (comm:socket-stream-socket stream) :stream stream) - (error 'unknown-error)))) + ;; 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) - (connect-to-udp-server (host-to-hostname host) port - :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout) - (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout)) + (with-mapped-conditions () + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout)) + (with-mapped-conditions () + (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) usocket))))

1 0

[usocket-cvs] r591 - usocket/branches/0.5.x/test
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 14:28:19 2011 New Revision: 591 Log: [test] Try to produce same detailed error type on all platforms Modified: usocket/branches/0.5.x/test/test-usocket.lisp Modified: usocket/branches/0.5.x/test/test-usocket.lisp ============================================================================== --- usocket/branches/0.5.x/test/test-usocket.lisp (original) +++ usocket/branches/0.5.x/test/test-usocket.lisp Mon Mar 28 14:28:19 2011 @@ -74,27 +74,13 @@ nil) (deftest socket-failure.1 - (with-caught-conditions (#-(or cmu lispworks armedbear openmcl mcl) - usocket:network-unreachable-error - #+(or cmu lispworks armedbear) - usocket:unknown-error - #+(or openmcl mcl) - usocket:timeout-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (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 - #+cmu - usocket:network-unreachable-error - #+(or openmcl mcl) - usocket:timeout-error - #-(or lispworks armedbear cmu openmcl mcl) - usocket:host-unreachable-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port :unreach) nil)

1 0

[usocket-cvs] r590 - in usocket/branches/0.5.x: . test
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 13:37:31 2011 New Revision: 590 Log: Clean-up useless test help files, never figure out how to use them... Removed: usocket/branches/0.5.x/Makefile usocket/branches/0.5.x/run-usocket-tests.sh usocket/branches/0.5.x/test/abcl.conf.in usocket/branches/0.5.x/test/allegro.conf.in usocket/branches/0.5.x/test/clisp.conf.in usocket/branches/0.5.x/test/cmucl.conf.in usocket/branches/0.5.x/test/sbcl.conf.in usocket/branches/0.5.x/test/your-lisp.conf.in

1 0

[usocket-cvs] r589 - usocket/branches/0.5.x/backend
by Chun Tian 28 Mar '11

28 Mar '11

Author: ctian Date: Mon Mar 28 13:23:37 2011 New Revision: 589 Log: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 13:23:37 2011 @@ -173,6 +173,8 @@ (sb-bsd-sockets:operation-timeout-error . timeout-error) #-ecl (sb-sys:io-timeout . timeout-error) + #+sbcl + (sb-ext:timeout . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error @@ -248,15 +250,17 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) + (labels ((connect () + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) + (if timeout + (sb-ext:with-timeout timeout (connect)) + (connect))) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :full - #+sbcl #+sbcl - :timeout timeout :element-type element-type)))) (:datagram (when (or local-host local-port) @@ -317,6 +321,7 @@ ;; next time wait for event again if we had EAGAIN/EINTR ;; or else we'd enter a tight loop of failed accepts + #+win32 (setf (%ready-p socket) nil))))) ;; Sockets and their associated streams are modelled as

1 0

[usocket-cvs] r588 - usocket/branches/0.5.x/backend
by Chun Tian 22 Mar '11

22 Mar '11

Author: ctian Date: Mon Mar 21 21:46:46 2011 New Revision: 588 Log: Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko <anton(a)sw4me.com> Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 21 21:46:46 2011 @@ -199,6 +199,10 @@ (if usock-cond (signal usock-cond :socket socket)))))) +;;; "The socket stream ends up with a bogus name as it is created before +;;; the socket is connected, making things harder to debug than they need +;;; to be." -- Nikodemus Siivola <nikodemus(a)random-state.net> + (defvar *dummy-stream* (let ((stream (make-broadcast-stream))) (close stream) @@ -291,16 +295,29 @@ (sb-bsd-sockets:socket-close sock) (error c))))) +;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR, +;;; instead of raising a condition. It's always possible for +;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket +;;; was detected to be ready: connection might be reset, for example. +;;; +;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to +;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton(a)sw4me.com> + (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (with-mapped-conditions (socket) - (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) - (make-stream-socket - :socket sock - :stream (sb-bsd-sockets:socket-make-stream - sock - :input t :output t :buffering :full - :element-type (or element-type - (element-type socket))))))) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (if sock + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket)))) + + ;; next time wait for event again if we had EAGAIN/EINTR + ;; or else we'd enter a tight loop of failed accepts + (setf (%ready-p socket) nil))))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which @@ -448,7 +465,15 @@ #+(and sbcl win32) (progn - (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) + ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET + ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It + ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED, + ;; which is always machine word-sized (exactly as intptr_t; + ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not + ;; enough -- potentially)." + ;; -- Anton Kovalenko <anton(a)sw4me.com>, Mar 22, 2011 + (sb-alien:define-alien-type ws-socket sb-alien:signed) + (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) (sb-alien:define-alien-type ws-event sb-alien::hinstance) @@ -556,13 +581,33 @@ (defun (setf os-wait-list-%wait) (value wait-list) (setf (sb-alien:deref (wait-list-%wait wait-list)) value)) + ;; "Event handles are leaking in current SBCL backend implementation, + ;; because of SBCL-unfriendly usage of finalizers. + ;; + ;; "SBCL never calls a finalizer that closes over a finalized object: a + ;; reference from that closure prevents its collection forever. That's + ;; the case with USOCKET in %SETUP-WAIT-LIST. + ;; + ;; "I use the following redefinition of %SETUP-WAIT-LIST: + ;; + ;; "Of course it may be rewritten with more clarity, but you can see the + ;; core idea: I'm closing over those components of WAIT-LIST that I need + ;; for finalization, not the wait-list itself. With the original + ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted + ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST." + ;; + ;; -- Anton Kovalenko <anton(a)sw4me.com>, Mar 22, 2011 + (defun %setup-wait-list (wait-list) (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 (os-wait-list-%wait wait-list)) - (sb-alien:free-alien (wait-list-%wait wait-list)))))) + (let ((event-handle (os-wait-list-%wait wait-list)) + (alien (wait-list-%wait wait-list))) + #'(lambda () + (wsa-event-close event-handle) + (unless (null alien) + (sb-alien:free-alien alien)))))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

usocket-cvs March 2011