[usocket-cvs] r614 - in usocket/trunk: . backend test vendor
Chun Tian (binghe)
ctian at common-lisp.net
Wed Mar 30 08:16:11 UTC 2011
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 at 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 at 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 at 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 ()
+ , at 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 at 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 at 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 at 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)
More information about the usocket-cvs
mailing list