[usocket-cvs] r614 - in usocket/trunk: . backend test vendor

Author: ctian Date: Wed Mar 30 04:16:10 2011 New Revision: 614

Log: Merge all changes since 0.5.0 from branch 0.5.x (r583-r611)

Added: usocket/trunk/test/test-datagram.lisp - copied unchanged from r613, /usocket/branches/0.5.x/test/test-datagram.lisp Removed: usocket/trunk/Makefile usocket/trunk/run-usocket-tests.sh usocket/trunk/test/abcl.conf.in usocket/trunk/test/allegro.conf.in usocket/trunk/test/clisp.conf.in usocket/trunk/test/cmucl.conf.in usocket/trunk/test/sbcl.conf.in usocket/trunk/test/your-lisp.conf.in Modified: usocket/trunk/CHANGES usocket/trunk/backend/allegro.lisp usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/backend/scl.lisp usocket/trunk/server.lisp usocket/trunk/test/test-condition.lisp usocket/trunk/test/test-usocket.lisp usocket/trunk/usocket-test.asd usocket/trunk/usocket.lisp usocket/trunk/vendor/spawn-thread.lisp

Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES (original) +++ usocket/trunk/CHANGES Wed Mar 30 04:16:10 2011 @@ -5,3 +5,22 @@ * 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: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions! +* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko anton@sw4me.com +* 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". +* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. +* Bugfix: [LispWorks] Better network error type detection on LispWorks. +* Bugfix: [CLISP] Fixed UDP (Datagram) support (RAWSOCK version), confirmed by CL-NET-SNMP. +* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode. +* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. + +[TODO] + +* 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)

Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Wed Mar 30 04:16:10 2011 @@ -90,7 +90,7 @@ (:stream (make-stream-socket :socket socket :stream socket)) (:datagram - (make-datagram-socket socket))))) + (make-datagram-socket socket :connected-p (and host port t))))))

;; One socket close method is sufficient, ;; because socket-streams are also sockets.

Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Wed Mar 30 04:16:10 2011 @@ -5,9 +5,15 @@

(in-package :usocket)

+(eval-when (:compile-toplevel :load-toplevel :execute) + #-ffi + (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.") + #-(or ffi rawsock) + (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support.")) + ;; utility routine for looking up the current host name #+ffi -(FFI:DEF-CALL-OUT get-host-name-internal +(ffi:def-call-out get-host-name-internal (:name "gethostname") (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) :OUT :ALLOCA) @@ -27,6 +33,17 @@ #-ffi "localhost")

+(defun get-host-by-address (address) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) + (posix:hostent-name hostent)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr name))) + (mapcar #'host-to-vector-quad + (posix:hostent-addr-list hostent))))) + #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) @@ -61,26 +78,34 @@ timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) - (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) - (when local-host (unsupported 'local-host 'socket-connect)) - (when local-port (unsupported 'local-port 'socket-connect)) - - (let ((socket) - (hostname (host-to-hostname host))) - (with-mapped-conditions (socket) - (setf socket - (if timeout - (socket:socket-connect port hostname - :element-type element-type - :buffered t - :timeout timeout) - (socket:socket-connect port hostname - :element-type element-type - :buffered t)))) - (make-stream-socket :socket socket - :stream socket))) ;; the socket is a stream too + (case protocol + (:stream + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (if timeout + (socket:socket-connect port hostname + :element-type element-type + :buffered t + :timeout timeout) + (socket:socket-connect port hostname + :element-type element-type + :buffered t)))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + (:datagram + #+rawsock + (socket-create-datagram (or local-port *auto-port*) + :local-host (or local-host *wildcard-host*) + :remote-host host + :remote-port port) + #+(and ffi (not rawsock)) + () + #-(or rawsock ffi) + (unsupported '(protocol :datagram) 'socket-connect))))

(defun socket-listen (host port &key reuseaddress @@ -146,7 +171,6 @@ (defmethod get-peer-port ((usocket stream-usocket)) (nth-value 1 (get-peer-name usocket)))

- (defun %setup-wait-list (wait-list) (declare (ignore wait-list)))

@@ -176,21 +200,19 @@ (setf (state x) :READ))) wait-list))))

