Context Navigation

← Previous Changeset
Next Changeset →

Changeset 426

Timestamp:

10/03/08 12:49:40 (2 months ago)

Author:

ctian

Message:

[experimental-udp] initial commit, no support on scl/clisp/armedbear, buggy on others.

Location:

usocket/branches/experimental-udp

Files:

: 3 added
: 9 modified

backend/allegro.lisp (modified) (3 diffs)
backend/cmucl.lisp (modified) (3 diffs)
backend/lispworks.lisp (modified) (3 diffs)
backend/openmcl.lisp (modified) (2 diffs)
backend/sbcl.lisp (modified) (3 diffs)
condition.lisp (modified) (1 diff)
package.lisp (modified) (3 diffs)
rtt-client.lisp (added)
rtt.lisp (added)
server.lisp (added)
usocket.asd (modified) (2 diffs)
usocket.lisp (modified) (2 diffs)

Legend:

: Unmodified
: Added
: Removed

usocket/branches/experimental-udp/backend/allegro.lisp

r405	r426
50	50	:binary))
51	51
52		(defun socket-connect (host port &key (element-type 'character)
	52	(defun socket-connect (host port &key (protocol :tcp) (element-type 'character)
53	53	timeout deadline
54	54	(nodelay t) ;; nodelay == t is the ACL default
…	…
60	60	(setf socket
61	61	(with-mapped-conditions (socket)
62		(if timeout
63		(mp:with-timeout (timeout nil)
64		(socket:make-socket :remote-host (host-to-hostname host)
65		:remote-port port
66		:local-host (when local-host (host-to-hostname local-host))
67		:local-port local-port
68		:format (to-format element-type)
69		:nodelay nodelay))
70		(socket:make-socket :remote-host (host-to-hostname host)
71		:remote-port port
72		:local-host local-host
73		:local-port local-port
74		:format (to-format element-type)
75		:nodelay nodelay))))
76		(make-stream-socket :socket socket :stream socket)))
77
	62	(ecase protocol
	63	(:tcp (if timeout
	64	(mp:with-timeout (timeout nil)
	65	(socket:make-socket :remote-host (host-to-hostname host)
	66	:remote-port port
	67	:local-host (when local-host (host-to-hostname local-host))
	68	:local-port local-port
	69	:format (to-format element-type)
	70	:nodelay nodelay))
	71	(socket:make-socket :remote-host (host-to-hostname host)
	72	:remote-port port
	73	:local-host (when local-host (host-to-hostname local-host))
	74	:local-port local-port
	75	:format (to-format element-type)
	76	:nodelay nodelay)))
	77	(:udp (if (and host port)
	78	(socket:make-socket :type :datagram
	79	:address-family :internet
	80	:connect :active
	81	:remote-host (host-to-hostname host)
	82	:remote-port port
	83	:local-host (when local-host (host-to-hostname local-host))
	84	:local-port local-port
	85	:format (to-format element-type))
	86	(socket:make-socket :type :datagram
	87	:address-family :internet
	88	:local-host local-host
	89	:local-port (when local-host (host-to-hostname local-host))
	90	:format (to-format element-type)))))))
	91	(ecase protocol
	92	(:tcp (make-stream-socket :socket socket :stream socket))
	93	(:udp (make-datagram-socket socket)))))
78	94
79	95	;; One socket close method is sufficient,
…	…
114	130	(make-stream-socket :socket stream-sock :stream stream-sock)))
115	131
	132	(defmethod socket-send ((socket datagram-usocket) buffer length &key address port)
	133	(with-mapped-conditions (socket)
	134	(let ((s (socket socket)))
	135	(socket:send-to s buffer length :remote-host address :remote-port port))))
	136
	137	(defmethod socket-receive ((socket datagram-usocket) buffer length)
	138	(with-mapped-conditions (socket)
	139	(let ((s (socket socket)))
	140	(socket:receive-from s length :buffer buffer :extract t))))
	141
116	142	(defmethod get-local-address ((usocket usocket))
117	143	(hbo-to-vector-quad (socket:local-host (socket usocket))))

usocket/branches/experimental-udp/backend/cmucl.lisp

