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))