- -;; -;; UDP/Datagram sockets! -;; +;;; +;;; UDP/Datagram sockets (RAWSOCK version) +;;;

#+rawsock (progn - (defun make-sockaddr_in () (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))

(declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr_in ip port) - (port-to-octet-buffer sockaddr_in port) - (ip-to-octet-buffer sockaddr_in ip :start 2) + (port-to-octet-buffer port sockaddr_in) + (ip-to-octet-buffer ip sockaddr_in :start 2) sockaddr_in)

(defun socket-create-datagram (local-port @@ -204,58 +226,158 @@ (fill-sockaddr_in (make-sockaddr_in) remote-host (or remote-port local-port))))) - (bind sock lsock_addr) + (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) (when rsock_addr - (connect sock rsock_addr)) + (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr))) (make-datagram-socket sock :connected-p (if rsock_addr t nil))))

- (defun socket-receive (socket buffer &key (size (length buffer))) + (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) - (sockaddr (when (not (connected-p socket)) - (rawsock:make-sockaddr))) + (sockaddr (unless (connected-p socket) + (rawsock:make-sockaddr :inet))) (rv (if sockaddr - (rawsock:recvfrom sock buffer sockaddr - :start 0 - :end size) - (rawsock:recv sock buffer - :start 0 - :end size)))) - (values buffer - rv - (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4) - (port-from-octet-buffer (sockaddr-data sockaddr) 2))))) + (rawsock:recvfrom sock buffer sockaddr :start 0 :end length) + (rawsock:recv sock buffer :start 0 :end length))) + (host 0) (port 0)) + (unless (connected-p socket) + (let ((data (rawsock:sockaddr-data sockaddr))) + (setq host (ip-from-octet-buffer data :start 4) + port (port-from-octet-buffer data :start 2)))) + (values buffer rv host port)))

- (defun socket-send (socket buffer &key address (size (length buffer))) + (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) "Returns the number of octets sent." (let* ((sock (socket socket)) - (sockaddr (when address - (rawsock:make-sockaddr :INET + (sockaddr (when (and host port) + (rawsock:make-sockaddr :inet (fill-sockaddr_in (make-sockaddr_in) - (host-byte-order - (second address)) - (first address))))) - (rv (if address + (host-byte-order host) + port)))) + (rv (if (and host port) (rawsock:sendto sock buffer sockaddr :start 0 - :end size) + :end length) (rawsock:send sock buffer :start 0 - :end size)))) + :end length)))) rv))

(defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket))) - - ) +) ; progn + +;;; +;;; UDP/Datagram sockets (FFI version) +;;;