r405	r426
51	51	:condition condition))))
52	52
53		(defun socket-connect (host port &key (element-type 'character)
	53	(defun socket-connect (host port &key (protocol :tcp) (element-type 'character)
54	54	timeout deadline (nodelay t nodelay-specified)
55	55	local-host local-port)
…	…
62	62	(unsupported 'local-port 'socket-connect))
63	63
64		(let* ((socket))
65		(setf socket
66		(with-mapped-conditions (socket)
67		(ext:connect-to-inet-socket (host-to-hbo host) port :stream)))
68		(if socket
69		(let* ((stream (sys:make-fd-stream socket :input t :output t
70		:element-type element-type
71		:buffering :full))
72		;;###FIXME the above line probably needs an :external-format
73		(usocket (make-stream-socket :socket socket
74		:stream stream)))
75		usocket)
76		(let ((err (unix:unix-errno)))
77		(when err (cmucl-map-socket-error err))))))
	64	(let ((socket))
	65	(ecase protocol
	66	(:tcp (progn
	67	(setf socket
	68	(with-mapped-conditions (socket)
	69	(ext:connect-to-inet-socket (host-to-hbo host) port
	70	(cdr (assoc protocol +protocol-map+))
	71	:local-host (if local-host
	72	(host-to-hbo local-host))
	73	:local-port local-port)))
	74	(if socket
	75	(let* ((stream (sys:make-fd-stream socket :input t :output t
	76	:element-type element-type
	77	:buffering :full))
	78	;;###FIXME the above line probably needs an :external-format
	79	(usocket (make-stream-socket :socket socket
	80	:stream stream)))
	81	usocket)
	82	(let ((err (unix:unix-errno)))
	83	(when err (cmucl-map-socket-error err))))))
	84	(:udp (progn
	85	(if (and host port)
	86	(setf socket (with-mapped-conditions (socket)
	87	(ext:connect-to-inet-socket (host-to-hbo host) port :datagram
	88	:local-host (if local-host
	89	(host-to-hbo local-host))
	90	:local-port local-port)))
	91	(progn
	92	(setf socket (with-mapped-conditions (socket)
	93	(ext:create-inet-socket :datagram)))
	94	(when (and local-host local-port)
	95	(with-mapped-conditions (socket)
	96	(ext:bind-inet-socket socket local-host local-port)))))
	97	(let ((usocket (make-datagram-socket socket)))
	98	(ext:finalize usocket #'(lambda () (unless (%closed-p usocket)
	99	(ext:close-socket socket))))
	100	usocket))))))
