Author: ctian Date: Wed Oct 22 13:37:16 2008 New Revision: 455 Log: [udp] merge recent fix on 0.4 branch and manually refit for SOCKET-CONNECT (UDP version). Modified: usocket/branches/experimental-udp/backend/armedbear.lisp usocket/branches/experimental-udp/backend/clisp.lisp usocket/branches/experimental-udp/backend/cmucl.lisp usocket/branches/experimental-udp/backend/lispworks.lisp usocket/branches/experimental-udp/backend/sbcl.lisp usocket/branches/experimental-udp/backend/scl.lisp usocket/branches/experimental-udp/condition.lisp Modified: usocket/branches/experimental-udp/backend/armedbear.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/armedbear.lisp (original) +++ usocket/branches/experimental-udp/backend/armedbear.lisp Wed Oct 22 13:37:16 2008 @@ -190,9 +190,8 @@ timeout deadline (nodelay nil nodelay-specified) local-host local-port) (when deadline (unsupported 'deadline 'socket-connect)) - (when (or local-host local-port) - (unimplemented 'local-host 'socket-connect) - (unimplemented 'local-port 'socket-connect)) + (when local-host (unimplemented 'local-host 'socket-connect)) + (when local-port (unimplemented 'local-port 'socket-connect)) (let ((usock)) (with-mapped-conditions (usock) Modified: usocket/branches/experimental-udp/backend/clisp.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/clisp.lisp (original) +++ usocket/branches/experimental-udp/backend/clisp.lisp Wed Oct 22 13:37:16 2008 @@ -62,9 +62,8 @@ (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) - (when (or local-host local-port) - (unsupported 'local-host 'socket-connect) - (unsupported 'local-port '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))) Modified: usocket/branches/experimental-udp/backend/cmucl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/cmucl.lisp (original) +++ usocket/branches/experimental-udp/backend/cmucl.lisp Wed Oct 22 13:37:16 2008 @@ -52,23 +52,29 @@ (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) - local-host local-port) + (local-host nil local-host-p) + (local-port nil local-port-p) + &aux + (local-bind-p (fboundp 'ext::bind-inet-socket))) (declare (ignore nodelay)) (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) - (when (or local-host local-port) - (unsupported 'local-host 'socket-connect) - (unsupported 'local-port 'socket-connect)) + (when (and local-host-p (not local-bind-p)) + (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)")) + (when (and local-port-p (not local-bind-p)) + (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)")) (let ((socket)) (ecase protocol (:stream (setf socket - (with-mapped-conditions (socket) - (ext:connect-to-inet-socket (host-to-hbo host) port :stream - :local-host (host-to-hbo local-host) - :local-port local-port))) + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (host-to-hbo local-host) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args)))) (if socket (let* ((stream (sys:make-fd-stream socket :input t :output t :element-type element-type @@ -82,15 +88,21 @@ (:datagram (setf socket (if (and host port) - (with-mapped-conditions (socket) - (ext:connect-to-inet-socket (host-to-hbo host) port :datagram - :local-host (host-to-hbo local-host) - :local-port local-port)) - (if (or local-host local-port) + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (host-to-hbo local-host) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) (with-mapped-conditions (socket) - (ext:create-inet-listener (or local-port 0) :datagram :host local-host)) + (apply #'ext:create-inet-listener + (nconc (list (or local-port 0) protocol) + (when (and local-host-p + (ip/= local-host *wildcard-host*)) + (list :host (host-to-hbo local-host)))))) (with-mapped-conditions (socket) - (ext:create-inet-socket :datagram))))) + (ext:create-inet-socket protocol))))) (if socket (let ((usocket (make-datagram-socket socket))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) @@ -249,5 +261,4 @@ (setf (state x) :READ))) (progn ;;###FIXME generate an error, except for EINTR - (cmucl-map-socket-error err) ))))))) Modified: usocket/branches/experimental-udp/backend/lispworks.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/lispworks.lisp (original) +++ usocket/branches/experimental-udp/backend/lispworks.lisp Wed Oct 22 13:37:16 2008 @@ -255,10 +255,11 @@ #+(and (not lispworks4) (not lispworks5.0)) (when nodelay-specified (unimplemented 'nodelay 'socket-connect)) - #+lispworks4 - (when (or local-host local-port) - (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0+ (verified)") - (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0+ (verified)")) + #+lispworks4 #+lispworks4 + (when local-host + (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) + (when local-port + (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) (ecase protocol (:stream Modified: usocket/branches/experimental-udp/backend/sbcl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/sbcl.lisp (original) +++ usocket/branches/experimental-udp/backend/sbcl.lisp Wed Oct 22 13:37:16 2008 @@ -202,7 +202,10 @@ (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) - local-host local-port) + local-host local-port + &aux + (sockopt-tcp-nodelay-p + (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))) (when deadline (unsupported 'deadline 'socket-connect)) (when timeout (unsupported 'timeout 'socket-connect)) (when (and nodelay-specified @@ -210,7 +213,7 @@ ;; package today. There's no guarantee the functions ;; we need are available, but we can make sure not to ;; call them if they aren't - (not (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))) + (not sockopt-tcp-nodelay-p)) (unsupported 'nodelay 'socket-connect)) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket @@ -228,8 +231,7 @@ ;;###FIXME: The above line probably needs an :external-format (usocket (make-stream-socket :stream stream :socket socket)) (ip (host-to-vector-quad host))) - (when (and nodelay-specified - (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)) + (when (and nodelay-specified sockopt-tcp-nodelay-p) (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay)) (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket @@ -340,9 +342,9 @@ (sb-bsd-sockets::host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) -#+sbcl +#+(and sbcl (not win32)) (progn - #-win32 + (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) @@ -384,10 +386,10 @@ (socket x)) rfds) (setf (state x) :READ)))))))))) +) ; progn - #+win32 +#+(and sbcl win32) (warn "wait-for-input not (yet!) supported...") - ) #+ecl (progn Modified: usocket/branches/experimental-udp/backend/scl.lisp ============================================================================== --- usocket/branches/experimental-udp/backend/scl.lisp (original) +++ usocket/branches/experimental-udp/backend/scl.lisp Wed Oct 22 13:37:16 2008 @@ -30,45 +30,55 @@ (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) - local-host local-port) + (local-host nil local-host-p) + (local-port nil local-port-p) + &aux + (patch-udp-p (fboundp 'ext::inet-socket-send-to))) (declare (ignore nodelay)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when timeout (unsupported 'timeout 'socket-connect)) - (when (or local-host local-port) - (unsupported 'local-host 'socket-connect) - (unsupported 'local-port 'socket-connect)) + (when (and local-host-p (not patch-udp-p)) + (unsupported 'local-host 'socket-connect :minimum "1.3.8.2")) + (when (and local-port-p (not patch-udp-p)) + (unsupported 'local-port 'socket-connect :minimum "1.3.8.2")) (let ((socket)) (ecase protocol (:stream - (setf socket (with-mapped-conditions () - (ext:connect-to-inet-socket (host-to-hbo host) port - :kind :stream - #+ignore #+ignore - #+ignore #+ignore - :local-host (if local-host - (host-to-hbo local-host)) - :local-port local-port))) + (setf socket (let ((args (list (host-to-hbo host) port :kind protocol))) + (when (and patch-udp-p (or local-host-p local-port-p)) + (nconc args (list :local-host (host-to-hbo local-host) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args)))) (let ((stream (sys:make-fd-stream socket :input t :output t :element-type element-type :buffering :full))) (make-stream-socket :socket socket :stream stream))) (:datagram + (when (not patch-udp-p) + (error 'unsupported + :feature '(protocol :datagram) + :context 'socket-connect + :minumum "1.3.8.2 or ask a udp-patch from SCL maintainer")) (setf socket (if (and host port) - (with-mapped-conditions () - (ext:connect-to-inet-socket (host-to-hbo host) port - :kind :datagram - :local-host (host-to-hbo local-host) - :local-port local-port)) - (if (or local-port local-port) + (let ((args (list (host-to-hbo host) port :kind protocol))) + (when (and patch-udp-p (or local-host-p local-port-p)) + (nconc args (list :local-host (host-to-hbo local-host) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) (with-mapped-conditions () (ext:create-inet-listener (or local-port 0) - :datagram - :host local-host)) + protocol + :host (if (ip= host *wildcard-host*) + 0 + (host-to-hbo local-host)))) (with-mapped-conditions () - (ext:create-inet-socket :datagram))))) + (ext:create-inet-socket protocol))))) (let ((usocket (make-datagram-socket socket))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) @@ -128,10 +138,8 @@ (multiple-value-bind (result errno) (ext:inet-socket-send-to s buffer length :remote-host address :remote-port port) - (unless result - (error "~@<Error sending on socket ~D: ~A~@:>" s - (unix:get-unix-error-msg errno))) - result))) + (or result + (scl-map-socket-error errno :socket socket))))) (defmethod socket-receive ((socket datagram-usocket) buffer length) (let ((s (socket socket))) @@ -141,10 +149,9 @@ (length buffer)))) (multiple-value-bind (result errno remote-host remote-port) (ext:inet-socket-receive-from s real-buffer real-length) - (unless result - (error "~@<Error receiving on socket ~D: ~A~@:>" s - (unix:get-unix-error-msg errno))) - (values real-buffer result remote-host remote-port))))) + (if result + (values real-buffer result remote-host remote-port) + (scl-map-socket-error errno :socket socket)))))) (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) Modified: usocket/branches/experimental-udp/condition.lisp ============================================================================== --- usocket/branches/experimental-udp/condition.lisp (original) +++ usocket/branches/experimental-udp/condition.lisp Wed Oct 22 13:37:16 2008 @@ -25,6 +25,12 @@ ((minimum :initarg :minimum :reader minimum :documentation "Indicates the minimal version of the implementation required to support the requested feature.")) + (:report (lambda (c stream) + (format stream "~A in ~A is unsupported." + (feature c) (context c)) + (when (minimum c) + (format stream " Minimum version (~A) is required." + (minimum c))))) (:documentation "Signalled when the underlying implementation doesn't allow supporting the requested feature. @@ -32,6 +38,9 @@ (define-condition unimplemented (insufficient-implementation) () + (:report (lambda (c stream) + (format stream "~A in ~A is unimplemented." + (feature c) (context c)))) (:documentation "Signalled if a certain feature might be implemented, based on the features of the underlying implementation, but hasn't been implemented yet.")) @@ -110,13 +119,16 @@ ((real-error :initarg :real-error :accessor usocket-real-error)) (:report (lambda (c stream) - (format stream - (simple-condition-format-control (usocket-real-error c)) - (simple-condition-format-arguments (usocket-real-error c))))) + (typecase c + (simple-condition + (format stream + (simple-condition-format-control (usocket-real-error c)) + (simple-condition-format-arguments (usocket-real-error c)))) + (otherwise + (format stream "The condition ~A occurred." (usocket-real-error c)))))) (:documentation "Error raised when there's no other - more applicable - error available.")) - (define-usocket-condition-classes (ns-try-again) (ns-condition)) @@ -140,9 +152,13 @@ ((real-error :initarg :real-error :accessor ns-real-error)) (:report (lambda (c stream) - (format stream - (simple-condition-format-control (ns-real-error c)) - (simple-condition-format-arguments (ns-real-error c))))) + (typecase c + (simple-condition + (format stream + (simple-condition-format-control (usocket-real-error c)) + (simple-condition-format-arguments (usocket-real-error c)))) + (otherwise + (format stream "The condition ~A occurred." (usocket-real-error c)))))) (:documentation "Error raised when there's no other - more applicable - error available.")) @@ -201,8 +217,10 @@ (defmacro unsupported (feature context &key minimum) - `(cerror 'unsupported :feature ,feature - :context ,context :minimum ,minimum)) + `(cerror "Ignore it and continue" 'unsupported + :feature ,feature + :context ,context + :minimum ,minimum)) (defmacro unimplemented (feature context) `(signal 'unimplemented :feature ,feature :context ,context))