-#-rawsock +#+(and ffi (not rawsock)) (progn - (warn "This image doesn't contain the RAWSOCK package. -To enable UDP socket support, please be sure to use the -Kfull parameter -at startup, or to enable RAWSOCK support during compilation.") - ) + ;; C primitive types + (ffi:def-c-type size_t) + (ffi:def-c-type in_addr_t ffi:uint32) + (ffi:def-c-type in_port_t ffi:uint16) + (ffi:def-c-type sa_family_t ffi:uint8) + (ffi:def-c-type socklen_t ffi:uint32) + + ;; C structures + (ffi:def-c-struct sockaddr + (sa_len ffi:uint8) + (sa_family sa_family_t) + (sa_data (ffi:c-array ffi:char 14))) + + #+ignore + (ffi:def-c-struct in_addr + (s_addr in_addr_t)) + + (ffi:def-c-struct sockaddr_in + (sin_len ffi:uint8) + (sin_family sa_family_t) + (sin_port in_port_t) + (sin_addr in_addr_t) ; should be struct in_addr + (sin_zero (ffi:c-array ffi:char 8))) + + (ffi:def-c-struct timeval + (tv_sec ffi:long) + (tv_usec ffi:long)) + + ;; foreign functions + (ffi:def-call-out %sendto (:name "sendto") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8)) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr)) + (address-len ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %recvfrom (:name "recvfrom") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8) :out) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr) :out) + (address-len (ffi:c-ptr ffi:int) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %socket (:name "socket") + (:arguments (family ffi:int) + (type ffi:int) + (protocol ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getsockopt (:name "getsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen (ffi:c-ptr socklen_t) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %setsockopt (:name "setsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + ;; socket constants + (defconstant +socket-af-inet+ 2) + (defconstant +socket-pf-unspec+ 0) + (defconstant +socket-sock-dgram+ 2) + (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") + + (defun open-udp-socket (&key local-address local-port read-timeout) + "Open a unconnected UDP socket. For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), +for binding on random free unused port, set LOCAL-PORT to 0." + (let ((socket-fd (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-pf-unspec+))) + (if socket-fd + (progn + ) + (error "cannot create socket")))) +) ; progn

Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Wed Mar 30 04:16:10 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

Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Wed Mar 30 04:16:10 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,33 +69,20 @@ (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 #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) + (raise-usock-err errno socket condition)))))

(defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.")

(defconstant *sockopt_so_rcvtimeo* - #+(not linux) #x1006 + #-linux #x1006 #+linux 20 "Socket receive timeout")

@@ -294,18 +279,21 @@ (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)) - :connected-p t))) + (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))))

Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Wed Mar 30 04:16:10 2011 @@ -97,20 +97,22 @@ :deadline deadline :nodelay nodelay :connect-timeout timeout))) - (openmcl-socket:socket-connect mcl-sock) (make-stream-socket :stream mcl-sock :socket mcl-sock))) (:datagram - (let ((mcl-sock - (openmcl-socket:make-socket :address-family :internet - :type :datagram - :local-host (when local-host (host-to-hostname local-host)) - :local-port local-port - :format :binary))) + (let* ((mcl-sock + (openmcl-socket:make-socket :address-family :internet + :type :datagram + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :input-timeout timeout + :format :binary)) + (usocket (make-datagram-socket mcl-sock))) (when (and host port) (ccl::inet-connect (ccl::socket-device mcl-sock) (ccl::host-as-inet-host host) (ccl::port-as-inet-port port "udp"))) - (make-datagram-socket mcl-sock)))))) + (setf (connected-p usocket) t) + usocket)))))

(defun socket-listen (host port &key reuseaddress

Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed Mar 30 04:16:10 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 @@ -199,11 +201,52 @@ (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@random-state.net + (defvar *dummy-stream* (let ((stream (make-broadcast-stream))) (close stream) stream))

+;;; 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@random-state.net + +#+sbcl +(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) local-host local-port @@ -226,7 +269,6 @@ :protocol (case protocol (:stream :tcp) (:datagram :udp)))) - (ip (host-to-vector-quad host)) (local-host (host-to-vector-quad (or local-host *wildcard-host*))) (local-port (or local-port *auto-port*)) usocket ok) @@ -245,15 +287,20 @@ (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 ip port) + #+sbcl + (labels ((connect () + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) + (if timeout + (%with-timeout (timeout (error 'sb-ext: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 :input t :output t :buffering :full - #+sbcl #+sbcl - :timeout timeout :element-type element-type)))) (:datagram (when (or local-host local-port) @@ -264,7 +311,7 @@ (setf usocket (make-datagram-socket socket)) (when (and host port) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port) + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) (setf (connected-p usocket) t))))) (setf ok t)) ;; Clean up in case of an error. @@ -292,16 +339,30 @@ (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@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 + #+win32 + (setf (%ready-p socket) nil)))))

;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which @@ -449,7 +510,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@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)

@@ -557,13 +626,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@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

Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Wed Mar 30 04:16:10 2011 @@ -82,7 +82,7 @@ (host-to-hbo local-host))))) (with-mapped-conditions () (ext:create-inet-socket protocol))))) - (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))))

Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Wed Mar 30 04:16:10 2011 @@ -31,8 +31,8 @@ :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread - (spawn-thread "USOCKET Server" #'real-call) - (real-call))))) + (values (spawn-thread "USOCKET Server" #'real-call) socket) + (real-call)))))

(defvar *remote-host*) (defvar *remote-port*)

Modified: usocket/trunk/test/test-condition.lisp ============================================================================== --- usocket/trunk/test/test-condition.lisp (original) +++ usocket/trunk/test/test-condition.lisp Wed Mar 30 04:16:10 2011 @@ -11,7 +11,7 @@

(deftest timeout-error.1 (with-caught-conditions (usocket:timeout-error nil) - (usocket:socket-connect "common-lisp.net" 81 :timeout 1) + (usocket:socket-connect "common-lisp.net" 81 :timeout 0) t) nil)

Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Wed Mar 30 04:16:10 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)