78	101
79	102	(defun socket-listen (host port
…	…
119	142	(with-mapped-conditions (usocket)
120	143	(ext:close-socket (socket usocket))))
	144
	145	(defmethod socket-close :after ((socket datagram-usocket))
	146	(setf (%closed-p socket) t))
	147
	148	(defmethod socket-send ((usocket datagram-usocket) buffer length &key address port)
	149	(with-mapped-conditions (usocket)
	150	(ext:inet-sendto (socket usocket) buffer length (if address (host-to-hbo address)) port)))
	151
	152	(defmethod socket-receive ((usocket datagram-usocket) buffer length)
	153	(let ((real-buffer (or buffer
	154	(make-array length :element-type '(unsigned-byte 8))))
	155	(real-length (or length
	156	(length buffer))))
	157	(multiple-value-bind (nbytes remote-host remote-port)
	158	(with-mapped-conditions (usocket)
	159	(ext:inet-recvfrom (socket usocket) real-buffer real-length))
	160	(when (plusp nbytes)
	161	(values real-buffer nbytes remote-host remote-port)))))
121	162
122	163	(defmethod get-local-name ((usocket usocket))

usocket/branches/experimental-udp/backend/lispworks.lisp

r425	r426
74	74	(raise-usock-err errno socket condition)))))
75	75
76		(defun socket-connect (host port &key (element-type 'base-char)
	76	(defun socket-connect (host port &key (protocol :tcp) (element-type 'base-char)
77	77	timeout deadline (nodelay t nodelay-specified)
78	78	local-host local-port)
…	…
88	88	(unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0+ (verified)"))
89	89
90		(let ((hostname (host-to-hostname host))
91		(stream))
92		(setf stream
93		(with-mapped-conditions ()
94		(comm:open-tcp-stream hostname port
95		:element-type element-type
96		#-lispworks4 #-lispworks4
97		#-lispworks4 #-lispworks4
98		:local-address (when local-host (host-to-hostname local-host))
99		:local-port local-port
100		#+(and (not lispworks4) (not lispworks5.0))
101		#+(and (not lispworks4) (not lispworks5.0))
102		:nodelay nodelay)))
103		(if stream
104		(make-stream-socket :socket (comm:socket-stream-socket stream)
105		:stream stream)
106		(error 'unknown-error))))
	90	(ecase protocol
	91	(:tcp (let ((hostname (host-to-hostname host))
	92	(stream))
	93	(setf stream
	94	(with-mapped-conditions ()
	95	(comm:open-tcp-stream hostname port
	96	:element-type element-type
	97	#-lispworks4 #-lispworks4
	98	#-lispworks4 #-lispworks4
	99	:local-address (when local-host (host-to-hostname local-host))
	100	:local-port local-port
	101	#+(and (not lispworks4) (not lispworks5.0))
	102	#+(and (not lispworks4) (not lispworks5.0))
	103	:nodelay nodelay)))
	104	(if stream
	105	(make-stream-socket :socket (comm:socket-stream-socket stream)
	106	:stream stream)
	107	(error 'unknown-error))))
	108	(:udp (let ((usocket (make-datagram-socket
	109	(if (and host port)
	110	(comm:connect-to-udp-server host port
	111	:errorp t
	112	:local-address local-host
	113	:local-port local-port)
	114	(comm:open-udp-socket :errorp t
	115	:local-address local-host
	116	:local-port local-port))
	117	:connected-p t)))
	118	(hcl:flag-special-free-action usocket)
	119	usocket))))
107	120
108	121	(defun socket-listen (host port
…	…
152	165	(with-mapped-conditions (usocket)
153	166	(comm::close-socket (socket usocket))))
	167
	168	(defmethod socket-close :after ((socket datagram-usocket))
	169	"Additional socket-close method for datagram-usocket"
	170	(setf (%closed-p socket) t))
	171
	172	;; Register a special free action for closing datagram usocket when being GCed
	173	(defun usocket-special-free-action (object)
	174	(when (and (typep object 'datagram-usocket)
	175	(not (closed-p object)))
	176	(socket-close object)))
	177
	178	(eval-when (:load-toplevel :execute)
	179	(hcl:add-special-free-action 'usocket-special-free-action))
	180
	181	(defmethod socket-send ((socket datagram-usocket) buffer length &key address port)
	182	(let ((s (socket socket)))
	183	(comm:send-message s buffer length address port)))
	184
	185	(defmethod socket-receive ((socket datagram-usocket) buffer length)
	186	(let ((s (socket socket)))
	187	(comm:receive-message s buffer length)))
154	188
155	189	(defmethod get-local-name ((usocket usocket))

usocket/branches/experimental-udp/backend/openmcl.lisp

r414	r426
75	75	:binary))
76	76
77		(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
	77	(defun socket-connect (host port &key (protocol :tcp) (element-type 'character)
	78	timeout deadline nodelay
78	79	local-host local-port)
79	80	(with-mapped-conditions ()
80		(let ((mcl-sock
81		(openmcl-socket:make-socket :remote-host (host-to-hostname host)
82		:remote-port port
83		:local-host (when local-host (host-to-hostname local-host))
84		:local-port local-port
85		:format (to-format element-type)
86		:deadline deadline
87		:nodelay nodelay
88		:connect-timeout (and timeout
89		(* timeout internal-time-units-per-second)))))
90		(openmcl-socket:socket-connect mcl-sock)
91		(make-stream-socket :stream mcl-sock :socket mcl-sock))))
	81	(ecase protocol
	82	(:tcp
	83	(let ((mcl-sock
	84	(openmcl-socket:make-socket :remote-host (host-to-hostname host)
	85	:remote-port port
	86	:local-host (when local-host (host-to-hostname local-host))
	87	:local-port local-port
	88	:format (to-format element-type)
	89	:deadline deadline
	90	:nodelay nodelay
	91	:connect-timeout (and timeout
	92	(* timeout internal-time-units-per-second)))))
	93	(openmcl-socket:socket-connect mcl-sock)
	94	(make-stream-socket :stream mcl-sock :socket mcl-sock)))
	95	(:udp
	96	(let ((mcl-sock
	97	(openmcl-socket:make-socket :address-family :internet
	98	:type :datagram
	99	:local-host (if local-host
	100	(host-to-hbo local-host))
	101	:local-port local-port)))
	102	(when (and host port)
	103	(ccl::inet-connect (ccl::socket-device mcl-sock)
	104	(ccl::host-as-inet-host host)
	105	(ccl::port-as-inet-port port "udp")))
	106	(make-datagram-socket mcl-sock))))))
92	107
93	108	(defun socket-listen (host port
…	…
122	137	(with-mapped-conditions (usocket)
123	138	(close (socket usocket))))
	139
	140	(defmethod socket-send ((usocket datagram-usocket) buffer length &key address port)
	141	(with-mapped-conditions (usocket)
	142	(openmcl-socket:send-to (socket usocket) buffer length
	143	:remote-host (if address (host-to-hbo address))
	144	:remote-port port)))
	145
	146	(defmethod socket-receive ((usocket datagram-usocket) buffer length)
	147	(with-mapped-conditions (usocket)
	148	(openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
124	149
125	150	(defmethod get-local-address ((usocket usocket))

usocket/branches/experimental-udp/backend/sbcl.lisp

r424	r426
200	200	(signal usock-cond :socket socket))))))
201	201
202
203		(defun socket-connect (host port &key (element-type 'character)
	202	(defun socket-connect (host port &key (protocol :tcp) (element-type 'character)
204	203	timeout deadline (nodelay t nodelay-specified)
205	204	local-host local-port)
…	…
215	214
216	215	(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
217		:type :stream :protocol :tcp)))
	216	:type (cdr (assoc protocol +protocol-map+))
	217	:protocol protocol)))
218	218	(handler-case
219		(let* ((stream
220		(sb-bsd-sockets:socket-make-stream socket
221		:input t
222		:output t
223		:buffering :full
224		:element-type element-type))
225		;;###FIXME: The above line probably needs an :external-format
226		(usocket (make-stream-socket :stream stream :socket socket))
227		(ip (host-to-vector-quad host)))
228		(when (and nodelay-specified
229		(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))
230		(setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay))
231		(when (or local-host local-port)
232		(sb-bsd-sockets:socket-bind socket
233		(host-to-vector-quad
234		(or local-host wildcard-host))
235		(or local-port auto-port)))
236		(with-mapped-conditions (usocket)
237		(sb-bsd-sockets:socket-connect socket ip port))
238		usocket)
	219	(ecase protocol
	220	(:tcp (let* ((stream
	221	(sb-bsd-sockets:socket-make-stream socket
	222	:input t
	223	:output t
	224	:buffering :full
	225	:element-type element-type))
	226	;;###FIXME: The above line probably needs an :external-format
	227	(usocket (make-stream-socket :stream stream :socket socket))
	228	(ip (host-to-vector-quad host)))
	229	(when (and nodelay-specified
	230	(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))
	231	(setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay))
	232	(when (or local-host local-port)
	233	(sb-bsd-sockets:socket-bind socket
	234	(host-to-vector-quad
	235	(or local-host wildcard-host))
	236	(or local-port auto-port)))
	237	(with-mapped-conditions (usocket)
	238	(sb-bsd-sockets:socket-connect socket ip port))
	239	usocket))
	240	(:udp (progn
	241	(when (and local-host local-port)
	242	(sb-bsd-sockets:socket-bind socket
	243	(host-to-vector-quad local-host)
	244	local-port))
	245	(when (and host port)
	246	(sb-bsd-sockets:socket-connect socket (host-to-hbo host) port))
	247	(make-datagram-socket socket))))
239	248	(t (c)
240	249	;; Make sure we don't leak filedescriptors
…	…
287	296	(with-mapped-conditions (usocket)
288	297	(close (socket-stream usocket))))
	298
	299	(defmethod socket-send ((socket datagram-usocket) buffer length &key address port)
	300	(with-mapped-conditions (socket)
	301	(let* ((s (socket socket))
	302	(dest (if (and address port) (list (host-to-vector-quad address) port) nil)))
	303	(sb-bsd-sockets:socket-send s buffer length :address dest))))
	304
	305	(defmethod socket-receive ((socket datagram-usocket) buffer length
	306	&key (element-type '(unsigned-byte 8)))
	307	(with-mapped-conditions (socket)
	308	(let ((s (socket socket)))
	309	(sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
289	310
290	311	(defmethod get-local-name ((usocket usocket))

usocket/branches/experimental-udp/condition.lisp

r399	r426
199	199	(defmacro unimplemented (feature context)
200	200	`(signal 'unimplemented :feature ,feature :context ,context))
	201
	202	;;; binghe: socket-warning for UDP retransmit support
	203
	204	(define-condition socket-warning (socket-condition warning)
	205	() ;; no slots (yet)
	206	(:documentation "Parent warning for all socket related warnings"))
	207
	208	(define-condition rtt-timeout-warning (socket-warning)
	209	((old-rto :type short-float
	210	:reader old-rto-of
	211	:initarg :old-rto)
	212	(new-rto :type short-float
	213	:reader new-rto-of
	214	:initarg :new-rto))
	215	(:report (lambda (condition stream)
	216	(format stream "Receive timeout (~As), next: ~As.~%"
	217	(old-rto-of condition)
	218	(new-rto-of condition))))
	219	(:documentation "RTT timeout warning"))
	220
	221	(define-condition rtt-seq-mismatch-warning (socket-warning)
	222	((send-seq :type integer
	223	:reader send-seq-of
	224	:initarg :send-seq)
	225	(recv-seq :type integer
	226	:reader recv-seq-of
	227	:initarg :recv-seq))
	228	(:report (lambda (condition stream)
	229	(format stream "Sequence number mismatch (~A -> ~A), try read again.~%"
	230	(send-seq-of condition)
	231	(recv-seq-of condition))))
	232	(:documentation "RTT sequence mismatch warning"))
	233
	234	(define-condition rtt-timeout-error (socket-error)
	235	()
	236	(:report (lambda (condition stream)
	237	(declare (ignore condition))
	238	(format stream "Max retransmit times (~A) reached, give up.~%"
	239	rtt-maxnrexmt)))
	240	(:documentation "RTT timeout error"))

usocket/branches/experimental-udp/package.lisp

r392	r426
12	12	#:auto-port
13	13
	14	#:remote-host ; special variables (udp)
	15	#:remote-port
	16
14	17	#:socket-connect ; socket constructors and methods
15	18	#:socket-listen
…	…
22	25	#:get-local-name
23	26	#:get-peer-name
	27
	28	#:socket-send ; udp function (send)
	29	#:socket-receive ; udp function (receive)
	30	#:socket-sync ; udp client (high-level)
	31	#:socket-server ; udp server
24	32
25	33	#:wait-for-input ; waiting for input-ready state (select() like)
…	…
66	74	#:unknown-error
67	75	#:ns-unknown-error
	76	#:socket-warning ; warnings (udp)
68	77
69	78	#:insufficient-implementation ; conditions regarding usocket support level

usocket/branches/experimental-udp/usocket.asd

r320	r426
1
	1	;;;; -- Mode: Lisp --
2	2	;;;; $Id$
3	3	;;;; $URL$
…	…
19	19	:description "Universal socket library for Common Lisp"
20	20	:depends-on (:split-sequence
21		#+sbcl :sb-bsd-sockets)
	21	#+sbcl :sb-bsd-sockets
	22	#+lispworks :lispworks-udp)
22	23	:components ((:file "package")
	24	(:file "rtt"
	25	:depends-on ("package"))
23	26	(:file "usocket"
24		~~:depends-on ("package~~"))
	27	:depends-on ("package" "rtt"))
25	28	(:file "condition"
26		:depends-on ("usocket"))
27		#+clisp (:file "clisp" :pathname "backend/clisp"
28		:depends-on ("condition"))
29		#+cmu (:file "cmucl" :pathname "backend/cmucl"
30		:depends-on ("condition"))
31		#+scl (:file "scl" :pathname "backend/scl"
32		:depends-on ("condition"))
33		#+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl"
34		:depends-on ("condition"))
35		#+lispworks (:file "lispworks" :pathname "backend/lispworks"
36		:depends-on ("condition"))
37		#+openmcl (:file "openmcl" :pathname "backend/openmcl"
38		:depends-on ("condition"))
39		#+allegro (:file "allegro" :pathname "backend/allegro"
40		:depends-on ("condition"))
41		#+armedbear (:file "armedbear" :pathname "backend/armedbear"
42		:depends-on ("condition"))
43		))
	29	:depends-on ("usocket" "rtt"))
	30	(:module "backend"
	31	:components (#+clisp (:file "clisp")
	32	#+cmu (:file "cmucl")
	33	#+scl (:file "scl")
	34	#+(or sbcl ecl) (:file "sbcl")
	35	#+lispworks (:file "lispworks")
	36	#+openmcl (:file "openmcl")
	37	#+allegro (:file "allegro")
	38	#+armedbear (:file "armedbear"))
	39	:depends-on ("condition"))
	40	(:file "rtt-client"