Author: ctian
Date: Sat Jan 28 12:31:12 2012
New Revision: 681
Log:
[LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard with minor fixes).
Modified:
usocket/trunk/CHANGES
usocket/trunk/backend/lispworks.lisp
Modified: usocket/trunk/CHANGES
==============================================================================
--- usocket/trunk/CHANGES Fri Jan 20 15:38:00 2012 (r680)
+++ usocket/trunk/CHANGES Sat Jan 28 12:31:12 2012 (r681)
@@ -1,3 +1,10 @@
+0.6.0:
+
+* New feature: SOCKET-OPTION for seting and geting various socket options.
+* Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov).
+* Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard).
+* Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard).
+
0.5.4:
* Bugfix: [ECL] Fixed for ECL's MAKE-BUILD by removing some unecessary code (reported by Juan Jose Garcia-Ripoll, the ECL maintainer)
@@ -51,10 +58,6 @@
* New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide
* New feature: Macintosh Common Lisp (MCL) support Datagram sockets (UDP)
-0.6.0:
-
-* New feature: SOCKET-OPTION for seting and geting various socket options.
-
[TODO for 0.6.x]
* New feature: SOCKET-SHUTDOWN for TCP and UDP sockets
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp Fri Jan 20 15:38:00 2012 (r680)
+++ usocket/trunk/backend/lispworks.lisp Sat Jan 28 12:31:12 2012 (r681)
@@ -183,7 +183,47 @@
len)
(float (/ (fli:dereference timeout) 1000))))
-(defun open-udp-socket (&key local-address local-port read-timeout)
+(defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname))
+ (declare (ignorable original-hostname))
+ #+(or lispworks4 lispworks5 lispworks6.0)
+ (let ((server-addr (fli:allocate-dynamic-foreign-object
+ :type '(:struct comm::sockaddr_in))))
+ (values (comm::initialize-sockaddr_in
+ server-addr
+ comm::*socket_af_inet*
+ hostname
+ service protocol)
+ comm::*socket_af_inet*
+ server-addr
+ (fli:pointer-element-size server-addr)))
+ #-(or lispworks4 lispworks5 lispworks6.0)
+ (progn
+ (when (stringp hostname)
+ (setq hostname (comm:string-ip-address hostname))
+ (unless hostname
+ (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address))))
+ (unless resolved-hostname
+ (return-from initialize-dynamic-sockaddr :unknown-host))
+ (setq hostname resolved-hostname))))
+ (if (or (null hostname)
+ (integerp hostname)
+ (comm:ipv6-address-p hostname))
+ (let ((server-addr (fli:allocate-dynamic-foreign-object
+ :type '(:struct comm::lw-sockaddr))))
+ (multiple-value-bind (error family)
+ (comm::initialize-sockaddr_in
+ server-addr
+ hostname
+ service protocol)
+ (values error family
+ server-addr
+ (if (eql family comm::*socket_af_inet*)
+ (fli:size-of '(:struct comm::sockaddr_in))
+ (fli:size-of '(:struct comm::sockaddr_in6))))))
+ :bad-host)))
+
+(defun open-udp-socket (&key local-address local-port read-timeout
+ (address-family comm::*socket_af_inet*))
"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."
@@ -201,54 +241,51 @@
;; safe and it will be very fast after the first time.
#+win32 (comm::ensure-sockets)
- (let ((socket-fd (comm::socket comm::*socket_af_inet* *socket_sock_dgram* *socket_ip_proto_udp*)))
+ (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*)))
(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"))))
+ (progn
+ (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
+ (if local-port
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error local-address-family
+ client-addr client-addr-length)
+ (initialize-dynamic-sockaddr local-address local-port "udp")
+ (if (or error (not (eql address-family local-address-family)))
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot resolve hostname ~S, service ~S: ~A"
+ local-address local-port (or error "address family mismatch")))
+ (if (comm::bind socket-fd client-addr client-addr-length)
+ ;; 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)
+ &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))
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error address-family server-addr server-addr-length)
+ (initialize-dynamic-sockaddr hostname service "udp")
+ (when error
+ (error "cannot resolve hostname ~S, service ~S: ~A"
+ hostname service error))
+ (let ((socket-fd (open-udp-socket :local-address local-address
+ :local-port local-port
+ :read-timeout read-timeout
+ :address-family address-family)))
+ (if socket-fd
+ (if (comm::connect socket-fd server-addr server-addr-length)
+ ;; 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"))))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
timeout deadline (nodelay t nodelay-specified)
@@ -390,16 +427,19 @@
"Send message to a socket, using sendto()/send()"
(declare (type integer socket-fd)
(type sequence buffer))
- (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)))
- (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
- (replace message buffer :end2 length)
- (if (and host service)
- (progn
- (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet* host service "udp")
+ (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+ (replace message buffer :end2 length)
+ (if (and host service)
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error family client-addr client-addr-length)
+ (initialize-dynamic-sockaddr host service "udp")
+ (when error
+ (error "cannot resolve hostname ~S, service ~S: ~A"
+ host service error))
(%sendto socket-fd ptr (min length +max-datagram-packet-size+) 0
(fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
- *length-of-sockaddr_in*))
- (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0)))))
+ client-addr-length)))
+ (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0))))
(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
(send-message (socket socket)
