[usocket-cvs] r515 - in usocket/trunk: . backend
Chun Tian (binghe)
ctian at common-lisp.net
Thu Jan 7 18:26:07 UTC 2010
Author: ctian
Date: Thu Jan 7 13:26:06 2010
New Revision: 515
Log:
Branch experimental-udp merged into trunk.
Added:
usocket/trunk/server.lisp
- copied unchanged from r514, /usocket/branches/experimental-udp/server.lisp
Modified:
usocket/trunk/backend/allegro.lisp
usocket/trunk/backend/armedbear.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/package.lisp
usocket/trunk/usocket.asd
usocket/trunk/usocket.lisp
Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp (original)
+++ usocket/trunk/backend/allegro.lisp Thu Jan 7 13:26:06 2010
@@ -49,7 +49,7 @@
:text
:binary))
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline
(nodelay t) ;; nodelay == t is the ACL default
local-host local-port)
@@ -58,20 +58,39 @@
(let ((socket))
(setf socket
- (labels ((make-socket ()
- (socket:make-socket :remote-host (host-to-hostname host)
- :remote-port port
- :local-host (when local-host
- (host-to-hostname local-host))
- :local-port local-port
- :format (to-format element-type)
- :nodelay nodelay)))
- (with-mapped-conditions (socket)
- (if timeout
- (mp:with-timeout (timeout nil)
- (make-socket))
- (make-socket)))))
- (make-stream-socket :socket socket :stream socket)))
+ (with-mapped-conditions (socket)
+ (ecase protocol
+ (:stream
+ (labels ((make-socket ()
+ (socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :local-host (when local-host
+ (host-to-hostname local-host))
+ :local-port local-port
+ :format (to-format element-type)
+ :nodelay nodelay)))
+ (if timeout
+ (mp:with-timeout (timeout nil)
+ (make-socket))
+ (make-socket))))
+ (:datagram
+ (apply #'socket:make-socket
+ (nconc (list :type protocol
+ :address-family :internet
+ :local-host (when local-host
+ (host-to-hostname local-host))
+ :local-port local-port
+ :format (to-format element-type))
+ (if (and host port)
+ (list :connect :active
+ :remote-host (host-to-hostname host)
+ :remote-port port)
+ (list :connect :passive))))))))
+ (ecase protocol
+ (:stream
+ (make-stream-socket :socket socket :stream socket))
+ (:datagram
+ (make-datagram-socket socket)))))
;; One socket close method is sufficient,
;; because socket-streams are also sockets.
@@ -130,6 +149,15 @@
(values (get-peer-address usocket)
(get-peer-port usocket)))
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+ (with-mapped-conditions (socket)
+ (let ((s (socket socket)))
+ (socket:send-to s buffer length :remote-host host :remote-port port))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (with-mapped-conditions (socket)
+ (let ((s (socket socket)))
+ (socket:receive-from s length :buffer buffer :extract t))))
(defun get-host-by-address (address)
(with-mapped-conditions ()
Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp (original)
+++ usocket/trunk/backend/armedbear.lisp Thu Jan 7 13:26:06 2010
@@ -6,7 +6,7 @@
(in-package :usocket)
-;;;;; Proposed contribution to the JAVA package
+;;; Proposed contribution to the JAVA package
(defpackage :jdi
(:use :cl)
@@ -186,24 +186,36 @@
(typecase condition
(error (error 'unknown-error :socket socket :real-error condition))))
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay nil nodelay-specified)
local-host local-port)
(when deadline (unsupported 'deadline 'socket-connect))
- (when local-host (unimplemented 'local-host 'socket-connect))
- (when local-port (unimplemented 'local-port 'socket-connect))
(let ((usock))
(with-mapped-conditions (usock)
- (let* ((sock-addr (jdi:jcoerce
- (jdi:do-jnew-call "java.net.InetSocketAddress"
- (host-to-hostname host)
- (jdi:jcoerce port :int))
- "java.net.SocketAddress"))
- (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
- "open" sock-addr))
+ (let* ((sock-addr (when (and host port)
+ (jdi:jcoerce
+ (jdi:do-jnew-call "java.net.InetSocketAddress"
+ (host-to-hostname host)
+ (jdi:jcoerce port :int))
+ "java.net.SocketAddress")))
+ (local-addr (when (or local-host local-port)
+ (jdi:jcoerce
+ (jdi:do-jnew-call "java.net.InetSocketAddress"
+ (host-to-hostname (or host *wildcard-host*))
+ (jdi:jcoerce (or port *auto-port*) :int))
+ "java.net.SocketAddress")))
+ (jchan (jdi:do-jstatic-call (ecase protocol
+ (:stream "java.nio.channels.SocketChannel")
+ (:datagram "java.nio.channels.DatagramChannel"))
+ "open"))
(sock (jdi:do-jmethod-call jchan "socket")))
- (when nodelay-specified
+ ;; TODO: Fix it
+ (when (or local-host local-port)
+ (jdi:do-jmethod-call sock "bind" local-addr))
+ (when (and host port)
+ (jdi:do-jmethod-call jchan "connect" sock-addr))
+ (when (and (eq protocol 'stream) nodelay-specified)
(jdi:do-jmethod-call sock "setTcpNoDelay"
(if nodelay
(java:make-immediate-object t :boolean)
@@ -212,10 +224,14 @@
(jdi:do-jmethod-call sock "setSoTimeout"
(truncate (* 1000 timeout))))
(setf usock
- (make-stream-socket
- :socket jchan
- :stream (ext:get-socket-stream (jdi:jop-deref sock)
- :element-type element-type)))))))
+ (ecase protocol
+ (:stream
+ (make-stream-socket
+ :socket jchan
+ :stream (ext:get-socket-stream (jdi:jop-deref sock)
+ :element-type element-type)))
+ (:datagram
+ (make-datagram-socket jchan))))))))
(defun socket-listen (host port
&key reuseaddress
@@ -447,4 +463,29 @@
w))
(defun %remove-waiter (wl w)
- (remhash (socket w) (wait-list-%wait wl)))
\ No newline at end of file
+ (remhash (socket w) (wait-list-%wait wl)))
+
+;;
+;; UDP support
+;;
+
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+ (let ((jchan (socket socket)))
+ (let ((srcs (jdi:jcoerce buffer "java.nio.ByteBuffer"))
+ (offset (jdi:jcoerce 0 :int))
+ (length (jdi:jcoerce length :int)))
+ (if (and host port)
+ (let ((target (jdi:jcoerce
+ (jdi:do-jnew-call "java.net.InetSocketAddress"
+ (host-to-hostname host)
+ (jdi:jcoerce port :int))
+ "java.net.SocketAddress")))
+ ;; how to use "length" argument here? --binghe, 2009/12/12
+ (jdi:do-jmethod-call jchan "send" buffer target))
+ (jdi:do-jmethod-call jchan "write" srcs offset length)))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (let ((jchan (socket socket)))
+ (multiple-value-bind (buffer size host port)
+ 0
+ (values buffer size host port))))
Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp (original)
+++ usocket/trunk/backend/clisp.lisp Thu Jan 7 13:26:06 2010
@@ -55,7 +55,7 @@
(error usock-err :socket socket)
(signal usock-err :socket socket)))))))
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
local-host local-port)
(declare (ignore nodelay))
Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp (original)
+++ usocket/trunk/backend/cmucl.lisp Thu Jan 7 13:26:06 2010
@@ -50,7 +50,7 @@
:socket socket
:condition condition))))
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
(local-host nil local-host-p)
(local-port nil local-port-p)
@@ -65,25 +65,53 @@
(when (and local-port-p (not local-bind-p))
(unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
- (let* ((socket))
- (setf socket
- (let ((args (list (host-to-hbo host) port :stream)))
- (when (and local-bind-p (or local-host-p local-port-p))
- (nconc args (list :local-host (when 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
- :buffering :full))
- ;;###FIXME the above line probably needs an :external-format
- (usocket (make-stream-socket :socket socket
- :stream stream)))
- usocket)
- (let ((err (unix:unix-errno)))
- (when err (cmucl-map-socket-error err))))))
+ (let ((socket))
+ (ecase protocol
+ (:stream
+ (setf socket
+ (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 (when 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
+ :buffering :full))
+ ;;###FIXME the above line probably needs an :external-format
+ (usocket (make-stream-socket :socket socket
+ :stream stream)))
+ usocket)
+ (let ((err (unix:unix-errno)))
+ (when err (cmucl-map-socket-error err)))))
+ (:datagram
+ (setf socket
+ (if (and host 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 (when 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)
+ (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 protocol)))))
+ (if socket
+ (let ((usocket (make-datagram-socket socket)))
+ (ext:finalize usocket #'(lambda () (when (%open-p usocket)
+ (ext:close-socket socket))))
+ usocket)
+ (let ((err (unix:unix-errno)))
+ (when err (cmucl-map-socket-error err))))))))
(defun socket-listen (host port
&key reuseaddress
@@ -128,6 +156,24 @@
(with-mapped-conditions (usocket)
(ext:close-socket (socket usocket))))
+(defmethod socket-close :after ((socket datagram-usocket))
+ (setf (%open-p socket) nil))
+
+(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)))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (let ((real-buffer (or buffer
+ (make-array length :element-type '(unsigned-byte 8))))
+ (real-length (or length
+ (length buffer))))
+ (multiple-value-bind (nbytes remote-host remote-port)
+ (with-mapped-conditions (usocket)
+ (ext:inet-recvfrom (socket usocket) real-buffer real-length))
+ (when (plusp nbytes)
+ (values real-buffer nbytes remote-host remote-port)))))
+
(defmethod get-local-name ((usocket usocket))
(multiple-value-bind
(address port)
@@ -216,5 +262,5 @@
(when (unix:fd-isset (socket x) rfds)
(setf (state x) :READ)))
(progn
- ;;###FIXME generate an error, except for EINTR
+ ;;###FIXME generate an error, except for EINTR
)))))))
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Thu Jan 7 13:26:06 2010
@@ -89,15 +89,172 @@
(declare (ignore host port err-msg))
(raise-usock-err errno socket condition)))))
-(defun socket-connect (host port &key (element-type 'base-char)
+(defconstant *socket_sock_dgram* 2
+ "Connectionless, unreliable datagrams of fixed maximum length.")
+
+(defconstant *sockopt_so_rcvtimeo*
+ #+(not linux) #x1006
+ #+linux 20
+ "Socket receive timeout")
+
+(fli:define-c-struct timeval
+ (tv-sec :long)
+ (tv-usec :long))
+
+;;; ssize_t
+;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags,
+;;; struct sockaddr *restrict address, socklen_t *restrict address_len);
+(fli:define-foreign-function (%recvfrom "recvfrom" :source)
+ ((socket :int)
+ (buffer (:pointer (:unsigned :byte)))
+ (length :int)
+ (flags :int)
+ (address (:pointer (:struct comm::sockaddr)))
+ (address-len (:pointer :int)))
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+;;; ssize_t
+;;; sendto(int socket, const void *buffer, size_t length, int flags,
+;;; const struct sockaddr *dest_addr, socklen_t dest_len);
+(fli:define-foreign-function (%sendto "sendto" :source)
+ ((socket :int)
+ (buffer (:pointer (:unsigned :byte)))
+ (length :int)
+ (flags :int)
+ (address (:pointer (:struct comm::sockaddr)))
+ (address-len :int))
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+#-win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+ "Set socket option: RCVTIMEO, argument seconds can be a float number"
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (multiple-value-bind (sec usec) (truncate seconds)
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (setf tv-sec sec
+ tv-usec (truncate (* 1000000 usec)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ (fli:size-of '(:struct timeval))))
+ seconds)))))
+
+#+win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+ "Set socket option: RCVTIMEO, argument seconds can be a float number.
+ On win32, you must bind the socket before use this function."
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (fli:with-dynamic-foreign-objects ((timeout :int))
+ (setf (fli:dereference timeout)
+ (truncate (* 1000 seconds)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :char))
+ (fli:size-of :int)))
+ seconds)))
+
+#-win32
+(defmethod get-socket-receive-timeout (socket-fd)
+ "Get socket option: RCVTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (float (+ tv-sec (/ tv-usec 1000000))))))
+
+#+win32
+(defmethod get-socket-receive-timeout (socket-fd)
+ "Get socket option: RCVTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout :int)
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (float (/ (fli:dereference timeout) 1000))))
+
+(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 (comm::socket comm::*socket_af_inet* *socket_sock_dgram* comm::*socket_pf_unspec*)))
+ (if socket-fd
+ (progn
+ (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
+ (if local-port
+ (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)))
+ (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet*
+ local-address local-port "udp")
+ (if (comm::bind socket-fd
+ (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+ (fli:pointer-element-size client-addr))
+ ;; success, return socket fd
+ socket-fd
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot bind"))))
+ socket-fd))
+ (error "cannot create socket"))))
+
+(defun connect-to-udp-server (hostname service
+ &key local-address local-port read-timeout)
+ "Something like CONNECT-TO-TCP-SERVER"
+ (let ((socket-fd (open-udp-socket :local-address local-address
+ :local-port local-port
+ :read-timeout read-timeout)))
+ (if socket-fd
+ (fli:with-dynamic-foreign-objects ((server-addr (:struct comm::sockaddr_in)))
+ ;; connect to remote address/port
+ (comm::initialize-sockaddr_in server-addr comm::*socket_af_inet* hostname service "udp")
+ (if (comm::connect socket-fd
+ (fli:copy-pointer server-addr :type '(:struct comm::sockaddr))
+ (fli:pointer-element-size server-addr))
+ ;; success, return socket fd
+ socket-fd
+ ;; fail, close socket and return nil
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot connect"))))
+ (error "cannot create socket"))))
+
+;; Register a special free action for closing datagram usocket when being GCed
+(defun usocket-special-free-action (object)
+ (when (and (typep object 'datagram-usocket)
+ (%open-p object))
+ (socket-close object)))
+
+(eval-when (:load-toplevel :execute)
+ (hcl:add-special-free-action 'usocket-special-free-action))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
timeout deadline (nodelay t nodelay-specified)
- local-host local-port)
+ local-host (local-port #+win32 *auto-port* #-win32 nil))
(declare (ignorable nodelay))
;; What's the meaning of this keyword?
(when deadline
(unimplemented 'deadline 'socket-connect))
-
+
#+(and lispworks4 (not lispworks4.4)) ; < 4.4.5
(when timeout
(unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5"))
@@ -112,26 +269,39 @@
(when local-port
(unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0"))
- (let ((hostname (host-to-hostname host))
- (stream))
- (setf stream
- (with-mapped-conditions ()
- (comm:open-tcp-stream hostname port
- :element-type element-type
- #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
- #-(and lispworks4 (not lispworks4.4))
- :timeout timeout
- #-lispworks4 #-lispworks4
- #-lispworks4 #-lispworks4
- :local-address (when local-host (host-to-hostname local-host))
- :local-port local-port
- #-(or lispworks4 lispworks5.0) ; >= 5.1
- #-(or lispworks4 lispworks5.0)
- :nodelay nodelay)))
- (if stream
- (make-stream-socket :socket (comm:socket-stream-socket stream)
- :stream stream)
- (error 'unknown-error))))
+ (ecase protocol
+ (:stream
+ (let ((hostname (host-to-hostname host))
+ (stream))
+ (setf stream
+ (with-mapped-conditions ()
+ (comm:open-tcp-stream hostname port
+ :element-type element-type
+ #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
+ #-(and lispworks4 (not lispworks4.4))
+ :timeout timeout
+ #-lispworks4 #-lispworks4
+ #-lispworks4 #-lispworks4
+ :local-address (when local-host (host-to-hostname local-host))
+ :local-port local-port
+ #-(or lispworks4 lispworks5.0) ; >= 5.1
+ #-(or lispworks4 lispworks5.0)
+ :nodelay nodelay)))
+ (if stream
+ (make-stream-socket :socket (comm:socket-stream-socket stream)
+ :stream stream)
+ (error 'unknown-error))))
+ (:datagram
+ (let ((usocket (make-datagram-socket
+ (if (and host port)
+ (connect-to-udp-server host port
+ :local-address local-host
+ :local-port local-port)
+ (open-udp-socket :local-address local-host
+ :local-port local-port))
+ :connected-p t)))
+ (hcl:flag-special-free-action usocket)
+ usocket))))
(defun socket-listen (host port
&key reuseaddress
@@ -180,6 +350,107 @@
(with-mapped-conditions (usocket)
(comm::close-socket (socket usocket))))
+(defmethod socket-close :after ((socket datagram-usocket))
+ "Additional socket-close method for datagram-usocket"
+ (setf (%open-p socket) nil))
+
+(defvar *message-send-buffer*
+ (make-array +max-datagram-packet-size+
+ :element-type '(unsigned-byte 8)
+ :allocation :static))
+
+(defvar *message-send-lock* (mp:make-lock))
+
+(defun send-message (socket-fd buffer &optional (length (length buffer)) host service)
+ "Send message to a socket, using sendto()/send()"
+ (declare (type integer socket-fd)
+ (type sequence buffer))
+ (let ((message *message-send-buffer*))
+ (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
+ (len :int
+ #-(or lispworks3 lispworks4 lispworks5.0)
+ :initial-element
+ (fli:size-of '(:struct comm::sockaddr_in))))
+ (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+ (mp:with-lock (*message-send-lock*)
+ (replace message buffer :end2 length)
+ (if (and host service)
+ (progn
+ (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet* host service "udp")
+ (%sendto socket-fd ptr (min length +max-datagram-packet-size+) 0
+ (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+ (fli:dereference len)))
+ (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0)))))))
+
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+ (let ((s (socket socket)))
+ (send-message s buffer length (host-to-hbo host) port)))
+
+(defvar *message-receive-buffer*
+ (make-array +max-datagram-packet-size+
+ :element-type '(unsigned-byte 8)
+ :allocation :static))
+
+(defvar *message-receive-lock* (mp:make-lock))
+
+(defun receive-message (socket-fd &optional buffer (length (length buffer))
+ &key read-timeout (max-buffer-size +max-datagram-packet-size+))
+ "Receive message from socket, read-timeout is a float number in seconds.
+
+ This function will return 4 values:
+ 1. receive buffer
+ 2. number of receive bytes
+ 3. remote address
+ 4. remote port"
+ (declare (type integer socket-fd)
+ (type sequence buffer))
+ (let ((message *message-receive-buffer*)
+ old-timeout)
+ (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
+ (len :int
+ #-(or lispworks3 lispworks4 lispworks5.0)
+ :initial-element
+ (fli:size-of '(:struct comm::sockaddr_in))))
+ (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+ ;; setup new read timeout
+ (when read-timeout
+ (setf old-timeout (get-socket-receive-timeout socket-fd))
+ (set-socket-receive-timeout socket-fd read-timeout))
+ (mp:with-lock (*message-receive-lock*)
+ (let ((n (%recvfrom socket-fd ptr max-buffer-size 0
+ (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+ len)))
+ ;; restore old read timeout
+ (when (and read-timeout (/= old-timeout read-timeout))
+ (set-socket-receive-timeout socket-fd old-timeout))
+ (if (plusp n)
+ (values (if buffer
+ (replace buffer message
+ :end1 (min length max-buffer-size)
+ :end2 (min n max-buffer-size))
+ (subseq message 0 (min n max-buffer-size)))
+ (min n max-buffer-size)
+ (comm::ntohl (fli:foreign-slot-value
+ (fli:foreign-slot-value client-addr
+ 'comm::sin_addr
+ :object-type '(:struct comm::sockaddr_in)
+ :type '(:struct comm::in_addr)
+ :copy-foreign-object nil)
+ 'comm::s_addr
+ :object-type '(:struct comm::in_addr)))
+ (comm::ntohs (fli:foreign-slot-value client-addr
+ 'comm::sin_port
+ :object-type '(:struct comm::sockaddr_in)
+ :type '(:unsigned :short)
+ :copy-foreign-object nil)))
+ (values nil n 0 0))))))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (let ((s (socket socket)))
+ (multiple-value-bind (buffer size host port)
+ (receive-message s buffer length)
+ (values buffer size host port))))
+
(defmethod get-local-name ((usocket usocket))
(multiple-value-bind
(address port)
Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp (original)
+++ usocket/trunk/backend/openmcl.lisp Thu Jan 7 13:26:06 2010
@@ -74,20 +74,35 @@
:text
:binary))
-(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline nodelay
local-host local-port)
(with-mapped-conditions ()
- (let ((mcl-sock
- (openmcl-socket:make-socket :remote-host (host-to-hostname host)
- :remote-port port
- :local-host (when local-host (host-to-hostname local-host))
- :local-port local-port
- :format (to-format element-type)
- :deadline deadline
- :nodelay nodelay
- :connect-timeout timeout)))
- (openmcl-socket:socket-connect mcl-sock)
- (make-stream-socket :stream mcl-sock :socket mcl-sock))))
+ (ecase protocol
+ (:stream
+ (let ((mcl-sock
+ (openmcl-socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :local-host (when local-host (host-to-hostname local-host))
+ :local-port local-port
+ :format (to-format element-type)
+ :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)))
+ (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))))))
(defun socket-listen (host port
&key reuseaddress
@@ -121,6 +136,16 @@
(with-mapped-conditions (usocket)
(close (socket usocket))))
+(defmethod socket-send ((usocket datagram-usocket) buffer length &key host port)
+ (with-mapped-conditions (usocket)
+ (openmcl-socket:send-to (socket usocket) buffer length
+ :remote-host (host-to-hbo host)
+ :remote-port port)))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (with-mapped-conditions (usocket)
+ (openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
+
(defmethod get-local-address ((usocket usocket))
(let ((address (openmcl-socket:local-host (socket usocket))))
(when address
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Thu Jan 7 13:26:06 2010
@@ -203,8 +203,7 @@
(if usock-cond
(signal usock-cond :socket socket))))))
-
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
local-host local-port
&aux
@@ -221,29 +220,43 @@
(unsupported 'nodelay 'socket-connect))
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream :protocol :tcp)))
+ :type protocol
+ :protocol (case protocol
+ (:stream :tcp)
+ (:datagram :udp)))))
(handler-case
- (let* ((stream
- (sb-bsd-sockets:socket-make-stream socket
- :input t
- :output t
- :buffering :full
- :element-type element-type))
- ;;###FIXME: The above line probably needs an :external-format
- (usocket (make-stream-socket :stream stream :socket socket))
- (ip (host-to-vector-quad host)))
- ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
- ;; to pass compilation on ECL without it.
- (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
- (host-to-vector-quad
- (or local-host *wildcard-host*))
- (or local-port *auto-port*)))
- (with-mapped-conditions (usocket)
- (sb-bsd-sockets:socket-connect socket ip port))
- usocket)
+ (ecase protocol
+ (:stream
+ (let* ((stream
+ (sb-bsd-sockets:socket-make-stream socket
+ :input t
+ :output t
+ :buffering :full
+ :element-type element-type))
+ ;;###FIXME: The above line probably needs an :external-format
+ (usocket (make-stream-socket :stream stream :socket socket))
+ (ip (host-to-vector-quad host)))
+ ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
+ ;; to pass compilation on ECL without it.
+ (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
+ (host-to-vector-quad
+ (or local-host *wildcard-host*))
+ (or local-port *auto-port*)))
+ (with-mapped-conditions (usocket)
+ (sb-bsd-sockets:socket-connect socket ip port))
+ usocket))
+ (:datagram
+ (when (or local-host local-port)
+ (sb-bsd-sockets:socket-bind socket
+ (host-to-vector-quad
+ (or local-host *wildcard-host*))
+ (or local-port *auto-port*)))
+ (when (and host port)
+ (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))
+ (make-datagram-socket socket)))
(t (c)
;; Make sure we don't leak filedescriptors
(sb-bsd-sockets:socket-close socket)
@@ -295,6 +308,18 @@
(with-mapped-conditions (usocket)
(close (socket-stream usocket))))
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+ (with-mapped-conditions (socket)
+ (let* ((s (socket socket))
+ (dest (if (and host port) (list (host-to-vector-quad host) port) nil)))
+ (sb-bsd-sockets:socket-send s buffer length :address dest))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length
+ &key (element-type '(unsigned-byte 8)))
+ (with-mapped-conditions (socket)
+ (let ((s (socket socket)))
+ (sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
+
(defmethod get-local-name ((usocket usocket))
(sb-bsd-sockets:socket-name (socket usocket)))
Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp (original)
+++ usocket/trunk/backend/scl.lisp Thu Jan 7 13:26:06 2010
@@ -28,7 +28,7 @@
:socket socket
:condition condition))))
-(defun socket-connect (host port &key (element-type 'character)
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
(local-host nil local-host-p)
(local-port nil local-port-p)
@@ -43,17 +43,50 @@
(when (and local-port-p (not patch-udp-p))
(unsupported 'local-port 'socket-connect :minimum "1.3.9"))
- (let* ((socket (let ((args (list (host-to-hbo host) port :kind :stream)))
+ (let ((socket))
+ (ecase protocol
+ (:stream
+ (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 (when 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.9"))
+ (setf socket
+ (if (and host 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 (when local-host
(host-to-hbo local-host))
:local-port local-port)))
- (with-mapped-conditions ()
- (apply #'ext:connect-to-inet-socket args))))
- (stream (sys:make-fd-stream socket :input t :output t
- :element-type element-type
- :buffering :full)))
- (make-stream-socket :socket socket :stream stream)))
+ (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)
+ protocol
+ :host (when local-host
+ (if (ip= local-host *wildcard-host*)
+ 0
+ (host-to-hbo local-host)))))
+ (with-mapped-conditions ()
+ (ext:create-inet-socket protocol)))))
+ (let ((usocket (make-datagram-socket socket)))
+ (ext:finalize usocket #'(lambda ()
+ (when (%open-p usocket)
+ (ext:close-socket socket))))
+ usocket)))))
(defun socket-listen (host port
&key reuseaddress
@@ -99,6 +132,30 @@
(with-mapped-conditions (usocket)
(close (socket-stream usocket))))
+(defmethod socket-close :after ((socket datagram-usocket))
+ (setf (%open-p socket) nil))
+
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+ (let ((s (socket socket))
+ (host (if host (host-to-hbo host))))
+ (multiple-value-bind (result errno)
+ (ext:inet-socket-send-to s buffer length
+ :remote-host host :remote-port port)
+ (or result
+ (scl-map-socket-error errno :socket socket)))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (let ((s (socket socket)))
+ (let ((real-buffer (or buffer
+ (make-array length :element-type '(unsigned-byte 8))))
+ (real-length (or length
+ (length buffer))))
+ (multiple-value-bind (result errno remote-host remote-port)
+ (ext:inet-socket-receive-from s real-buffer real-length)
+ (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)
(with-mapped-conditions (usocket)
Modified: usocket/trunk/package.lisp
==============================================================================
--- usocket/trunk/package.lisp (original)
+++ usocket/trunk/package.lisp Thu Jan 7 13:26:06 2010
@@ -3,14 +3,20 @@
;;;; See the LICENSE file for licensing information.
-#+lispworks (cl:require "comm")
+(in-package :usocket-system)
-(cl:eval-when (:execute :load-toplevel :compile-toplevel)
- (cl:defpackage :usocket
- (:use :cl)
- (:export #:*wildcard-host*
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+(defpackage :usocket
+ (:use :common-lisp)
+ (:export #:*wildcard-host*
#:*auto-port*
+ #:*remote-host* ; special variables (udp)
+ #:*remote-port*
+
#:socket-connect ; socket constructors and methods
#:socket-listen
#:socket-accept
@@ -22,6 +28,10 @@
#:get-local-name
#:get-peer-name
+ #:socket-send ; udp function (send)
+ #:socket-receive ; udp function (receive)
+ #:socket-server ; udp server
+
#:wait-for-input ; waiting for input-ready state (select() like)
#:make-wait-list
#:add-waiter
@@ -65,9 +75,8 @@
#:ns-unknown-condition
#:unknown-error
#:ns-unknown-error
+ #:socket-warning ; warnings (udp)
#:insufficient-implementation ; conditions regarding usocket support level
#:unsupported
- #:unimplemented
- )))
-
+ #:unimplemented))
Modified: usocket/trunk/usocket.asd
==============================================================================
--- usocket/trunk/usocket.asd (original)
+++ usocket/trunk/usocket.asd Thu Jan 7 13:26:06 2010
@@ -24,10 +24,8 @@
:cl-utilities
#+sbcl :sb-bsd-sockets)
:components ((:file "package")
- (:file "usocket"
- :depends-on ("package"))
- (:file "condition"
- :depends-on ("usocket"))
+ (:file "usocket" :depends-on ("package"))
+ (:file "condition" :depends-on ("usocket"))
(:module "vendor"
:components (#+mcl (:file "kqueue")))
(:module "backend"
@@ -40,4 +38,5 @@
#+mcl (:file "mcl")
#+openmcl (:file "openmcl")
#+allegro (:file "allegro")
- #+armedbear (:file "armedbear")))))
+ #+armedbear (:file "armedbear")))
+ (:file "server" :depends-on ("backend"))))
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp (original)
+++ usocket/trunk/usocket.lisp Thu Jan 7 13:26:06 2010
@@ -11,6 +11,8 @@
(defparameter *auto-port* 0
"Port number to pass when an auto-assigned port number is wanted.")
+(defconstant +max-datagram-packet-size+ 65536)
+
(defclass usocket ()
((socket
:initarg :socket
@@ -83,9 +85,16 @@
be initiated from remote sockets."))
(defclass datagram-usocket (usocket)
- ((connected-p :initarg :connected-p :accessor connected-p))
-;; ###FIXME: documentation to be added.
- (:documentation ""))
+ ((connected-p :type boolean
+ :accessor connected-p
+ :initarg :connected-p)
+ #+(or cmu scl lispworks)
+ (%open-p :type boolean
+ :accessor %open-p
+ :initform t
+ :documentation "Flag to indicate if usocket is open,
+for GC on implementions operate on raw socket fd."))
+ (:documentation "UDP (inet-datagram) socket"))
(defun usocket-p (socket)
(typep socket 'usocket))
@@ -151,6 +160,14 @@
(defgeneric socket-close (usocket)
(:documentation "Close a previously opened `usocket'."))
+(defgeneric socket-send (usocket buffer length &key host port)
+ (:documentation "Send packets through a previously opend `usocket'."))
+
+(defgeneric socket-receive (usocket buffer length &key)
+ (:documentation "Receive packets from a previously opend `usocket'.
+
+Returns 4 values: (values buffer size host port)"))
+
(defgeneric get-local-address (socket)
(:documentation "Returns the IP address of the socket."))
More information about the usocket-cvs
mailing list