Author: ctian Date: Wed May 11 09:08:19 2011 New Revision: 660 Log: Merge all changes from branch 0.5.x (r640-r659) before tagging 0.5.2 Added: usocket/trunk/test/wait-for-input.lisp - copied unchanged from r659, /usocket/branches/0.5.x/test/wait-for-input.lisp Modified: usocket/trunk/CHANGES usocket/trunk/backend/abcl.lisp usocket/trunk/backend/clisp.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/package.lisp usocket/trunk/server.lisp usocket/trunk/test/package.lisp usocket/trunk/test/test-datagram.lisp usocket/trunk/test/test-usocket.lisp usocket/trunk/usocket-test.asd usocket/trunk/usocket.lisp Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES (original) +++ usocket/trunk/CHANGES Wed May 11 09:08:19 2011 @@ -1,10 +1,13 @@ -0.5.0: +0.5.2: -* New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL) -* Support for UDP (datagram-usocket) was added (for all supported platform except MCL) -* 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 +* General: [SBCL] SOCKET-CONNECT's TIMEOUT argument was limited on non-Windows platforms. +* Bugfix: [CLISP] WAIT-FOR-INPUT now functions right (with/without READY-ONLY), this made Hunchentoot working on CLISP. (Thanks to Anton Vodonosov <avodonosov@yandex.ru>) +* Bugfix: [ABCL] Fix SOCKET-ACCEPT to follow the documented API so that when called without an :ELEMENT-TYPE argument. (Thanks to Mark Evenson, the ABCL developer) +* Bugfix: [LispWorks] Fixed SOCKET-ACCEPT (Windows only) on WAIT-FOR-INPUTed sockets. +* Bugfix: [SBCL, ECL] Fixed wrongly STATE set/unset for WAIT-FOR-INPUT on Windows (report by Elliott Slaughter) +* Enhancement: Additional NAME keyword argument for SOCKET-SERVER for setting the server thread name. +* Enhancement: [ABCL] GET-ADDRESS now works with underlying IP6 addresses. +* Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added. 0.5.1: @@ -21,6 +24,15 @@ * Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. * Bugfix: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version). +0.5.0: + +* New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL) +* Support for UDP (datagram-usocket) was added (for all supported platform except MCL) +* Add WAIT-FOR-INPUT support for SBCL and ECL on win32. +* Simple TCP and UDP server API: SOCKET-SERVER +* Completely rewritten full-feature ABCL backends using latest Java interfaces +* Lots of bug fixed since 0.4.1 + [TODO] * New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide Modified: usocket/trunk/backend/abcl.lisp ============================================================================== --- usocket/trunk/backend/abcl.lisp (original) +++ usocket/trunk/backend/abcl.lisp Wed May 11 09:08:19 2011 @@ -67,7 +67,7 @@ (defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress)) (defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int)) (defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress)) -(defvar $@getAddress/0 (jmethod $*Inet4Address "getAddress")) +(defvar $@getAddress/0 (jmethod $*InetAddress "getAddress")) (defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String)) (defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String)) (defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel")) @@ -170,9 +170,13 @@ (labels ((jbyte (n) (let ((byte (jarray-ref array n))) (if (minusp byte) (+ 256 byte) byte)))) - (if (= 4 length) - (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)) - nil))))) ; not a IPv4 address?! + (cond + ((= 4 length) + (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3))) + ((= 16 length) + (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3) + (jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7))) + (t nil)))))) ; neither a IPv4 nor IPv6 address?! (defun get-hosts-by-name (name) (with-mapped-conditions () @@ -249,9 +253,13 @@ ;;; SOCKET-ACCEPT -(defmethod socket-accept ((usocket stream-server-usocket) &key (element-type 'character)) +(defmethod socket-accept ((usocket stream-server-usocket) + &key (element-type 'character element-type-p)) (with-mapped-conditions (usocket) (let* ((client-socket (jcall $@accept/0 (socket usocket))) + (element-type (if element-type-p + element-type + (element-type usocket))) (stream (ext:get-socket-stream client-socket :element-type element-type))) (make-stream-socket :stream stream :socket client-socket)))) Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Wed May 11 09:08:19 2011 @@ -191,6 +191,10 @@ (socket:socket-stream-local (socket usocket) t) (values (dotted-quad-to-vector-quad address) port))) +(defmethod get-local-name ((usocket stream-server-usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + (defmethod get-peer-name ((usocket stream-usocket)) (multiple-value-bind (address port) @@ -200,12 +204,19 @@ (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) +(defmethod get-local-address ((usocket stream-server-usocket)) + (dotted-quad-to-vector-quad + (socket:socket-server-host (socket usocket)))) + (defmethod get-peer-address ((usocket usocket)) (nth-value 0 (get-peer-name usocket))) (defmethod get-local-port ((usocket usocket)) (nth-value 1 (get-local-name usocket))) +(defmethod get-local-port ((usocket stream-server-usocket)) + (socket:socket-server-port (socket usocket))) + (defmethod get-peer-port ((usocket usocket)) (nth-value 1 (get-peer-name usocket))) @@ -232,9 +243,9 @@ (socket:socket-status request-list))) (sockets (wait-list-waiters wait-list))) (do* ((x (pop sockets) (pop sockets)) - (y (pop status-list) (pop status-list))) + (y (cdr (pop status-list)) (cdr (pop status-list)))) ((null x)) - (when (eq y :INPUT) + (when (member y '(T :INPUT)) (setf (state x) :READ))) wait-list)))) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Wed May 11 09:08:19 2011 @@ -318,18 +318,28 @@ #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) (make-stream-server-socket sock :element-type element-type))) +;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which +;; should NOT be applied on socket FDs who have already been called on W-F-I, +;; so we have to check the %READY-P slot to decide if this waiting is necessary, +;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011 + (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) - (let* ((sock (with-mapped-conditions (usocket) - (comm::get-fd-from-socket (socket usocket)))) + (let* ((socket (with-mapped-conditions (usocket) + #+win32 + (if (%ready-p usocket) + (comm::accept-connection-to-socket (socket usocket)) + (comm::get-fd-from-socket (socket usocket))) + #-win32 + (comm::get-fd-from-socket (socket usocket)))) (stream (make-instance 'comm:socket-stream - :socket sock + :socket socket :direction :io :element-type (or element-type (element-type usocket))))) #+win32 - (when sock + (when socket (setf (%ready-p usocket) nil)) - (make-stream-socket :socket sock :stream stream))) + (make-stream-socket :socket socket :stream stream))) ;; Sockets and their streams are different objects ;; close the stream in order to make sure buffers Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed May 11 09:08:19 2011 @@ -215,7 +215,7 @@ ;;; 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 +#+(and sbcl (not win32)) (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 @@ -287,13 +287,13 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) - #+sbcl + #+(and sbcl (not win32)) (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 + #+(or ecl (and sbcl win32)) (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) @@ -347,22 +347,23 @@ ;;; "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)))) - (if sock +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let ((socket (sb-bsd-sockets:socket-accept (socket usocket)))) + (when socket + (prog1 (make-stream-socket - :socket sock + :socket socket :stream (sb-bsd-sockets:socket-make-stream - sock + socket :input t :output t :buffering :full :element-type (or element-type - (element-type socket)))) + (element-type usocket)))) - ;; 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))))) + ;; 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 usocket) nil)))))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which @@ -584,15 +585,18 @@ (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long)) (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr)) socket) - int-ptr)) + (prog1 int-ptr + (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+ #.+wsa-wait-timeout+) + ((#.+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)) @@ -608,20 +612,22 @@ (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) - (if (or (and (stream-usocket-p socket) - (listen (socket-stream socket))) - (%ready-p socket)) - (setf (state socket) :READ) + (if (%ready-p socket) + (progn + (setf (state socket) :READ)) (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events))) (let ((rv (wsa-enum-network-events (os-socket-handle socket) 0 (sb-alien:addr network-events)))) (if (zerop rv) - (map-network-events #'(lambda (err-code) - (if (zerop err-code) - (setf (%ready-p socket) t - (state socket) :READ) - (raise-usock-err err-code socket))) - network-events) + (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) @@ -733,7 +739,8 @@ '%remove-waiter)) ;; TODO: how to handle error (result) in this call? - (defun bytes-available-for-read (socket) + (declaim (inline %bytes-available-for-read)) + (defun %bytes-available-for-read (socket) (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum "u_long nbytes; int result; @@ -741,28 +748,40 @@ result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes); @(return) = nbytes;")) + (defun bytes-available-for-read (socket) + (let ((nbytes (%bytes-available-for-read socket))) + (when (plusp nbytes) + (setf (state socket) :read)) + nbytes)) + (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) - (if (or (and (stream-usocket-p socket) - (listen (socket-stream socket))) - (%ready-p socket)) + (if (%ready-p socket) (setf (state socket) :READ) (let ((events (etypecase socket (stream-server-usocket (logior fd-connect fd-accept fd-close)) (stream-usocket (logior fd-read)) (datagram-usocket (logior fd-read))))) ;; TODO: check the iErrorCode array - (if (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) :bool - "WSANETWORKEVENTS network_events; - int i, result; - result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events); - if (!result) { - @(return) = (#1 & network_events.lNetworkEvents)? Ct : Cnil; - } else - @(return) = Cnil;") - (setf (%ready-p socket) t - (state socket) :READ) - (sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))) + (multiple-value-bind (valid-p ready-p) + (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) + (values :bool :bool) + "WSANETWORKEVENTS network_events; + int i, result; + result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events); + if (!result) { + @(return 0) = Ct; + @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil; + } else { + @(return 0) = Cnil; + @(return 1) = Cnil; + }") + (if valid-p + (when ready-p + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (sb-bsd-sockets::socket-error 'update-ready-and-state-slots))))))) (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) @@ -774,8 +793,9 @@ result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL); @(return) = result;"))) (ecase rv - ((#.+wsa-wait-event-0+ #.+wsa-wait-timeout+) + ((#.+wsa-wait-event-0+) (update-ready-and-state-slots (wait-list-waiters wait-list))) + ((#.+wsa-wait-timeout+)) ; do nothing here ((#.+wsa-wait-failed+) (sb-bsd-sockets::socket-error 'wait-for-input-internal)))))) Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Wed May 11 09:08:19 2011 @@ -49,6 +49,14 @@ #:socket-stream #:datagram-usocket + ;; predicates (for version 0.6 or 1.0 ?) + #| + #:usocket-p + #:stream-usocket-p + #:stream-server-usocket-p + #:datagram-usocket-p + |# + #:host-byte-order ; IP(v4) utility functions #:hbo-to-dotted-quad #:hbo-to-vector-quad @@ -83,6 +91,7 @@ (in-package :usocket) ;;; Logical Pathname Translations, learn from CL-HTTP source code + (eval-when (:load-toplevel :execute) (let* ((defaults #+asdf (asdf:component-pathname (asdf:find-system :usocket)) #-asdf *load-truename*) @@ -93,4 +102,5 @@ :defaults defaults :version :newest))) (setf (logical-pathname-translations "usocket") - `(("**;*.*" ,home))))) + `(("**;*.*.NEWEST" ,home) + ("**;*.*" ,home))))) Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Wed May 11 09:08:19 2011 @@ -8,7 +8,8 @@ ;; for udp (timeout 1) (max-buffer-size +max-datagram-packet-size+) ;; for tcp - element-type reuse-address multi-threading) + element-type reuse-address multi-threading + name) (let* ((real-host (or host *wildcard-host*)) (socket (ecase protocol (:stream @@ -31,7 +32,7 @@ :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread - (values (spawn-thread "USOCKET Server" #'real-call) socket) + (values (spawn-thread (or name "USOCKET Server") #'real-call) socket) (real-call))))) (defvar *remote-host*) @@ -81,7 +82,8 @@ (unwind-protect (apply function (socket-stream client-socket) arguments) (close (socket-stream client-socket)) - (socket-close client-socket))))) + (socket-close client-socket) + nil)))) (unwind-protect (loop do (let* ((client-socket (apply #'socket-accept Modified: usocket/trunk/test/package.lisp ============================================================================== --- usocket/trunk/test/package.lisp (original) +++ usocket/trunk/test/package.lisp Wed May 11 09:08:19 2011 @@ -6,6 +6,8 @@ (in-package :cl-user) (defpackage :usocket-test - (:use :cl :regression-test) - (:nicknames :usoct) - (:export :do-tests :run-usocket-tests)) + (:use :common-lisp + :usocket + :regression-test) + (:export #:do-tests + #:run-usocket-tests)) Modified: usocket/trunk/test/test-datagram.lisp ============================================================================== --- usocket/trunk/test/test-datagram.lisp (original) +++ usocket/trunk/test/test-datagram.lisp Wed May 11 09:08:19 2011 @@ -6,7 +6,7 @@ (defvar *echo-server*) (defvar *echo-server-port*) -(eval-when (:load-toplevel :execute) +(defun start-server () (multiple-value-bind (thread socket) (usocket:socket-server "127.0.0.1" 0 #'identity nil :in-new-thread t @@ -28,6 +28,9 @@ ;;; UDP Send Test #1: connected socket (deftest udp-send.1 + (progn + (unless (and *echo-server* *echo-server-port*) + (start-server)) (let ((s (usocket:socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) @@ -36,11 +39,14 @@ (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) - (reduce #'+ *receive-buffer* :start 0 :end 5))) + (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) ;;; UDP Send Test #2: unconnected socket (deftest udp-send.2 + (progn + (unless (and *echo-server* *echo-server-port*) + (start-server)) (let ((s (usocket:socket-connect nil nil :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) @@ -49,5 +55,5 @@ (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) - (reduce #'+ *receive-buffer* :start 0 :end 5))) + (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Wed May 11 09:08:19 2011 @@ -157,41 +157,5 @@ (usocket:socket-close sock)))) t) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *wait-for-input-timeout* 2)) - -(deftest wait-for-input.1 - (with-caught-conditions (nil nil) - (let ((sock (usocket:socket-connect *common-lisp-net* 80)) - (time (get-universal-time))) - (unwind-protect - (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) - (- (get-universal-time) time)) - (usocket:socket-close sock)))) - #.*wait-for-input-timeout*) - -(deftest wait-for-input.2 - (with-caught-conditions (nil nil) - (let ((sock (usocket:socket-connect *common-lisp-net* 80)) - (time (get-universal-time))) - (unwind-protect - (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t) - (- (get-universal-time) time)) - (usocket:socket-close sock)))) - #.*wait-for-input-timeout*) - -(deftest wait-for-input.3 - (with-caught-conditions (nil nil) - (let ((sock (usocket:socket-connect *common-lisp-net* 80))) - (unwind-protect - (progn - (format (usocket:socket-stream sock) - "GET / HTTP/1.0~2%") - (force-output (usocket:socket-stream sock)) - (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) - (subseq (read-line (usocket:socket-stream sock)) 0 15)) - (usocket:socket-close sock)))) - "HTTP/1.1 200 OK") - (defun run-usocket-tests () (do-tests)) Modified: usocket/trunk/usocket-test.asd ============================================================================== --- usocket/trunk/usocket-test.asd (original) +++ usocket/trunk/usocket-test.asd Wed May 11 09:08:19 2011 @@ -26,7 +26,8 @@ :components ((:file "package") (:file "test-usocket") (:file "test-condition") - (:file "test-datagram"))))) + (:file "test-datagram") + (:file "wait-for-input"))))) (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 May 11 09:08:19 2011 @@ -323,9 +323,10 @@ (values (if ready-only socks socket-or-sockets) to))))) (let* ((start (get-internal-real-time)) (sockets-ready 0)) - #-(and win32 (or sbcl ecl)) (dolist (x (wait-list-waiters socket-or-sockets)) (when (setf (state x) + #+(and win32 (or sbcl ecl)) NIL ; they cannot relay on LISTEN + #-(and win32 (or sbcl ecl)) (if (and (stream-usocket-p x) (listen (socket-stream x))) :READ NIL))