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