Modified: usocket/trunk/usocket-test.asd ============================================================================== --- usocket/trunk/usocket-test.asd (original) +++ usocket/trunk/usocket-test.asd Wed Mar 30 04:16:10 2011 @@ -22,11 +22,11 @@ :depends-on (:usocket :rt) :components ((:module "test" + :serial t :components ((:file "package") - (:file "test-usocket" - :depends-on ("package")) - (:file "test-condition" - :depends-on ("test-usocket")))))) + (:file "test-usocket") + (:file "test-condition") + (:file "test-datagram")))))

(defmethod perform ((op test-op) (c (eql (find-system :usocket-test)))) (funcall (intern "DO-TESTS" "USOCKET-TEST")))

Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Mar 30 04:16:10 2011 @@ -367,16 +367,16 @@ (aref buffer b)))))

(defmacro port-to-octet-buffer (port buffer &key (start 0)) - `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + `(integer-to-octet-buffer ,port ,buffer 2 :start ,start))

(defmacro ip-to-octet-buffer (ip buffer &key (start 0)) - `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start))

(defmacro port-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 2 ,start)) + `(octet-buffer-to-integer ,buffer 2 :start ,start))

(defmacro ip-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 4 ,start)) + `(octet-buffer-to-integer ,buffer 4 :start ,start))

;; ;; IP(v4) utility functions @@ -470,43 +470,41 @@ ;; DNS helper functions ;;

-#-clisp -(progn - (defun get-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (car hosts))) - - (defun get-random-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (when hosts - (elt hosts (random (length hosts)))))) +(defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + +(defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts))))))

- (defun host-to-vector-quad (host) - "Translate a host specification (vector quad, dotted quad or domain name) +(defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." - (etypecase host - (string (let* ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - ;; valid IP dotted quad? - ip - (get-random-host-by-name host)))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - host) - (integer (hbo-to-vector-quad host)))) - - (defun host-to-hbo (host) - (etypecase host - (string (let ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - (host-byte-order ip) - (host-to-hbo (get-host-by-name host))))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - (host-byte-order host)) - (integer host)))) + (etypecase host + (string (let* ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + host) + (integer (hbo-to-vector-quad host)))) + +(defun host-to-hbo (host) + (etypecase host + (string (let ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + (host-byte-order host)) + (integer host)))

;; ;; Other utility functions

Modified: usocket/trunk/vendor/spawn-thread.lisp ============================================================================== --- usocket/trunk/vendor/spawn-thread.lisp (original) +++ usocket/trunk/vendor/spawn-thread.lisp Wed Mar 30 04:16:10 2011 @@ -43,6 +43,9 @@ (defun spawn-thread (name function &rest args) #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) (declare (dynamic-extent args)) + #+abcl + (threads:make-thread #'(lambda () (apply function args)) + :name name) #+allegro (apply #'mp:process-run-function name function args) #+(and clisp mt)