From ctian at common-lisp.net Thu Mar 10 10:17:44 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 10 Mar 2011 05:17:44 -0500 Subject: [usocket-cvs] r575 - usocket/trunk/backend Message-ID: Author: ctian Date: Thu Mar 10 05:17:43 2011 New Revision: 575 Log: [SBCL] Merge a patch from Nikodemus Siivola (SBCL maintainer), for "better SOCKET-CONNECT for SBCL". Modified: usocket/trunk/backend/sbcl.lisp Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Thu Mar 10 05:17:43 2011 @@ -199,6 +199,11 @@ (if usock-cond (signal usock-cond :socket socket)))))) +(defvar *dummy-stream* + (let ((stream (make-broadcast-stream))) + (close stream) + stream)) + (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port @@ -219,47 +224,53 @@ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type protocol :protocol (case protocol - (:stream :tcp) - (:datagram :udp))))) - (handler-case - (ecase protocol - (:stream - (let* ((stream - (sb-bsd-sockets:socket-make-stream socket - :input t - :output t - :buffering :full - #+sbcl #+sbcl - :timeout timeout - :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) - (error c))))) + (:stream :tcp) + (:datagram :udp)))) + (ip (host-to-vector-quad host)) + (local-host (host-to-vector-quad (or local-host *wildcard-host*))) + (local-port (or local-port *auto-port*)) + usocket ok) + (unwind-protect + (progn + (ecase protocol + (:stream + ;; If make a real socket stream before the socket is + ;; connected, it gets a misleading name so supply a + ;; dummy value to start with. + (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*)) + ;; 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 local-host local-port)) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port) + ;; Now that we're connected make the stream. + (setf (socket-stream usocket) + (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + #+sbcl #+sbcl + :timeout timeout + :element-type element-type)))) + (: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*))) + (setf usocket (make-datagram-socket socket)) + (when (and host port) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port) + (setf (connected-p usocket) t))))) + (setf ok t)) + ;; Clean up in case of an error. + (unless ok + (sb-bsd-sockets:socket-close socket :abort t))) + usocket)) (defun socket-listen (host port &key reuseaddress From ehuelsmann at common-lisp.net Sat Mar 12 20:18:56 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 15:18:56 -0500 Subject: [usocket-cvs] r576 - usocket/branches/0.5.x Message-ID: Author: ehuelsmann Date: Sat Mar 12 15:18:55 2011 New Revision: 576 Log: Create 0.5 release branch. Added: usocket/branches/0.5.x/ - copied from r575, /usocket/trunk/ From ehuelsmann at common-lisp.net Sat Mar 12 20:21:45 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 15:21:45 -0500 Subject: [usocket-cvs] r577 - usocket/trunk Message-ID: Author: ehuelsmann Date: Sat Mar 12 15:21:45 2011 New Revision: 577 Log: Update version number on trunk, with 0.5.x release branch created. Modified: usocket/trunk/usocket.asd Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Sat Mar 12 15:21:45 2011 @@ -14,7 +14,7 @@ (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" - :version "0.5.0" + :version "0.6.0" :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (#+sbcl :sb-bsd-sockets) From ehuelsmann at common-lisp.net Sat Mar 12 20:22:36 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 15:22:36 -0500 Subject: [usocket-cvs] r578 - usocket/tags/0.5.0 Message-ID: Author: ehuelsmann Date: Sat Mar 12 15:22:35 2011 New Revision: 578 Log: Create 0.5.0 release tag. Added: usocket/tags/0.5.0/ - copied from r577, /usocket/branches/0.5.x/ From ehuelsmann at common-lisp.net Sat Mar 12 20:25:40 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 15:25:40 -0500 Subject: [usocket-cvs] r579 - usocket/branches/0.5.x Message-ID: Author: ehuelsmann Date: Sat Mar 12 15:25:40 2011 New Revision: 579 Log: Update branch version number, now that 0.5.0 has been tagged. Modified: usocket/branches/0.5.x/usocket.asd Modified: usocket/branches/0.5.x/usocket.asd ============================================================================== --- usocket/branches/0.5.x/usocket.asd (original) +++ usocket/branches/0.5.x/usocket.asd Sat Mar 12 15:25:40 2011 @@ -14,7 +14,7 @@ (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" - :version "0.5.0" + :version "0.5.1" :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (#+sbcl :sb-bsd-sockets) From ehuelsmann at common-lisp.net Sat Mar 12 20:28:17 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 15:28:17 -0500 Subject: [usocket-cvs] r580 - usocket/branches/experimental-udp Message-ID: Author: ehuelsmann Date: Sat Mar 12 15:28:17 2011 New Revision: 580 Log: Remove experimental-udp branch which has been long-merged. Removed: usocket/branches/experimental-udp/ From ehuelsmann at common-lisp.net Sat Mar 12 21:14:27 2011 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 12 Mar 2011 16:14:27 -0500 Subject: [usocket-cvs] r581 - in public_html: . releases releases/old Message-ID: Author: ehuelsmann Date: Sat Mar 12 16:14:26 2011 New Revision: 581 Log: Publish the 0.5.0 release. Added: public_html/releases/old/usocket-0.1.0.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.1.0.tar.gz public_html/releases/old/usocket-0.1.0.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.1.0.tar.gz.asc public_html/releases/old/usocket-0.2.0.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.0.tar.gz public_html/releases/old/usocket-0.2.0.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.0.tar.gz.asc public_html/releases/old/usocket-0.2.1.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.1.tar.gz public_html/releases/old/usocket-0.2.1.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.1.tar.gz.asc public_html/releases/old/usocket-0.2.2.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.2.tar.gz public_html/releases/old/usocket-0.2.2.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.2.tar.gz.asc public_html/releases/old/usocket-0.2.3.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.3.tar.gz public_html/releases/old/usocket-0.2.3.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.3.tar.gz.asc public_html/releases/old/usocket-0.2.4.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.4.tar.gz public_html/releases/old/usocket-0.2.4.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.4.tar.gz.asc public_html/releases/old/usocket-0.2.5.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.2.5.tar.gz public_html/releases/old/usocket-0.2.5.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.2.5.tar.gz.asc public_html/releases/old/usocket-0.3.0.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.0.tar.gz public_html/releases/old/usocket-0.3.0.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.0.tar.gz.asc public_html/releases/old/usocket-0.3.1.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.1.tar.gz public_html/releases/old/usocket-0.3.1.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.1.tar.gz.asc public_html/releases/old/usocket-0.3.2.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.2.tar.gz public_html/releases/old/usocket-0.3.2.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.2.tar.gz.asc public_html/releases/old/usocket-0.3.3.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.3.tar.gz public_html/releases/old/usocket-0.3.3.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.3.tar.gz.asc public_html/releases/old/usocket-0.3.4.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.4.tar.gz public_html/releases/old/usocket-0.3.4.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.4.tar.gz.asc public_html/releases/old/usocket-0.3.5.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.5.tar.gz public_html/releases/old/usocket-0.3.5.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.5.tar.gz.asc public_html/releases/old/usocket-0.3.6.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.6.tar.gz public_html/releases/old/usocket-0.3.6.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.6.tar.gz.asc public_html/releases/old/usocket-0.3.7.tar.gz - copied unchanged from r580, /public_html/releases/usocket-0.3.7.tar.gz public_html/releases/old/usocket-0.3.7.tar.gz.asc - copied unchanged from r580, /public_html/releases/usocket-0.3.7.tar.gz.asc public_html/releases/usocket-0.5.0.tar.gz (contents, props changed) public_html/releases/usocket-0.5.0.tar.gz.asc Removed: public_html/releases/usocket-0.1.0.tar.gz public_html/releases/usocket-0.1.0.tar.gz.asc public_html/releases/usocket-0.2.0.tar.gz public_html/releases/usocket-0.2.0.tar.gz.asc public_html/releases/usocket-0.2.1.tar.gz public_html/releases/usocket-0.2.1.tar.gz.asc public_html/releases/usocket-0.2.2.tar.gz public_html/releases/usocket-0.2.2.tar.gz.asc public_html/releases/usocket-0.2.3.tar.gz public_html/releases/usocket-0.2.3.tar.gz.asc public_html/releases/usocket-0.2.4.tar.gz public_html/releases/usocket-0.2.4.tar.gz.asc public_html/releases/usocket-0.2.5.tar.gz public_html/releases/usocket-0.2.5.tar.gz.asc public_html/releases/usocket-0.3.0.tar.gz public_html/releases/usocket-0.3.0.tar.gz.asc public_html/releases/usocket-0.3.1.tar.gz public_html/releases/usocket-0.3.1.tar.gz.asc public_html/releases/usocket-0.3.2.tar.gz public_html/releases/usocket-0.3.2.tar.gz.asc public_html/releases/usocket-0.3.3.tar.gz public_html/releases/usocket-0.3.3.tar.gz.asc public_html/releases/usocket-0.3.4.tar.gz public_html/releases/usocket-0.3.4.tar.gz.asc public_html/releases/usocket-0.3.5.tar.gz public_html/releases/usocket-0.3.5.tar.gz.asc public_html/releases/usocket-0.3.6.tar.gz public_html/releases/usocket-0.3.6.tar.gz.asc public_html/releases/usocket-0.3.7.tar.gz public_html/releases/usocket-0.3.7.tar.gz.asc Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sat Mar 12 16:14:26 2011 @@ -404,6 +404,13 @@ Summary + Mar 12, 2011 + 0.5.0 + Lots of bugfixes since 0.4.1, support for WAIT-FOR-INPUT for + SBCL and ECL on Win32, new platform added: Macintosh Common Lisp + (5.0 and up) + + Dec 27, 2008 0.4.1 fixes for ECL, LispWorks, SBCL, SCL Added: public_html/releases/usocket-0.5.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/usocket-0.5.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/usocket-0.5.0.tar.gz.asc Sat Mar 12 16:14:26 2011 @@ -0,0 +1,14 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk1732MACgkQi5O0Epaz9TlT7wCdERC7+BcEeCZya1pLNE0DWieg +B5cAnA4NKehUXpAqs36Xge0r+znjzZfN +=bjOR +-----END PGP SIGNATURE----- +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEABECAAYFAk173McACgkQny6v4+l8uLAhUQCfY4cUC7lOAcxCLycRnVzIQIsp +KtYAnR23m9Qn8omBTXgwJc2DvKjx/EjU +=JGOc +-----END PGP SIGNATURE----- From ctian at common-lisp.net Sun Mar 13 13:53:47 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Sun, 13 Mar 2011 09:53:47 -0400 Subject: [usocket-cvs] r582 - public_html Message-ID: Author: ctian Date: Sun Mar 13 09:53:46 2011 New Revision: 582 Log: Update brief release notes for 0.5.0 (add UDP support) Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Mar 13 09:53:46 2011 @@ -406,8 +406,8 @@ Mar 12, 2011 0.5.0 - Lots of bugfixes since 0.4.1, support for WAIT-FOR-INPUT for - SBCL and ECL on Win32, new platform added: Macintosh Common Lisp + UDP support; Lots of bugfixes since 0.4.1; support for WAIT-FOR-INPUT for + SBCL and ECL on Win32; new platform added: Macintosh Common Lisp (5.0 and up) From ctian at common-lisp.net Sun Mar 20 13:44:17 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Sun, 20 Mar 2011 09:44:17 -0400 Subject: [usocket-cvs] r583 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Sun Mar 20 09:44:17 2011 New Revision: 583 Log: Bugfix: UDP flag "connected-p" never been set in SOCKET-CONNECT (LW, CCL and SCL). Modified: usocket/branches/0.5.x/backend/lispworks.lisp usocket/branches/0.5.x/backend/openmcl.lisp usocket/branches/0.5.x/backend/scl.lisp Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Sun Mar 20 09:44:17 2011 @@ -305,7 +305,7 @@ (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) :local-port local-port :read-timeout timeout)) - :connected-p t))) + :connected-p (and host port t)))) (hcl:flag-special-free-action usocket) usocket)))) Modified: usocket/branches/0.5.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/openmcl.lisp (original) +++ usocket/branches/0.5.x/backend/openmcl.lisp Sun Mar 20 09:44:17 2011 @@ -100,17 +100,18 @@ (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))) + (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)) + (usocket (make-datagram-socket mcl-sock))) (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)))))) + (ccl::inet-connect (ccl::socket-device mcl-sock) + (ccl::host-as-inet-host host) + (ccl::port-as-inet-port port "udp")) + (setf (connected-p usocket) t))))))) (defun socket-listen (host port &key reuseaddress Modified: usocket/branches/0.5.x/backend/scl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/scl.lisp (original) +++ usocket/branches/0.5.x/backend/scl.lisp Sun Mar 20 09:44:17 2011 @@ -82,7 +82,7 @@ (host-to-hbo local-host))))) (with-mapped-conditions () (ext:create-inet-socket protocol))))) - (let ((usocket (make-datagram-socket socket))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) From ctian at common-lisp.net Sun Mar 20 14:11:32 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Sun, 20 Mar 2011 10:11:32 -0400 Subject: [usocket-cvs] r584 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Sun Mar 20 10:11:31 2011 New Revision: 584 Log: Bugfix: UDP flag "connected-p" never been set in SOCKET-CONNECT (ACL). Modified: usocket/branches/0.5.x/backend/allegro.lisp Modified: usocket/branches/0.5.x/backend/allegro.lisp ============================================================================== --- usocket/branches/0.5.x/backend/allegro.lisp (original) +++ usocket/branches/0.5.x/backend/allegro.lisp Sun Mar 20 10:11:31 2011 @@ -90,7 +90,7 @@ (:stream (make-stream-socket :socket socket :stream socket)) (:datagram - (make-datagram-socket socket))))) + (make-datagram-socket socket :connected-p (and host port t)))))) ;; One socket close method is sufficient, ;; because socket-streams are also sockets. From ctian at common-lisp.net Sun Mar 20 14:13:55 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Sun, 20 Mar 2011 10:13:55 -0400 Subject: [usocket-cvs] r585 - usocket/branches/0.5.x/vendor Message-ID: Author: ctian Date: Sun Mar 20 10:13:27 2011 New Revision: 585 Log: Update vendor code (portable-threads) to support threads creating in ABCL. Modified: usocket/branches/0.5.x/vendor/spawn-thread.lisp Modified: usocket/branches/0.5.x/vendor/spawn-thread.lisp ============================================================================== --- usocket/branches/0.5.x/vendor/spawn-thread.lisp (original) +++ usocket/branches/0.5.x/vendor/spawn-thread.lisp Sun Mar 20 10:13:27 2011 @@ -43,6 +43,9 @@ (defun spawn-thread (name function &rest args) #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) (declare (dynamic-extent args)) + #+abcl + (threads:make-thread #'(lambda () (apply function args)) + :name name) #+allegro (apply #'mp:process-run-function name function args) #+(and clisp mt) From ctian at common-lisp.net Sun Mar 20 14:34:38 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Sun, 20 Mar 2011 10:34:38 -0400 Subject: [usocket-cvs] r586 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Sun Mar 20 10:34:38 2011 New Revision: 586 Log: Bugfix: last rework of SOCKET-CONNECT (by N. Siivola) broke UDP listening call (both HOST and PORT are NIL) Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Sun Mar 20 10:34:38 2011 @@ -226,7 +226,6 @@ :protocol (case protocol (:stream :tcp) (:datagram :udp)))) - (ip (host-to-vector-quad host)) (local-host (host-to-vector-quad (or local-host *wildcard-host*))) (local-port (or local-port *auto-port*)) usocket ok) @@ -245,7 +244,7 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port) + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket @@ -264,7 +263,7 @@ (setf usocket (make-datagram-socket socket)) (when (and host port) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port) + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) (setf (connected-p usocket) t))))) (setf ok t)) ;; Clean up in case of an error. From ctian at common-lisp.net Mon Mar 21 13:47:57 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 21 Mar 2011 09:47:57 -0400 Subject: [usocket-cvs] r587 - public_html/releases Message-ID: Author: ctian Date: Mon Mar 21 09:47:55 2011 New Revision: 587 Log: Add latest links for quicklisp Added: public_html/releases/usocket-latest.tar.gz (contents, props changed) public_html/releases/usocket-latest.tar.gz.asc (contents, props changed) Added: public_html/releases/usocket-latest.tar.gz ============================================================================== --- (empty file) +++ public_html/releases/usocket-latest.tar.gz Mon Mar 21 09:47:55 2011 @@ -0,0 +1 @@ +link usocket-0.5.0.tar.gz \ No newline at end of file Added: public_html/releases/usocket-latest.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/usocket-latest.tar.gz.asc Mon Mar 21 09:47:55 2011 @@ -0,0 +1 @@ +link usocket-0.5.0.tar.gz.asc \ No newline at end of file From ctian at common-lisp.net Tue Mar 22 01:46:46 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 21 Mar 2011 21:46:46 -0400 Subject: [usocket-cvs] r588 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Mon Mar 21 21:46:46 2011 New Revision: 588 Log: Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 21 21:46:46 2011 @@ -199,6 +199,10 @@ (if usock-cond (signal usock-cond :socket socket)))))) +;;; "The socket stream ends up with a bogus name as it is created before +;;; the socket is connected, making things harder to debug than they need +;;; to be." -- Nikodemus Siivola + (defvar *dummy-stream* (let ((stream (make-broadcast-stream))) (close stream) @@ -291,16 +295,29 @@ (sb-bsd-sockets:socket-close sock) (error c))))) +;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR, +;;; instead of raising a condition. It's always possible for +;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket +;;; was detected to be ready: connection might be reset, for example. +;;; +;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to +;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko + (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (with-mapped-conditions (socket) - (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) - (make-stream-socket - :socket sock - :stream (sb-bsd-sockets:socket-make-stream - sock - :input t :output t :buffering :full - :element-type (or element-type - (element-type socket))))))) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (if sock + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket)))) + + ;; next time wait for event again if we had EAGAIN/EINTR + ;; or else we'd enter a tight loop of failed accepts + (setf (%ready-p socket) nil))))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which @@ -448,7 +465,15 @@ #+(and sbcl win32) (progn - (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) + ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET + ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It + ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED, + ;; which is always machine word-sized (exactly as intptr_t; + ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not + ;; enough -- potentially)." + ;; -- Anton Kovalenko , Mar 22, 2011 + (sb-alien:define-alien-type ws-socket sb-alien:signed) + (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) (sb-alien:define-alien-type ws-event sb-alien::hinstance) @@ -556,13 +581,33 @@ (defun (setf os-wait-list-%wait) (value wait-list) (setf (sb-alien:deref (wait-list-%wait wait-list)) value)) + ;; "Event handles are leaking in current SBCL backend implementation, + ;; because of SBCL-unfriendly usage of finalizers. + ;; + ;; "SBCL never calls a finalizer that closes over a finalized object: a + ;; reference from that closure prevents its collection forever. That's + ;; the case with USOCKET in %SETUP-WAIT-LIST. + ;; + ;; "I use the following redefinition of %SETUP-WAIT-LIST: + ;; + ;; "Of course it may be rewritten with more clarity, but you can see the + ;; core idea: I'm closing over those components of WAIT-LIST that I need + ;; for finalization, not the wait-list itself. With the original + ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted + ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST." + ;; + ;; -- Anton Kovalenko , Mar 22, 2011 + (defun %setup-wait-list (wait-list) (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event)) (setf (os-wait-list-%wait wait-list) (wsa-event-create)) (sb-ext:finalize wait-list - #'(lambda () (unless (null (wait-list-%wait wait-list)) - (wsa-event-close (os-wait-list-%wait wait-list)) - (sb-alien:free-alien (wait-list-%wait wait-list)))))) + (let ((event-handle (os-wait-list-%wait wait-list)) + (alien (wait-list-%wait wait-list))) + #'(lambda () + (wsa-event-close event-handle) + (unless (null alien) + (sb-alien:free-alien alien)))))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter From ctian at common-lisp.net Mon Mar 28 17:23:38 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 13:23:38 -0400 Subject: [usocket-cvs] r589 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Mon Mar 28 13:23:37 2011 New Revision: 589 Log: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 13:23:37 2011 @@ -173,6 +173,8 @@ (sb-bsd-sockets:operation-timeout-error . timeout-error) #-ecl (sb-sys:io-timeout . timeout-error) + #+sbcl + (sb-ext:timeout . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error @@ -248,15 +250,17 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) + (labels ((connect () + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) + (if timeout + (sb-ext:with-timeout timeout (connect)) + (connect))) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :full - #+sbcl #+sbcl - :timeout timeout :element-type element-type)))) (:datagram (when (or local-host local-port) @@ -317,6 +321,7 @@ ;; next time wait for event again if we had EAGAIN/EINTR ;; or else we'd enter a tight loop of failed accepts + #+win32 (setf (%ready-p socket) nil))))) ;; Sockets and their associated streams are modelled as From ctian at common-lisp.net Mon Mar 28 17:37:32 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 13:37:32 -0400 Subject: [usocket-cvs] r590 - in usocket/branches/0.5.x: . test Message-ID: Author: ctian Date: Mon Mar 28 13:37:31 2011 New Revision: 590 Log: Clean-up useless test help files, never figure out how to use them... Removed: usocket/branches/0.5.x/Makefile usocket/branches/0.5.x/run-usocket-tests.sh usocket/branches/0.5.x/test/abcl.conf.in usocket/branches/0.5.x/test/allegro.conf.in usocket/branches/0.5.x/test/clisp.conf.in usocket/branches/0.5.x/test/cmucl.conf.in usocket/branches/0.5.x/test/sbcl.conf.in usocket/branches/0.5.x/test/your-lisp.conf.in From ctian at common-lisp.net Mon Mar 28 18:28:20 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 14:28:20 -0400 Subject: [usocket-cvs] r591 - usocket/branches/0.5.x/test Message-ID: Author: ctian Date: Mon Mar 28 14:28:19 2011 New Revision: 591 Log: [test] Try to produce same detailed error type on all platforms Modified: usocket/branches/0.5.x/test/test-usocket.lisp Modified: usocket/branches/0.5.x/test/test-usocket.lisp ============================================================================== --- usocket/branches/0.5.x/test/test-usocket.lisp (original) +++ usocket/branches/0.5.x/test/test-usocket.lisp Mon Mar 28 14:28:19 2011 @@ -74,27 +74,13 @@ nil) (deftest socket-failure.1 - (with-caught-conditions (#-(or cmu lispworks armedbear openmcl mcl) - usocket:network-unreachable-error - #+(or cmu lispworks armedbear) - usocket:unknown-error - #+(or openmcl mcl) - usocket:timeout-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) :unreach) nil) (deftest socket-failure.2 - (with-caught-conditions (#+(or lispworks armedbear) - usocket:unknown-error - #+cmu - usocket:network-unreachable-error - #+(or openmcl mcl) - usocket:timeout-error - #-(or lispworks armedbear cmu openmcl mcl) - usocket:host-unreachable-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port :unreach) nil) From ctian at common-lisp.net Mon Mar 28 18:30:35 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 14:30:35 -0400 Subject: [usocket-cvs] r592 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Mon Mar 28 14:30:35 2011 New Revision: 592 Log: [LispWorks] Detect networking error types by (LW:ERRNO-VALUE). Modified: usocket/branches/0.5.x/backend/lispworks.lisp Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Mon Mar 28 14:30:35 2011 @@ -9,7 +9,7 @@ (require "comm") #+lispworks3 - (error "LispWorks 3 is not supported by USOCKET.")) + (error "LispWorks 3 is not supported by USOCKET any more.")) ;;; --------------------------------------------------------------------------- ;;; Warn if multiprocessing is not running on Lispworks @@ -40,17 +40,15 @@ #+win32 "ws2_32") (defun get-host-name () - (multiple-value-bind (retcode name) + (multiple-value-bind (return-code name) (get-host-name-internal) - (when (= 0 retcode) + (when (zerop return-code) name))) #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) - (cons (mapcar #'(lambda (y) - (+ 10000 y)) - (car x)) + (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) (cdr x))) z)) @@ -62,7 +60,7 @@ (append +unix-errno-condition-map+ +unix-errno-error-map+)) -(defun raise-or-signal-socket-error (errno socket) +(defun raise-usock-err (errno socket &optional condition) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) (if usock-err @@ -71,27 +69,13 @@ (signal usock-err :socket socket)) (error 'unknown-error :socket socket - :real-error nil)))) - -(defun raise-usock-err (errno socket &optional condition) - (let* ((usock-err - (cdr (assoc errno +lispworks-error-map+ - :test #'member)))) - (if usock-err - (if (subtypep usock-err 'error) - (error usock-err :socket socket) - (signal usock-err :socket)) - (error 'unknown-error - :socket socket :real-error condition)))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (typecase condition - (simple-error (destructuring-bind (&optional host port err-msg errno) - (simple-condition-format-arguments condition) - (declare (ignore host port err-msg)) - (raise-usock-err errno socket condition))))) + (condition (let ((errno (lispworks:errno-value))) + (raise-usock-err errno socket condition))))) (defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.") @@ -294,17 +278,20 @@ (if stream (make-stream-socket :socket (comm:socket-stream-socket stream) :stream stream) - (error 'unknown-error)))) + ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout + (error 'timeout-error)))) (:datagram (let ((usocket (make-datagram-socket (if (and host port) - (connect-to-udp-server (host-to-hostname host) port - :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout) - (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout)) + (with-mapped-conditions () + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout)) + (with-mapped-conditions () + (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout))) :connected-p (and host port t)))) (hcl:flag-special-free-action usocket) usocket)))) From ctian at common-lisp.net Mon Mar 28 23:02:54 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 19:02:54 -0400 Subject: [usocket-cvs] r593 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Mon Mar 28 19:02:54 2011 New Revision: 593 Log: Fixed for ECL (always forget this) Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 19:02:54 2011 @@ -250,11 +250,14 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) + #+sbcl (labels ((connect () (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) (if timeout (sb-ext:with-timeout timeout (connect)) (connect))) + #+ecl + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket From ctian at common-lisp.net Mon Mar 28 23:09:39 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 19:09:39 -0400 Subject: [usocket-cvs] r594 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Mon Mar 28 19:09:39 2011 New Revision: 594 Log: [SBCL] change the use of WITH-TIMEOUT into a nested version for safe purpose. Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 19:09:39 2011 @@ -210,6 +210,22 @@ (close stream) stream)) +;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads. +;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29 + +#+sbcl +(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body) + (let ((tag-sym (gensym)) + (timer-sym (gensym))) + `(block ,tag-sym + (let ((,timer-sym + (sb-ext:make-timer + #'(lambda () + (return-from ,tag-sym (progn , at timeout-body)))))) + (sb-ext:schedule-timer ,timer-sym ,seconds) + (unwind-protect (progn , at timed-body) + (sb-ext:unschedule-timer ,timer-sym)))))) + (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port @@ -254,7 +270,7 @@ (labels ((connect () (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) (if timeout - (sb-ext:with-timeout timeout (connect)) + (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) (connect))) #+ecl (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) From ctian at common-lisp.net Mon Mar 28 23:22:25 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Mon, 28 Mar 2011 19:22:25 -0400 Subject: [usocket-cvs] r595 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Mon Mar 28 19:22:25 2011 New Revision: 595 Log: Update ChangeLog Modified: usocket/branches/0.5.x/CHANGES Modified: usocket/branches/0.5.x/CHANGES ============================================================================== --- usocket/branches/0.5.x/CHANGES (original) +++ usocket/branches/0.5.x/CHANGES Mon Mar 28 19:22:25 2011 @@ -5,3 +5,18 @@ * Add WAIT-FOR-INPUT support for SBCL and ECL on win32. * Simple TCP and UDP server API: SOCKET-SERVER * Lots of bug fixed since 0.4.1 + +0.5.1: + +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko +* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. +* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". +* Enhancement: [LispWorks] Better network error type detection on LispWorks. + +[TODO] + +* Bugfix: now SOCKET-CONNECT/Datagram works on CLISP +* New feature: CLISP support UDP without RAWSOCK (using FFI interface) +* 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) From ctian at common-lisp.net Tue Mar 29 11:49:06 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 07:49:06 -0400 Subject: [usocket-cvs] r596 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Tue Mar 29 07:49:05 2011 New Revision: 596 Log: [SBCL] switch to a async unwind safe version of %WITH-TIMEOUT (Nikodemus Siivola) Modified: usocket/branches/0.5.x/backend/sbcl.lisp Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Tue Mar 29 07:49:05 2011 @@ -210,21 +210,42 @@ (close stream) stream)) -;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads. -;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29 +;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch +;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS +;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than +;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola #+sbcl -(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body) - (let ((tag-sym (gensym)) - (timer-sym (gensym))) - `(block ,tag-sym - (let ((,timer-sym - (sb-ext:make-timer - #'(lambda () - (return-from ,tag-sym (progn , at timeout-body)))))) - (sb-ext:schedule-timer ,timer-sym ,seconds) - (unwind-protect (progn , at timed-body) - (sb-ext:unschedule-timer ,timer-sym)))))) +(defmacro %with-timeout ((seconds timeout-form) &body body) + "Runs BODY as an implicit PROGN with timeout of SECONDS. If +timeout occurs before BODY has finished, BODY is unwound and +TIMEOUT-FORM is executed with its values returned instead. + +Note that BODY is unwound asynchronously when a timeout occurs, +so unless all code executed during it -- including anything +down the call chain -- is asynch unwind safe, bad things will +happen. Use with care." + (let ((exec (gensym)) (unwind (gensym)) (timer (gensym)) + (timeout (gensym)) (block (gensym))) + `(block ,block + (tagbody + (flet ((,unwind () + (go ,timeout)) + (,exec () + , at body)) + (declare (dynamic-extent #',exec #',unwind)) + (let ((,timer (sb-ext:make-timer #',unwind))) + (declare (dynamic-extent ,timer)) + (sb-sys:without-interrupts + (unwind-protect + (progn + (sb-ext:schedule-timer ,timer ,seconds) + (return-from ,block + (sb-sys:with-local-interrupts + (,exec)))) + (sb-ext:unschedule-timer ,timer))))) + ,timeout + (return-from ,block ,timeout-form))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) From ctian at common-lisp.net Tue Mar 29 13:01:09 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:01:09 -0400 Subject: [usocket-cvs] r597 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Tue Mar 29 09:01:08 2011 New Revision: 597 Log: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. Modified: usocket/branches/0.5.x/backend/cmucl.lisp Modified: usocket/branches/0.5.x/backend/cmucl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/cmucl.lisp (original) +++ usocket/branches/0.5.x/backend/cmucl.lisp Tue Mar 29 09:01:08 2011 @@ -106,7 +106,7 @@ (with-mapped-conditions (socket) (ext:create-inet-socket protocol))))) (if socket - (let ((usocket (make-datagram-socket socket))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) usocket) @@ -159,9 +159,28 @@ (defmethod socket-close :after ((socket datagram-usocket)) (setf (%open-p socket) nil)) +#+unicode +(defun %unix-send (fd buffer length flags) + (alien:alien-funcall + (alien:extern-alien "send" + (function c-call:int + c-call:int + system:system-area-pointer + c-call:int + c-call:int)) + fd + (system:vector-sap buffer) + length + flags)) + (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))) + (if (and host port) + (ext:inet-sendto (socket usocket) buffer length (host-to-hbo host) port) + #-unicode + (unix:unix-send (socket usocket) buffer length 0) + #+unicode + (%unix-send (socket usocket) buffer length 0)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (let ((real-buffer (or buffer From ctian at common-lisp.net Tue Mar 29 13:03:02 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:03:02 -0400 Subject: [usocket-cvs] r598 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Tue Mar 29 09:03:02 2011 New Revision: 598 Log: [CCL] Fixed SOCKET-CONNECT returning NIL when doing UDP connections (involved in r583, after 0.5.0) Modified: usocket/branches/0.5.x/backend/openmcl.lisp Modified: usocket/branches/0.5.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/openmcl.lisp (original) +++ usocket/branches/0.5.x/backend/openmcl.lisp Tue Mar 29 09:03:02 2011 @@ -108,10 +108,11 @@ :format :binary)) (usocket (make-datagram-socket mcl-sock))) (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")) - (setf (connected-p usocket) t))))))) + (ccl::inet-connect (ccl::socket-device mcl-sock) + (ccl::host-as-inet-host host) + (ccl::port-as-inet-port port "udp"))) + (setf (connected-p usocket) t) + usocket))))) (defun socket-listen (host port &key reuseaddress From ctian at common-lisp.net Tue Mar 29 13:04:28 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:04:28 -0400 Subject: [usocket-cvs] r599 - in usocket/branches/0.5.x: . test Message-ID: Author: ctian Date: Tue Mar 29 09:04:27 2011 New Revision: 599 Log: Add some Unit Tests for Datagram sockets Added: usocket/branches/0.5.x/test/test-datagram.lisp (contents, props changed) Modified: usocket/branches/0.5.x/test/test-condition.lisp usocket/branches/0.5.x/usocket-test.asd Modified: usocket/branches/0.5.x/test/test-condition.lisp ============================================================================== --- usocket/branches/0.5.x/test/test-condition.lisp (original) +++ usocket/branches/0.5.x/test/test-condition.lisp Tue Mar 29 09:04:27 2011 @@ -11,7 +11,7 @@ (deftest timeout-error.1 (with-caught-conditions (usocket:timeout-error nil) - (usocket:socket-connect "common-lisp.net" 81 :timeout 1) + (usocket:socket-connect "common-lisp.net" 81 :timeout 0) t) nil) Added: usocket/branches/0.5.x/test/test-datagram.lisp ============================================================================== --- (empty file) +++ usocket/branches/0.5.x/test/test-datagram.lisp Tue Mar 29 09:04:27 2011 @@ -0,0 +1,45 @@ +;;;; $Id$ +;;;; $URL$ + +(in-package :usocket-test) + +(defvar *echo-server* + (usocket:socket-server "127.0.0.1" 10243 #'identity nil + :in-new-thread t + :protocol :datagram)) + +(defparameter *max-buffer-size* 32) + +(defvar *send-buffer* + (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0)) + +(defvar *receive-buffer* + (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun clean-buffers () + (fill *send-buffer* 0) + (fill *receive-buffer* 0)) + +;;; UDP Send Test #1: connected socket +(deftest udp-send.1 + (let ((s (usocket:socket-connect "127.0.0.1" 10243 :protocol :datagram))) + (clean-buffers) + (replace *send-buffer* #(1 2 3 4 5)) + (usocket:socket-send s *send-buffer* 5) + (usocket:wait-for-input s :timeout 3) + (multiple-value-bind (buffer size host port) + (usocket:socket-receive s *receive-buffer* *max-buffer-size*) + (reduce #'+ *receive-buffer* :start 0 :end 5))) + 15) + +;;; UDP Send Test #2: unconnected socket +(deftest udp-send.2 + (let ((s (usocket:socket-connect nil nil :protocol :datagram))) + (clean-buffers) + (replace *send-buffer* #(1 2 3 4 5)) + (usocket:socket-send s *send-buffer* 5 :host "127.0.0.1" :port 10243) + (usocket:wait-for-input s :timeout 3) + (multiple-value-bind (buffer size host port) + (usocket:socket-receive s *receive-buffer* *max-buffer-size*) + (reduce #'+ *receive-buffer* :start 0 :end 5))) + 15) Modified: usocket/branches/0.5.x/usocket-test.asd ============================================================================== --- usocket/branches/0.5.x/usocket-test.asd (original) +++ usocket/branches/0.5.x/usocket-test.asd Tue Mar 29 09:04:27 2011 @@ -21,11 +21,11 @@ :depends-on (:usocket :rt) :components ((:module "test" + :serial t :components ((:file "package") - (:file "test-usocket" - :depends-on ("package")) - (:file "test-condition" - :depends-on ("test-usocket")))))) + (:file "test-usocket") + (:file "test-condition") + (:file "test-datagram"))))) (defmethod perform ((op test-op) (c (eql (find-system :usocket-test)))) (funcall (intern "DO-TESTS" "USOCKET-TEST"))) From ctian at common-lisp.net Tue Mar 29 13:28:31 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:28:31 -0400 Subject: [usocket-cvs] r600 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Tue Mar 29 09:28:30 2011 New Revision: 600 Log: [CCL] remove the useless OPENMCL-SOCKET:SOCKET-CONNECT call in SOCKET-CONNECT; set :input-timeout to TIMEOUT keyword argument. Modified: usocket/branches/0.5.x/backend/openmcl.lisp Modified: usocket/branches/0.5.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/openmcl.lisp (original) +++ usocket/branches/0.5.x/backend/openmcl.lisp Tue Mar 29 09:28:30 2011 @@ -97,7 +97,6 @@ :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 @@ -105,6 +104,7 @@ :type :datagram :local-host (when local-host (host-to-hostname local-host)) :local-port local-port + :input-timeout timeout :format :binary)) (usocket (make-datagram-socket mcl-sock))) (when (and host port) From ctian at common-lisp.net Tue Mar 29 13:29:33 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:29:33 -0400 Subject: [usocket-cvs] r601 - usocket/branches/0.5.x/test Message-ID: Author: ctian Date: Tue Mar 29 09:29:33 2011 New Revision: 601 Log: Unit test: using random echo server port on test, this allow multiple tests running at the same time on different platforms. Modified: usocket/branches/0.5.x/test/test-datagram.lisp Modified: usocket/branches/0.5.x/test/test-datagram.lisp ============================================================================== --- usocket/branches/0.5.x/test/test-datagram.lisp (original) +++ usocket/branches/0.5.x/test/test-datagram.lisp Tue Mar 29 09:29:33 2011 @@ -3,10 +3,16 @@ (in-package :usocket-test) -(defvar *echo-server* - (usocket:socket-server "127.0.0.1" 10243 #'identity nil - :in-new-thread t - :protocol :datagram)) +(defvar *echo-server*) +(defvar *echo-server-port*) + +(eval-when (:load-toplevel :execute) + (multiple-value-bind (thread socket) + (usocket:socket-server "127.0.0.1" 0 #'identity nil + :in-new-thread t + :protocol :datagram) + (setq *echo-server* thread + *echo-server-port* (usocket:get-local-port socket)))) (defparameter *max-buffer-size* 32) @@ -22,13 +28,14 @@ ;;; UDP Send Test #1: connected socket (deftest udp-send.1 - (let ((s (usocket:socket-connect "127.0.0.1" 10243 :protocol :datagram))) + (let ((s (usocket:socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) (usocket:socket-send s *send-buffer* 5) (usocket:wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) + (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5))) 15) @@ -37,9 +44,10 @@ (let ((s (usocket:socket-connect nil nil :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) - (usocket:socket-send s *send-buffer* 5 :host "127.0.0.1" :port 10243) + (usocket:socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*) (usocket:wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) + (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5))) 15) From ctian at common-lisp.net Tue Mar 29 13:31:40 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:31:40 -0400 Subject: [usocket-cvs] r602 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Tue Mar 29 09:31:40 2011 New Revision: 602 Log: SOCKET-SERVER return a second value to indicate the created underlying usocket object when running in new thread mode. This make server debugging work easier. Modified: usocket/branches/0.5.x/server.lisp Modified: usocket/branches/0.5.x/server.lisp ============================================================================== --- usocket/branches/0.5.x/server.lisp (original) +++ usocket/branches/0.5.x/server.lisp Tue Mar 29 09:31:40 2011 @@ -31,8 +31,8 @@ :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread - (spawn-thread "USOCKET Server" #'real-call) - (real-call))))) + (values (spawn-thread "USOCKET Server" #'real-call) socket) + (real-call))))) (defvar *remote-host*) (defvar *remote-port*) From ctian at common-lisp.net Tue Mar 29 13:32:14 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 09:32:14 -0400 Subject: [usocket-cvs] r603 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Tue Mar 29 09:32:14 2011 New Revision: 603 Log: Update ChangeLog Modified: usocket/branches/0.5.x/CHANGES Modified: usocket/branches/0.5.x/CHANGES ============================================================================== --- usocket/branches/0.5.x/CHANGES (original) +++ usocket/branches/0.5.x/CHANGES Tue Mar 29 09:32:14 2011 @@ -12,7 +12,9 @@ * Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. * Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. * Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". +* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. * Enhancement: [LispWorks] Better network error type detection on LispWorks. +* Enhancement: SOCKET-SERVER return a second value to indicate the created underlying usocket object when running in new thread mode. This make server debugging work easier. [TODO] From ctian at common-lisp.net Tue Mar 29 17:04:30 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Tue, 29 Mar 2011 13:04:30 -0400 Subject: [usocket-cvs] r604 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Tue Mar 29 13:04:30 2011 New Revision: 604 Log: [CLISP] Fixed SOCKET-CONNECT / UDP for RAWSOCK; Basic FFI framework. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Tue Mar 29 13:04:30 2011 @@ -5,9 +5,15 @@ (in-package :usocket) +(eval-when (:compile-toplevel :load-toplevel :execute) + #-ffi + (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.") + #-(or ffi rawsock) + (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support.")) + ;; utility routine for looking up the current host name #+ffi -(FFI:DEF-CALL-OUT get-host-name-internal +(ffi:def-call-out get-host-name-internal (:name "gethostname") (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) :OUT :ALLOCA) @@ -61,26 +67,36 @@ timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) - (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) (when local-host (unsupported 'local-host 'socket-connect)) (when local-port (unsupported 'local-port 'socket-connect)) - - (let ((socket) - (hostname (host-to-hostname host))) - (with-mapped-conditions (socket) - (setf socket - (if timeout - (socket:socket-connect port hostname - :element-type element-type - :buffered t - :timeout timeout) - (socket:socket-connect port hostname - :element-type element-type - :buffered t)))) - (make-stream-socket :socket socket - :stream socket))) ;; the socket is a stream too + (case protocol + (:stream + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (if timeout + (socket:socket-connect port hostname + :element-type element-type + :buffered t + :timeout timeout) + (socket:socket-connect port hostname + :element-type element-type + :buffered t)))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + (:datagram + #+rawsock + (socket-create-datagram (or local-port *auto-port*) + :local-host (or local-host *wildcard-host*) + :remote-host host + :remote-port port) + #+(and ffi (not rawsock)) + () + #-(or rawsock ffi) + (unsupported '(protocol :datagram) 'socket-connect)))) (defun socket-listen (host port &key reuseaddress @@ -146,7 +162,6 @@ (defmethod get-peer-port ((usocket stream-usocket)) (nth-value 1 (get-peer-name usocket))) - (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) @@ -176,14 +191,12 @@ (setf (state x) :READ))) wait-list)))) - -;; -;; UDP/Datagram sockets! -;; +;;; +;;; UDP/Datagram sockets (RAWSOCK version) +;;; #+rawsock (progn - (defun make-sockaddr_in () (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) @@ -209,7 +222,7 @@ (connect sock rsock_addr)) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) - (defun socket-receive (socket buffer &key (size (length buffer))) + (defun socket-receive (socket buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) @@ -218,44 +231,74 @@ (rv (if sockaddr (rawsock:recvfrom sock buffer sockaddr :start 0 - :end size) + :end length) (rawsock:recv sock buffer :start 0 - :end size)))) + :end length)))) (values buffer rv - (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4) - (port-from-octet-buffer (sockaddr-data sockaddr) 2))))) + (ip-from-octet-buffer (sockaddr-data sockaddr) 4) + (port-from-octet-buffer (sockaddr-data sockaddr) 2)))) - (defun socket-send (socket buffer &key address (size (length buffer))) + (defun socket-send (socket buffer length &key host port) "Returns the number of octets sent." (let* ((sock (socket socket)) - (sockaddr (when address + (sockaddr (when (and host port) (rawsock:make-sockaddr :INET (fill-sockaddr_in (make-sockaddr_in) - (host-byte-order - (second address)) - (first address))))) - (rv (if address + (host-byte-order host) + port)))) + (rv (if (and host port) (rawsock:sendto sock buffer sockaddr :start 0 - :end size) + :end length) (rawsock:send sock buffer :start 0 - :end size)))) + :end length)))) rv)) (defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket))) - - ) +) ; progn + +;;; +;;; UDP/Datagram sockets (FFI version) +;;; -#-rawsock +#+(and ffi (not rawsock)) (progn - (warn "This image doesn't contain the RAWSOCK package. -To enable UDP socket support, please be sure to use the -Kfull parameter -at startup, or to enable RAWSOCK support during compilation.") - ) + (ffi:def-c-struct sockaddr + ) + + (ffi:def-c-struct sockaddr_in + ) + + (ffi:def-call-out %sendto (:name "sendto") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8)) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr)) + (address-len ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %recvfrom (:name "recvfrom") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8) :out) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr) :out) + (address-len (ffi:c-ptr ffi:int) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) +) ; progn From ctian at common-lisp.net Wed Mar 30 05:41:42 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 01:41:42 -0400 Subject: [usocket-cvs] r605 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Wed Mar 30 01:41:42 2011 New Revision: 605 Log: [LispWorks] fixed HANDLE-CONDITION on win32, should be (wsa-get-last-error) instead of (lw:errno-value) Modified: usocket/branches/0.5.x/backend/lispworks.lisp Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Wed Mar 30 01:41:42 2011 @@ -74,14 +74,15 @@ (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (typecase condition - (condition (let ((errno (lispworks:errno-value))) + (condition (let ((errno #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) (raise-usock-err errno socket condition))))) (defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.") (defconstant *sockopt_so_rcvtimeo* - #+(not linux) #x1006 + #-linux #x1006 #+linux 20 "Socket receive timeout") From ctian at common-lisp.net Wed Mar 30 05:49:11 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 01:49:11 -0400 Subject: [usocket-cvs] r606 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Wed Mar 30 01:49:11 2011 New Revision: 606 Log: [CLISP] more FFI basic definitions. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Wed Mar 30 01:49:11 2011 @@ -270,12 +270,35 @@ #+(and ffi (not rawsock)) (progn + ;; C primitive types + (ffi:def-c-type size_t) + (ffi:def-c-type in_addr_t ffi:uint32) + (ffi:def-c-type in_port_t ffi:uint16) + (ffi:def-c-type sa_family_t ffi:uint8) + (ffi:def-c-type socklen_t ffi:uint32) + + ;; C structures (ffi:def-c-struct sockaddr - ) + (sa_len ffi:uint8) + (sa_family sa_family_t) + (sa_data (ffi:c-array ffi:char 14))) + + #+ignore + (ffi:def-c-struct in_addr + (s_addr in_addr_t)) (ffi:def-c-struct sockaddr_in - ) + (sin_len ffi:uint8) + (sin_family sa_family_t) + (sin_port in_port_t) + (sin_addr in_addr_t) ; should be struct in_addr + (sin_zero (ffi:c-array ffi:char 8))) + + (ffi:def-c-struct timeval + (tv_sec ffi:long) + (tv_usec ffi:long)) + ;; foreign functions (ffi:def-call-out %sendto (:name "sendto") (:arguments (socket ffi:int) (buffer (ffi:c-ptr ffi:uint8)) @@ -301,4 +324,53 @@ (:language #-win32 :stdc #+win32 :stdc-stdcall) (:return-type ffi:int)) + + (ffi:def-call-out %socket (:name "socket") + (:arguments (family ffi:int) + (type ffi:int) + (protocol ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getsockopt (:name "getsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen (ffi:c-ptr socklen_t) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %setsockopt (:name "setsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + ;; socket constants + (defconstant +socket-af-inet+ 2) + (defconstant +socket-pf-unspec+ 0) + (defconstant +socket-sock-dgram+ 2) + (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") + + (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 (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-pf-unspec+))) + (if socket-fd + (progn + ) + (error "cannot create socket")))) ) ; progn From ctian at common-lisp.net Wed Mar 30 06:05:35 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 02:05:35 -0400 Subject: [usocket-cvs] r607 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Wed Mar 30 02:05:35 2011 New Revision: 607 Log: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions! Modified: usocket/branches/0.5.x/usocket.lisp Modified: usocket/branches/0.5.x/usocket.lisp ============================================================================== --- usocket/branches/0.5.x/usocket.lisp (original) +++ usocket/branches/0.5.x/usocket.lisp Wed Mar 30 02:05:35 2011 @@ -367,16 +367,16 @@ (aref buffer b))))) (defmacro port-to-octet-buffer (port buffer &key (start 0)) - `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) (defmacro ip-to-octet-buffer (ip buffer &key (start 0)) - `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start)) (defmacro port-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 2 ,start)) + `(octet-buffer-to-integer ,buffer 2 :start ,start)) (defmacro ip-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 4 ,start)) + `(octet-buffer-to-integer ,buffer 4 :start ,start)) ;; ;; IP(v4) utility functions From ctian at common-lisp.net Wed Mar 30 06:43:35 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 02:43:35 -0400 Subject: [usocket-cvs] r608 - in usocket/branches/0.5.x: . backend Message-ID: Author: ctian Date: Wed Mar 30 02:43:34 2011 New Revision: 608 Log: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. Modified: usocket/branches/0.5.x/backend/clisp.lisp usocket/branches/0.5.x/usocket.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Wed Mar 30 02:43:34 2011 @@ -33,6 +33,17 @@ #-ffi "localhost") +(defun get-host-by-address (address) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) + (posix:hostent-name hostent)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr name))) + (mapcar #'host-to-vector-quad + (posix:hostent-addr-list hostent))))) + #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) @@ -69,8 +80,6 @@ (declare (ignore nodelay)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) - (when local-host (unsupported 'local-host 'socket-connect)) - (when local-port (unsupported 'local-port 'socket-connect)) (case protocol (:stream (let ((socket) @@ -202,8 +211,8 @@ (declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr_in ip port) - (port-to-octet-buffer sockaddr_in port) - (ip-to-octet-buffer sockaddr_in ip :start 2) + (port-to-octet-buffer port sockaddr_in) + (ip-to-octet-buffer ip sockaddr_in :start 2) sockaddr_in) (defun socket-create-datagram (local-port @@ -217,17 +226,17 @@ (fill-sockaddr_in (make-sockaddr_in) remote-host (or remote-port local-port))))) - (bind sock lsock_addr) + (rawsock:bind sock lsock_addr) (when rsock_addr - (connect sock rsock_addr)) + (rawsock:connect sock rsock_addr)) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) - (defun socket-receive (socket buffer length &key) + (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) (sockaddr (when (not (connected-p socket)) - (rawsock:make-sockaddr))) + (rawsock:make-sockaddr :inet))) (rv (if sockaddr (rawsock:recvfrom sock buffer sockaddr :start 0 @@ -237,10 +246,10 @@ :end length)))) (values buffer rv - (ip-from-octet-buffer (sockaddr-data sockaddr) 4) - (port-from-octet-buffer (sockaddr-data sockaddr) 2)))) + (ip-from-octet-buffer (rawsock:sockaddr-data sockaddr) :start 4) + (port-from-octet-buffer (rawsock:sockaddr-data sockaddr) :start 2)))) - (defun socket-send (socket buffer length &key host port) + (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) "Returns the number of octets sent." (let* ((sock (socket socket)) (sockaddr (when (and host port) Modified: usocket/branches/0.5.x/usocket.lisp ============================================================================== --- usocket/branches/0.5.x/usocket.lisp (original) +++ usocket/branches/0.5.x/usocket.lisp Wed Mar 30 02:43:34 2011 @@ -470,43 +470,41 @@ ;; DNS helper functions ;; -#-clisp -(progn - (defun get-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (car hosts))) - - (defun get-random-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (when hosts - (elt hosts (random (length hosts)))))) +(defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + +(defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts)))))) - (defun host-to-vector-quad (host) - "Translate a host specification (vector quad, dotted quad or domain name) +(defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." - (etypecase host - (string (let* ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - ;; valid IP dotted quad? - ip - (get-random-host-by-name host)))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - host) - (integer (hbo-to-vector-quad host)))) - - (defun host-to-hbo (host) - (etypecase host - (string (let ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - (host-byte-order ip) - (host-to-hbo (get-host-by-name host))))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - (host-byte-order host)) - (integer host)))) + (etypecase host + (string (let* ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + host) + (integer (hbo-to-vector-quad host)))) + +(defun host-to-hbo (host) + (etypecase host + (string (let ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + (host-byte-order host)) + (integer host))) ;; ;; Other utility functions From ctian at common-lisp.net Wed Mar 30 06:44:16 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 02:44:16 -0400 Subject: [usocket-cvs] r609 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Wed Mar 30 02:44:16 2011 New Revision: 609 Log: Update ChangeLog Modified: usocket/branches/0.5.x/CHANGES Modified: usocket/branches/0.5.x/CHANGES ============================================================================== --- usocket/branches/0.5.x/CHANGES (original) +++ usocket/branches/0.5.x/CHANGES Wed Mar 30 02:44:16 2011 @@ -8,13 +8,15 @@ 0.5.1: -* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko +* Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions! * Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko * Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. * Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". * Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. -* Enhancement: [LispWorks] Better network error type detection on LispWorks. +* Bugfix: [LispWorks] Better network error type detection on LispWorks. * Enhancement: SOCKET-SERVER return a second value to indicate the created underlying usocket object when running in new thread mode. This make server debugging work easier. +* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. [TODO] From ctian at common-lisp.net Wed Mar 30 07:17:23 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 03:17:23 -0400 Subject: [usocket-cvs] r610 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Wed Mar 30 03:17:22 2011 New Revision: 610 Log: [CLISP] Fixed UDP (datagram) support (RAWSOCK version), confirmed by CL-NET-SNMP. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Wed Mar 30 03:17:22 2011 @@ -226,34 +226,32 @@ (fill-sockaddr_in (make-sockaddr_in) remote-host (or remote-port local-port))))) - (rawsock:bind sock lsock_addr) + (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) (when rsock_addr - (rawsock:connect sock rsock_addr)) + (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr))) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) - (sockaddr (when (not (connected-p socket)) + (sockaddr (unless (connected-p socket) (rawsock:make-sockaddr :inet))) (rv (if sockaddr - (rawsock:recvfrom sock buffer sockaddr - :start 0 - :end length) - (rawsock:recv sock buffer - :start 0 - :end length)))) - (values buffer - rv - (ip-from-octet-buffer (rawsock:sockaddr-data sockaddr) :start 4) - (port-from-octet-buffer (rawsock:sockaddr-data sockaddr) :start 2)))) + (rawsock:recvfrom sock buffer sockaddr :start 0 :end length) + (rawsock:recv sock buffer :start 0 :end length))) + (host 0) (port 0)) + (unless (connected-p socket) + (let ((data (rawsock:sockaddr-data sockaddr))) + (setq host (ip-from-octet-buffer data :start 4) + port (port-from-octet-buffer data :start 2)))) + (values buffer rv host port))) (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) "Returns the number of octets sent." (let* ((sock (socket socket)) (sockaddr (when (and host port) - (rawsock:make-sockaddr :INET + (rawsock:make-sockaddr :inet (fill-sockaddr_in (make-sockaddr_in) (host-byte-order host) From ctian at common-lisp.net Wed Mar 30 07:21:56 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 03:21:56 -0400 Subject: [usocket-cvs] r611 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Wed Mar 30 03:21:56 2011 New Revision: 611 Log: Update ChangeLog Modified: usocket/branches/0.5.x/CHANGES Modified: usocket/branches/0.5.x/CHANGES ============================================================================== --- usocket/branches/0.5.x/CHANGES (original) +++ usocket/branches/0.5.x/CHANGES Wed Mar 30 03:21:56 2011 @@ -15,12 +15,12 @@ * Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". * Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. * Bugfix: [LispWorks] Better network error type detection on LispWorks. -* Enhancement: SOCKET-SERVER return a second value to indicate the created underlying usocket object when running in new thread mode. This make server debugging work easier. +* Bugfix: [CLISP] Fixed UDP (Datagram) support (RAWSOCK version), confirmed by CL-NET-SNMP. +* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode. * Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. [TODO] -* Bugfix: now SOCKET-CONNECT/Datagram works on CLISP * New feature: CLISP support UDP without RAWSOCK (using FFI interface) * 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) From ctian at common-lisp.net Wed Mar 30 07:34:03 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 03:34:03 -0400 Subject: [usocket-cvs] r612 - usocket/branches/0.4.x Message-ID: Author: ctian Date: Wed Mar 30 03:34:03 2011 New Revision: 612 Log: Merge r607 from branch 0.5.x Modified: usocket/branches/0.4.x/usocket.lisp Modified: usocket/branches/0.4.x/usocket.lisp ============================================================================== --- usocket/branches/0.4.x/usocket.lisp (original) +++ usocket/branches/0.4.x/usocket.lisp Wed Mar 30 03:34:03 2011 @@ -313,16 +313,16 @@ (defmacro port-to-octet-buffer (port buffer &key (start 0)) - `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) (defmacro ip-to-octet-buffer (ip buffer &key (start 0)) - `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start)) (defmacro port-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 2 ,start)) + `(octet-buffer-to-integer ,buffer 2 :start ,start)) (defmacro ip-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 4 ,start)) + `(octet-buffer-to-integer ,buffer 4 :start ,start)) ;; ;; IP(v4) utility functions From ctian at common-lisp.net Wed Mar 30 08:12:46 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 04:12:46 -0400 Subject: [usocket-cvs] r613 - usocket/trunk Message-ID: Author: ctian Date: Wed Mar 30 04:12:45 2011 New Revision: 613 Log: Basic SOCKET-OPTION framework added. Added: usocket/trunk/option.lisp (contents, props changed) Modified: usocket/trunk/package.lisp usocket/trunk/usocket-test.asd usocket/trunk/usocket.asd Added: usocket/trunk/option.lisp ============================================================================== --- (empty file) +++ usocket/trunk/option.lisp Wed Mar 30 04:12:45 2011 @@ -0,0 +1,93 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; SOCKET-OPTION, a high-level socket option get/set facility +;;;; Author: Chun Tian (binghe) + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;;; Interface definition + +(defgeneric socket-option (socket option &key) + (:documentation + "Get a socket's internal options")) + +(defgeneric (setf socket-option) (new-value socket option &key) + (:documentation + "Set a socket's internal options")) + +;;; Handling of wrong type of arguments + +(defmethod socket-option ((socket usocket) (option t) &key) + (error 'type-error :datum option :expected-type 'keyword)) + +(defmethod (setf socket-option) (new-value (socket usocket) (option t) &key) + (declare (ignore new-value)) + (socket-option socket option)) + +(defmethod socket-option ((socket usocket) (option symbol) &key) + (if (keywordp option) + (error 'unimplemented :feature option :context 'socket-option) + (error 'type-error :datum option :expected-type 'keyword))) + +(defmethod (setf socket-option) (new-value (socket usocket) (option symbol) &key) + (declare (ignore new-value)) + (socket-option socket option)) + +;;; Option: RECEIVE-TIMEOUT (RCVTIMEO) +;;; Scope: TCP & UDP + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (let ((socket (socket usocket))) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-rcvtimeo) + #+clozure + (ccl:stream-input-timeout socket) + #+cmu + (lisp::fd-stream-timeout (socket-stream usocket)) + #+ecl + (sb-bsd-sockets:sockopt-receive-timeout socket) + #+lispworks + (get-socket-receive-timeout socket) + #+mcl + () ; TODO + #+sbcl + (sb-impl::fd-stream-timeout (socket-stream usocket)) + #+scl + ())) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (declare (type number new-value)) + (let ((socket (socket usocket)) + (timeout new-value)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-rcvtimeo timeout) + #+clozure + (setf (ccl:stream-input-timeout socket) timeout) + #+cmu + (setf (lisp::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'integer)) + #+ecl + (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout) + #+lispworks + (set-socket-receive-timeout socket timeout) + #+mcl + () ; TODO + #+sbcl + (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'single-float)) + #+scl + () + new-value)) Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Wed Mar 30 04:12:45 2011 @@ -29,6 +29,7 @@ #:socket-send ; udp function (send) #:socket-receive ; udp function (receive) #:socket-server ; udp server + #:socket-option ; 0.6.x #:wait-for-input ; waiting for input-ready state (select() like) #:make-wait-list Modified: usocket/trunk/usocket-test.asd ============================================================================== --- usocket/trunk/usocket-test.asd (original) +++ usocket/trunk/usocket-test.asd Wed Mar 30 04:12:45 2011 @@ -15,6 +15,7 @@ (defsystem usocket-test :name "usocket test" :author "Erik Enge" + :maintainer "Chun Tian (binghe)" :version "0.1.0" :licence "MIT" :description "Tests for usocket" Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Wed Mar 30 04:12:45 2011 @@ -14,6 +14,7 @@ (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" + :maintainer "Chun Tian (binghe)" :version "0.6.0" :licence "MIT" :description "Universal socket library for Common Lisp" @@ -36,7 +37,8 @@ #+mcl (:file "mcl") #+openmcl (:file "openmcl") #+allegro (:file "allegro"))) - (:file "server" :depends-on ("backend")))) + (:file "option" :depends-on ("backend")) + (:file "server" :depends-on ("backend" "option")))) (defmethod perform ((op test-op) (c (eql (find-system :usocket)))) (oos 'load-op :usocket-test) From ctian at common-lisp.net Wed Mar 30 08:16:11 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 04:16:11 -0400 Subject: [usocket-cvs] r614 - in usocket/trunk: . backend test vendor Message-ID: Author: ctian Date: Wed Mar 30 04:16:10 2011 New Revision: 614 Log: Merge all changes since 0.5.0 from branch 0.5.x (r583-r611) Added: usocket/trunk/test/test-datagram.lisp - copied unchanged from r613, /usocket/branches/0.5.x/test/test-datagram.lisp Removed: usocket/trunk/Makefile usocket/trunk/run-usocket-tests.sh usocket/trunk/test/abcl.conf.in usocket/trunk/test/allegro.conf.in usocket/trunk/test/clisp.conf.in usocket/trunk/test/cmucl.conf.in usocket/trunk/test/sbcl.conf.in usocket/trunk/test/your-lisp.conf.in Modified: usocket/trunk/CHANGES usocket/trunk/backend/allegro.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/server.lisp usocket/trunk/test/test-condition.lisp usocket/trunk/test/test-usocket.lisp usocket/trunk/usocket-test.asd usocket/trunk/usocket.lisp usocket/trunk/vendor/spawn-thread.lisp Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES (original) +++ usocket/trunk/CHANGES Wed Mar 30 04:16:10 2011 @@ -5,3 +5,22 @@ * Add WAIT-FOR-INPUT support for SBCL and ECL on win32. * Simple TCP and UDP server API: SOCKET-SERVER * Lots of bug fixed since 0.4.1 + +0.5.1: + +* Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions! +* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko +* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. +* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". +* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. +* Bugfix: [LispWorks] Better network error type detection on LispWorks. +* Bugfix: [CLISP] Fixed UDP (Datagram) support (RAWSOCK version), confirmed by CL-NET-SNMP. +* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode. +* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. + +[TODO] + +* New feature: CLISP support UDP without RAWSOCK (using FFI interface) +* 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) Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Wed Mar 30 04:16:10 2011 @@ -90,7 +90,7 @@ (:stream (make-stream-socket :socket socket :stream socket)) (:datagram - (make-datagram-socket socket))))) + (make-datagram-socket socket :connected-p (and host port t)))))) ;; One socket close method is sufficient, ;; because socket-streams are also sockets. Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Wed Mar 30 04:16:10 2011 @@ -5,9 +5,15 @@ (in-package :usocket) +(eval-when (:compile-toplevel :load-toplevel :execute) + #-ffi + (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.") + #-(or ffi rawsock) + (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support.")) + ;; utility routine for looking up the current host name #+ffi -(FFI:DEF-CALL-OUT get-host-name-internal +(ffi:def-call-out get-host-name-internal (:name "gethostname") (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) :OUT :ALLOCA) @@ -27,6 +33,17 @@ #-ffi "localhost") +(defun get-host-by-address (address) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) + (posix:hostent-name hostent)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (let ((hostent (posix:resolve-host-ipaddr name))) + (mapcar #'host-to-vector-quad + (posix:hostent-addr-list hostent))))) + #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) @@ -61,26 +78,34 @@ timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) - (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) - (when local-host (unsupported 'local-host 'socket-connect)) - (when local-port (unsupported 'local-port 'socket-connect)) - - (let ((socket) - (hostname (host-to-hostname host))) - (with-mapped-conditions (socket) - (setf socket - (if timeout - (socket:socket-connect port hostname - :element-type element-type - :buffered t - :timeout timeout) - (socket:socket-connect port hostname - :element-type element-type - :buffered t)))) - (make-stream-socket :socket socket - :stream socket))) ;; the socket is a stream too + (case protocol + (:stream + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (if timeout + (socket:socket-connect port hostname + :element-type element-type + :buffered t + :timeout timeout) + (socket:socket-connect port hostname + :element-type element-type + :buffered t)))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + (:datagram + #+rawsock + (socket-create-datagram (or local-port *auto-port*) + :local-host (or local-host *wildcard-host*) + :remote-host host + :remote-port port) + #+(and ffi (not rawsock)) + () + #-(or rawsock ffi) + (unsupported '(protocol :datagram) 'socket-connect)))) (defun socket-listen (host port &key reuseaddress @@ -146,7 +171,6 @@ (defmethod get-peer-port ((usocket stream-usocket)) (nth-value 1 (get-peer-name usocket))) - (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) @@ -176,21 +200,19 @@ (setf (state x) :READ))) wait-list)))) - -;; -;; UDP/Datagram sockets! -;; +;;; +;;; UDP/Datagram sockets (RAWSOCK version) +;;; #+rawsock (progn - (defun make-sockaddr_in () (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) (declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr_in ip port) - (port-to-octet-buffer sockaddr_in port) - (ip-to-octet-buffer sockaddr_in ip :start 2) + (port-to-octet-buffer port sockaddr_in) + (ip-to-octet-buffer ip sockaddr_in :start 2) sockaddr_in) (defun socket-create-datagram (local-port @@ -204,58 +226,158 @@ (fill-sockaddr_in (make-sockaddr_in) remote-host (or remote-port local-port))))) - (bind sock lsock_addr) + (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) (when rsock_addr - (connect sock rsock_addr)) + (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr))) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) - (defun socket-receive (socket buffer &key (size (length buffer))) + (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) - (sockaddr (when (not (connected-p socket)) - (rawsock:make-sockaddr))) + (sockaddr (unless (connected-p socket) + (rawsock:make-sockaddr :inet))) (rv (if sockaddr - (rawsock:recvfrom sock buffer sockaddr - :start 0 - :end size) - (rawsock:recv sock buffer - :start 0 - :end size)))) - (values buffer - rv - (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4) - (port-from-octet-buffer (sockaddr-data sockaddr) 2))))) + (rawsock:recvfrom sock buffer sockaddr :start 0 :end length) + (rawsock:recv sock buffer :start 0 :end length))) + (host 0) (port 0)) + (unless (connected-p socket) + (let ((data (rawsock:sockaddr-data sockaddr))) + (setq host (ip-from-octet-buffer data :start 4) + port (port-from-octet-buffer data :start 2)))) + (values buffer rv host port))) - (defun socket-send (socket buffer &key address (size (length buffer))) + (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) "Returns the number of octets sent." (let* ((sock (socket socket)) - (sockaddr (when address - (rawsock:make-sockaddr :INET + (sockaddr (when (and host port) + (rawsock:make-sockaddr :inet (fill-sockaddr_in (make-sockaddr_in) - (host-byte-order - (second address)) - (first address))))) - (rv (if address + (host-byte-order host) + port)))) + (rv (if (and host port) (rawsock:sendto sock buffer sockaddr :start 0 - :end size) + :end length) (rawsock:send sock buffer :start 0 - :end size)))) + :end length)))) rv)) (defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket))) - - ) +) ; progn + +;;; +;;; UDP/Datagram sockets (FFI version) +;;; -#-rawsock +#+(and ffi (not rawsock)) (progn - (warn "This image doesn't contain the RAWSOCK package. -To enable UDP socket support, please be sure to use the -Kfull parameter -at startup, or to enable RAWSOCK support during compilation.") - ) + ;; C primitive types + (ffi:def-c-type size_t) + (ffi:def-c-type in_addr_t ffi:uint32) + (ffi:def-c-type in_port_t ffi:uint16) + (ffi:def-c-type sa_family_t ffi:uint8) + (ffi:def-c-type socklen_t ffi:uint32) + + ;; C structures + (ffi:def-c-struct sockaddr + (sa_len ffi:uint8) + (sa_family sa_family_t) + (sa_data (ffi:c-array ffi:char 14))) + + #+ignore + (ffi:def-c-struct in_addr + (s_addr in_addr_t)) + + (ffi:def-c-struct sockaddr_in + (sin_len ffi:uint8) + (sin_family sa_family_t) + (sin_port in_port_t) + (sin_addr in_addr_t) ; should be struct in_addr + (sin_zero (ffi:c-array ffi:char 8))) + + (ffi:def-c-struct timeval + (tv_sec ffi:long) + (tv_usec ffi:long)) + + ;; foreign functions + (ffi:def-call-out %sendto (:name "sendto") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8)) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr)) + (address-len ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %recvfrom (:name "recvfrom") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr ffi:uint8) :out) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr) :out) + (address-len (ffi:c-ptr ffi:int) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %socket (:name "socket") + (:arguments (family ffi:int) + (type ffi:int) + (protocol ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getsockopt (:name "getsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen (ffi:c-ptr socklen_t) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %setsockopt (:name "setsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + ;; socket constants + (defconstant +socket-af-inet+ 2) + (defconstant +socket-pf-unspec+ 0) + (defconstant +socket-sock-dgram+ 2) + (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") + + (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 (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-pf-unspec+))) + (if socket-fd + (progn + ) + (error "cannot create socket")))) +) ; progn Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Wed Mar 30 04:16:10 2011 @@ -106,7 +106,7 @@ (with-mapped-conditions (socket) (ext:create-inet-socket protocol))))) (if socket - (let ((usocket (make-datagram-socket socket))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) usocket) @@ -159,9 +159,28 @@ (defmethod socket-close :after ((socket datagram-usocket)) (setf (%open-p socket) nil)) +#+unicode +(defun %unix-send (fd buffer length flags) + (alien:alien-funcall + (alien:extern-alien "send" + (function c-call:int + c-call:int + system:system-area-pointer + c-call:int + c-call:int)) + fd + (system:vector-sap buffer) + length + flags)) + (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))) + (if (and host port) + (ext:inet-sendto (socket usocket) buffer length (host-to-hbo host) port) + #-unicode + (unix:unix-send (socket usocket) buffer length 0) + #+unicode + (%unix-send (socket usocket) buffer length 0)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (let ((real-buffer (or buffer Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Wed Mar 30 04:16:10 2011 @@ -9,7 +9,7 @@ (require "comm") #+lispworks3 - (error "LispWorks 3 is not supported by USOCKET.")) + (error "LispWorks 3 is not supported by USOCKET any more.")) ;;; --------------------------------------------------------------------------- ;;; Warn if multiprocessing is not running on Lispworks @@ -40,17 +40,15 @@ #+win32 "ws2_32") (defun get-host-name () - (multiple-value-bind (retcode name) + (multiple-value-bind (return-code name) (get-host-name-internal) - (when (= 0 retcode) + (when (zerop return-code) name))) #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) - (cons (mapcar #'(lambda (y) - (+ 10000 y)) - (car x)) + (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) (cdr x))) z)) @@ -62,7 +60,7 @@ (append +unix-errno-condition-map+ +unix-errno-error-map+)) -(defun raise-or-signal-socket-error (errno socket) +(defun raise-usock-err (errno socket &optional condition) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) (if usock-err @@ -71,33 +69,20 @@ (signal usock-err :socket socket)) (error 'unknown-error :socket socket - :real-error nil)))) - -(defun raise-usock-err (errno socket &optional condition) - (let* ((usock-err - (cdr (assoc errno +lispworks-error-map+ - :test #'member)))) - (if usock-err - (if (subtypep usock-err 'error) - (error usock-err :socket socket) - (signal usock-err :socket)) - (error 'unknown-error - :socket socket :real-error condition)))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (typecase condition - (simple-error (destructuring-bind (&optional host port err-msg errno) - (simple-condition-format-arguments condition) - (declare (ignore host port err-msg)) - (raise-usock-err errno socket condition))))) + (condition (let ((errno #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) + (raise-usock-err errno socket condition))))) (defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.") (defconstant *sockopt_so_rcvtimeo* - #+(not linux) #x1006 + #-linux #x1006 #+linux 20 "Socket receive timeout") @@ -294,18 +279,21 @@ (if stream (make-stream-socket :socket (comm:socket-stream-socket stream) :stream stream) - (error 'unknown-error)))) + ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout + (error 'timeout-error)))) (:datagram (let ((usocket (make-datagram-socket (if (and host port) - (connect-to-udp-server (host-to-hostname host) port - :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout) - (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) - :local-port local-port - :read-timeout timeout)) - :connected-p t))) + (with-mapped-conditions () + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout)) + (with-mapped-conditions () + (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout))) + :connected-p (and host port t)))) (hcl:flag-special-free-action usocket) usocket)))) Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Wed Mar 30 04:16:10 2011 @@ -97,20 +97,22 @@ :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))) + (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 + :input-timeout timeout + :format :binary)) + (usocket (make-datagram-socket mcl-sock))) (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)))))) + (setf (connected-p usocket) t) + usocket))))) (defun socket-listen (host port &key reuseaddress Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Wed Mar 30 04:16:10 2011 @@ -173,6 +173,8 @@ (sb-bsd-sockets:operation-timeout-error . timeout-error) #-ecl (sb-sys:io-timeout . timeout-error) + #+sbcl + (sb-ext:timeout . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error @@ -199,11 +201,52 @@ (if usock-cond (signal usock-cond :socket socket)))))) +;;; "The socket stream ends up with a bogus name as it is created before +;;; the socket is connected, making things harder to debug than they need +;;; to be." -- Nikodemus Siivola + (defvar *dummy-stream* (let ((stream (make-broadcast-stream))) (close stream) stream)) +;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch +;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS +;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than +;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola + +#+sbcl +(defmacro %with-timeout ((seconds timeout-form) &body body) + "Runs BODY as an implicit PROGN with timeout of SECONDS. If +timeout occurs before BODY has finished, BODY is unwound and +TIMEOUT-FORM is executed with its values returned instead. + +Note that BODY is unwound asynchronously when a timeout occurs, +so unless all code executed during it -- including anything +down the call chain -- is asynch unwind safe, bad things will +happen. Use with care." + (let ((exec (gensym)) (unwind (gensym)) (timer (gensym)) + (timeout (gensym)) (block (gensym))) + `(block ,block + (tagbody + (flet ((,unwind () + (go ,timeout)) + (,exec () + , at body)) + (declare (dynamic-extent #',exec #',unwind)) + (let ((,timer (sb-ext:make-timer #',unwind))) + (declare (dynamic-extent ,timer)) + (sb-sys:without-interrupts + (unwind-protect + (progn + (sb-ext:schedule-timer ,timer ,seconds) + (return-from ,block + (sb-sys:with-local-interrupts + (,exec)))) + (sb-ext:unschedule-timer ,timer))))) + ,timeout + (return-from ,block ,timeout-form))))) + (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port @@ -226,7 +269,6 @@ :protocol (case protocol (:stream :tcp) (:datagram :udp)))) - (ip (host-to-vector-quad host)) (local-host (host-to-vector-quad (or local-host *wildcard-host*))) (local-port (or local-port *auto-port*)) usocket ok) @@ -245,15 +287,20 @@ (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket local-host local-port)) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port) + #+sbcl + (labels ((connect () + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) + (if timeout + (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) + (connect))) + #+ecl + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :full - #+sbcl #+sbcl - :timeout timeout :element-type element-type)))) (:datagram (when (or local-host local-port) @@ -264,7 +311,7 @@ (setf usocket (make-datagram-socket socket)) (when (and host port) (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port) + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) (setf (connected-p usocket) t))))) (setf ok t)) ;; Clean up in case of an error. @@ -292,16 +339,30 @@ (sb-bsd-sockets:socket-close sock) (error c))))) +;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR, +;;; instead of raising a condition. It's always possible for +;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket +;;; was detected to be ready: connection might be reset, for example. +;;; +;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to +;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko + (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (with-mapped-conditions (socket) - (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) - (make-stream-socket - :socket sock - :stream (sb-bsd-sockets:socket-make-stream - sock - :input t :output t :buffering :full - :element-type (or element-type - (element-type socket))))))) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (if sock + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket)))) + + ;; next time wait for event again if we had EAGAIN/EINTR + ;; or else we'd enter a tight loop of failed accepts + #+win32 + (setf (%ready-p socket) nil))))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which @@ -449,7 +510,15 @@ #+(and sbcl win32) (progn - (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int) + ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET + ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It + ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED, + ;; which is always machine word-sized (exactly as intptr_t; + ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not + ;; enough -- potentially)." + ;; -- Anton Kovalenko , Mar 22, 2011 + (sb-alien:define-alien-type ws-socket sb-alien:signed) + (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) (sb-alien:define-alien-type ws-event sb-alien::hinstance) @@ -557,13 +626,33 @@ (defun (setf os-wait-list-%wait) (value wait-list) (setf (sb-alien:deref (wait-list-%wait wait-list)) value)) + ;; "Event handles are leaking in current SBCL backend implementation, + ;; because of SBCL-unfriendly usage of finalizers. + ;; + ;; "SBCL never calls a finalizer that closes over a finalized object: a + ;; reference from that closure prevents its collection forever. That's + ;; the case with USOCKET in %SETUP-WAIT-LIST. + ;; + ;; "I use the following redefinition of %SETUP-WAIT-LIST: + ;; + ;; "Of course it may be rewritten with more clarity, but you can see the + ;; core idea: I'm closing over those components of WAIT-LIST that I need + ;; for finalization, not the wait-list itself. With the original + ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted + ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST." + ;; + ;; -- Anton Kovalenko , Mar 22, 2011 + (defun %setup-wait-list (wait-list) (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event)) (setf (os-wait-list-%wait wait-list) (wsa-event-create)) (sb-ext:finalize wait-list - #'(lambda () (unless (null (wait-list-%wait wait-list)) - (wsa-event-close (os-wait-list-%wait wait-list)) - (sb-alien:free-alien (wait-list-%wait wait-list)))))) + (let ((event-handle (os-wait-list-%wait wait-list)) + (alien (wait-list-%wait wait-list))) + #'(lambda () + (wsa-event-close event-handle) + (unless (null alien) + (sb-alien:free-alien alien)))))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Wed Mar 30 04:16:10 2011 @@ -82,7 +82,7 @@ (host-to-hbo local-host))))) (with-mapped-conditions () (ext:create-inet-socket protocol))))) - (let ((usocket (make-datagram-socket socket))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) Modified: usocket/trunk/server.lisp ============================================================================== --- usocket/trunk/server.lisp (original) +++ usocket/trunk/server.lisp Wed Mar 30 04:16:10 2011 @@ -31,8 +31,8 @@ :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread - (spawn-thread "USOCKET Server" #'real-call) - (real-call))))) + (values (spawn-thread "USOCKET Server" #'real-call) socket) + (real-call))))) (defvar *remote-host*) (defvar *remote-port*) Modified: usocket/trunk/test/test-condition.lisp ============================================================================== --- usocket/trunk/test/test-condition.lisp (original) +++ usocket/trunk/test/test-condition.lisp Wed Mar 30 04:16:10 2011 @@ -11,7 +11,7 @@ (deftest timeout-error.1 (with-caught-conditions (usocket:timeout-error nil) - (usocket:socket-connect "common-lisp.net" 81 :timeout 1) + (usocket:socket-connect "common-lisp.net" 81 :timeout 0) t) nil) Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Wed Mar 30 04:16:10 2011 @@ -74,27 +74,13 @@ nil) (deftest socket-failure.1 - (with-caught-conditions (#-(or cmu lispworks armedbear openmcl mcl) - usocket:network-unreachable-error - #+(or cmu lispworks armedbear) - usocket:unknown-error - #+(or openmcl mcl) - usocket:timeout-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) :unreach) nil) (deftest socket-failure.2 - (with-caught-conditions (#+(or lispworks armedbear) - usocket:unknown-error - #+cmu - usocket:network-unreachable-error - #+(or openmcl mcl) - usocket:timeout-error - #-(or lispworks armedbear cmu openmcl mcl) - usocket:host-unreachable-error - nil) + (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port :unreach) nil) Modified: usocket/trunk/usocket-test.asd ============================================================================== --- usocket/trunk/usocket-test.asd (original) +++ usocket/trunk/usocket-test.asd Wed Mar 30 04:16:10 2011 @@ -22,11 +22,11 @@ :depends-on (:usocket :rt) :components ((:module "test" + :serial t :components ((:file "package") - (:file "test-usocket" - :depends-on ("package")) - (:file "test-condition" - :depends-on ("test-usocket")))))) + (:file "test-usocket") + (:file "test-condition") + (:file "test-datagram"))))) (defmethod perform ((op test-op) (c (eql (find-system :usocket-test)))) (funcall (intern "DO-TESTS" "USOCKET-TEST"))) Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Mar 30 04:16:10 2011 @@ -367,16 +367,16 @@ (aref buffer b))))) (defmacro port-to-octet-buffer (port buffer &key (start 0)) - `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) (defmacro ip-to-octet-buffer (ip buffer &key (start 0)) - `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start)) (defmacro port-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 2 ,start)) + `(octet-buffer-to-integer ,buffer 2 :start ,start)) (defmacro ip-from-octet-buffer (buffer &key (start 0)) - `(octet-buffer-to-integer ,buffer 4 ,start)) + `(octet-buffer-to-integer ,buffer 4 :start ,start)) ;; ;; IP(v4) utility functions @@ -470,43 +470,41 @@ ;; DNS helper functions ;; -#-clisp -(progn - (defun get-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (car hosts))) - - (defun get-random-host-by-name (name) - (let ((hosts (get-hosts-by-name name))) - (when hosts - (elt hosts (random (length hosts)))))) +(defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + +(defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts)))))) - (defun host-to-vector-quad (host) - "Translate a host specification (vector quad, dotted quad or domain name) +(defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." - (etypecase host - (string (let* ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - ;; valid IP dotted quad? - ip - (get-random-host-by-name host)))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - host) - (integer (hbo-to-vector-quad host)))) - - (defun host-to-hbo (host) - (etypecase host - (string (let ((ip (when (ip-address-string-p host) - (dotted-quad-to-vector-quad host)))) - (if (and ip (= 4 (length ip))) - (host-byte-order ip) - (host-to-hbo (get-host-by-name host))))) - ((or (vector t 4) - (array (unsigned-byte 8) (4))) - (host-byte-order host)) - (integer host)))) + (etypecase host + (string (let* ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + host) + (integer (hbo-to-vector-quad host)))) + +(defun host-to-hbo (host) + (etypecase host + (string (let ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + (host-byte-order host)) + (integer host))) ;; ;; Other utility functions Modified: usocket/trunk/vendor/spawn-thread.lisp ============================================================================== --- usocket/trunk/vendor/spawn-thread.lisp (original) +++ usocket/trunk/vendor/spawn-thread.lisp Wed Mar 30 04:16:10 2011 @@ -43,6 +43,9 @@ (defun spawn-thread (name function &rest args) #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) (declare (dynamic-extent args)) + #+abcl + (threads:make-thread #'(lambda () (apply function args)) + :name name) #+allegro (apply #'mp:process-run-function name function args) #+(and clisp mt) From ctian at common-lisp.net Wed Mar 30 08:30:45 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 04:30:45 -0400 Subject: [usocket-cvs] r615 - usocket/trunk Message-ID: Author: ctian Date: Wed Mar 30 04:30:45 2011 New Revision: 615 Log: Update ChangeLog Modified: usocket/trunk/CHANGES Modified: usocket/trunk/CHANGES ============================================================================== --- usocket/trunk/CHANGES (original) +++ usocket/trunk/CHANGES Wed Mar 30 04:30:45 2011 @@ -24,3 +24,11 @@ * New feature: CLISP support UDP without RAWSOCK (using FFI interface) * 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 From ctian at common-lisp.net Wed Mar 30 15:13:37 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 11:13:37 -0400 Subject: [usocket-cvs] r616 - usocket/branches/0.5.x/test Message-ID: Author: ctian Date: Wed Mar 30 11:13:37 2011 New Revision: 616 Log: Fixed HTTP 1.0 test cases Modified: usocket/branches/0.5.x/test/test-usocket.lisp Modified: usocket/branches/0.5.x/test/test-usocket.lisp ============================================================================== --- usocket/branches/0.5.x/test/test-usocket.lisp (original) +++ usocket/branches/0.5.x/test/test-usocket.lisp Wed Mar 30 11:13:37 2011 @@ -118,13 +118,11 @@ (unwind-protect (progn (format (usocket:socket-stream sock) - "GET / HTTP/1.0~c~c~c~c" - #\Return #\linefeed #\Return #\linefeed) + "GET / HTTP/1.0~2%") (force-output (usocket:socket-stream sock)) - (read-line (usocket:socket-stream sock))) + (subseq (read-line (usocket:socket-stream sock)) 0 15)) (usocket:socket-close sock)))) - #+(or mcl clisp) "HTTP/1.1 200 OK" - #-(or mcl clisp) #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + "HTTP/1.1 200 OK") (deftest socket-name.1 (with-caught-conditions (nil nil) @@ -188,14 +186,12 @@ (unwind-protect (progn (format (usocket:socket-stream sock) - "GET / HTTP/1.0~c~c~c~c" - #\Return #\linefeed #\Return #\linefeed) + "GET / HTTP/1.0~2%") (force-output (usocket:socket-stream sock)) (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) - (read-line (usocket:socket-stream sock))) + (subseq (read-line (usocket:socket-stream sock)) 0 15)) (usocket:socket-close sock)))) - #+(or mcl clisp) "HTTP/1.1 200 OK" - #-(or mcl clisp) #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + "HTTP/1.1 200 OK") (defun run-usocket-tests () (do-tests)) From ctian at common-lisp.net Wed Mar 30 18:25:06 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 14:25:06 -0400 Subject: [usocket-cvs] r617 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Wed Mar 30 14:25:06 2011 New Revision: 617 Log: [CLISP] SOCKET-CONNECT / UDP now works on both RAWSOCK and FFI. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Wed Mar 30 14:25:06 2011 @@ -97,13 +97,11 @@ (make-stream-socket :socket socket :stream socket))) ;; the socket is a stream too (:datagram - #+rawsock + #+(or rawsock ffi) (socket-create-datagram (or local-port *auto-port*) :local-host (or local-host *wildcard-host*) :remote-host host :remote-port port) - #+(and ffi (not rawsock)) - () #-(or rawsock ffi) (unsupported '(protocol :datagram) 'socket-connect)))) @@ -342,6 +340,34 @@ #+win32 :stdc-stdcall) (:return-type ffi:int)) + (ffi:def-call-out %connect (:name "connect") + (:arguments (socket ffi:int) + (address (ffi:c-ptr sockaddr) :in) + (address_len socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %bind (:name "bind") + (:arguments (socket ffi:int) + (address (ffi:c-ptr sockaddr) :in) + (address_len socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket") + (:arguments (socket ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + (ffi:def-call-out %getsockopt (:name "getsockopt") (:arguments (sockfd ffi:int) (level ffi:int) @@ -366,18 +392,80 @@ #+win32 :stdc-stdcall) (:return-type ffi:int)) + (ffi:def-call-out %htonl (:name "htonl") + (:arguments (hostlong ffi:uint32)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint32)) + + (ffi:def-call-out %htons (:name "htons") + (:arguments (hostshort ffi:uint16)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint16)) + + (ffi:def-call-out %ntohl (:name "ntohl") + (:arguments (netlong ffi:uint32)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint32)) + + (ffi:def-call-out %ntohs (:name "ntohs") + (:arguments (netshort ffi:uint16)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint16)) + ;; socket constants (defconstant +socket-af-inet+ 2) - (defconstant +socket-pf-unspec+ 0) (defconstant +socket-sock-dgram+ 2) (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") - (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 (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-pf-unspec+))) - (if socket-fd - (progn - ) - (error "cannot create socket")))) + (defvar *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in)) + + (declaim (inline fill-sockaddr_in)) + (defun fill-sockaddr_in (sockaddr host port) + (let ((hbo (host-to-hbo #(127 0 0 1)))) + (setf (ffi:slot (ffi:foreign-value sockaddr) 'sin_len) *length-of-sockaddr_in* + (ffi:slot (ffi:foreign-value sockaddr) 'sin_family) +socket-af-inet+ + (ffi:slot (ffi:foreign-value sockaddr) 'sin_port) (%htons port) + (ffi:slot (ffi:foreign-value sockaddr) 'sin_addr) (%htonl hbo)) + sockaddr)) + + (defun socket-create-datagram (local-port + &key (local-host *wildcard-host*) + remote-host + remote-port) + (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ 0)) + (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) + local-host local-port)) + (rsock_addr (when remote-host + (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) + remote-host (or remote-port local-port))))) + (unwind-protect + (progn + (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr) + *length-of-sockaddr_in*) + (when rsock_addr + (%connect sock + (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr) + *length-of-sockaddr_in*))) + (ffi:foreign-free lsock_addr) + (when remote-host + (ffi:foreign-free rsock_addr))) + (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + + (defmethod socket-close ((usocket datagram-usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) + (zerop (%close (socket usocket)))) + ) ; progn From ctian at common-lisp.net Thu Mar 31 03:22:38 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Wed, 30 Mar 2011 23:22:38 -0400 Subject: [usocket-cvs] r618 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Wed Mar 30 23:22:37 2011 New Revision: 618 Log: Add VALUES declaration for SOCKET-RECEIVE, and I doubt not all backends currently return all four values correctly. Modified: usocket/branches/0.5.x/backend/abcl.lisp usocket/branches/0.5.x/backend/allegro.lisp usocket/branches/0.5.x/backend/clisp.lisp usocket/branches/0.5.x/backend/cmucl.lisp usocket/branches/0.5.x/backend/lispworks.lisp usocket/branches/0.5.x/backend/openmcl.lisp usocket/branches/0.5.x/backend/sbcl.lisp usocket/branches/0.5.x/backend/scl.lisp Modified: usocket/branches/0.5.x/backend/abcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/abcl.lisp (original) +++ usocket/branches/0.5.x/backend/abcl.lisp Wed Mar 30 23:22:37 2011 @@ -343,6 +343,10 @@ ;;; TODO: return-host and return-port cannot be get ... (defmethod socket-receive ((usocket datagram-usocket) buffer length &key (element-type '(unsigned-byte 8))) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (let* ((socket (socket usocket)) (real-length (or length +max-datagram-packet-size+)) (byte-array (jnew-array $*byte real-length)) Modified: usocket/branches/0.5.x/backend/allegro.lisp ============================================================================== --- usocket/branches/0.5.x/backend/allegro.lisp (original) +++ usocket/branches/0.5.x/backend/allegro.lisp Wed Mar 30 23:22:37 2011 @@ -155,6 +155,10 @@ (socket:send-to s buffer length :remote-host host :remote-port port)))) (defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (with-mapped-conditions (socket) (let ((s (socket socket))) (socket:receive-from s length :buffer buffer :extract t)))) Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Wed Mar 30 23:22:37 2011 @@ -232,6 +232,10 @@ (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (let* ((sock (socket socket)) (sockaddr (unless (connected-p socket) (rawsock:make-sockaddr :inet))) @@ -468,4 +472,13 @@ (remove-waiter (wait-list usocket) usocket)) (zerop (%close (socket usocket)))) + (defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port + ) + + (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + ) ) ; progn Modified: usocket/branches/0.5.x/backend/cmucl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/cmucl.lisp (original) +++ usocket/branches/0.5.x/backend/cmucl.lisp Wed Mar 30 23:22:37 2011 @@ -183,6 +183,10 @@ (%unix-send (socket usocket) buffer length 0)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (let ((real-buffer (or buffer (make-array length :element-type '(unsigned-byte 8)))) (real-length (or length Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Wed Mar 30 23:22:37 2011 @@ -433,6 +433,10 @@ (values nil n 0 0))))))) (defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (multiple-value-bind (buffer size host port) (receive-message (socket socket) (slot-value socket 'recv-buffer) Modified: usocket/branches/0.5.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/openmcl.lisp (original) +++ usocket/branches/0.5.x/backend/openmcl.lisp Wed Mar 30 23:22:37 2011 @@ -157,6 +157,10 @@ (ccl::send-for-usocket (socket usocket) buffer length)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (with-mapped-conditions (usocket) (openmcl-socket:receive-from (socket usocket) length :buffer buffer))) Modified: usocket/branches/0.5.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/sbcl.lisp (original) +++ usocket/branches/0.5.x/backend/sbcl.lisp Wed Mar 30 23:22:37 2011 @@ -387,6 +387,10 @@ (defmethod socket-receive ((socket datagram-usocket) buffer length &key (element-type '(unsigned-byte 8))) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (with-mapped-conditions (socket) (let ((s (socket socket))) (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) Modified: usocket/branches/0.5.x/backend/scl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/scl.lisp (original) +++ usocket/branches/0.5.x/backend/scl.lisp Wed Mar 30 23:22:37 2011 @@ -145,6 +145,10 @@ (scl-map-socket-error errno :socket socket))))) (defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port (let ((s (socket socket))) (let ((real-buffer (or buffer (make-array length :element-type '(unsigned-byte 8)))) From ctian at common-lisp.net Thu Mar 31 06:25:43 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 02:25:43 -0400 Subject: [usocket-cvs] r619 - in usocket/branches/0.5.x: . backend Message-ID: Author: ctian Date: Thu Mar 31 02:25:43 2011 New Revision: 619 Log: [CLISP] SOCKET-RECEIVE (FFI version), untested. Modified: usocket/branches/0.5.x/backend/clisp.lisp usocket/branches/0.5.x/usocket.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 02:25:43 2011 @@ -323,11 +323,11 @@ (ffi:def-call-out %recvfrom (:name "recvfrom") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr ffi:uint8) :out) + (buffer (ffi:c-ptr ffi:uint8) :in-out) (length ffi:int) (flags ffi:int) - (address (ffi:c-ptr sockaddr) :out) - (address-len (ffi:c-ptr ffi:int) :out)) + (address (ffi:c-ptr sockaddr) :in-out) + (address-len (ffi:c-ptr ffi:int) :in-out)) #+win32 (:library "WS2_32") #-win32 (:library :default) (:language #-win32 :stdc @@ -438,10 +438,16 @@ (declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr host port) (let ((hbo (host-to-hbo #(127 0 0 1)))) + #+ignore (setf (ffi:slot (ffi:foreign-value sockaddr) 'sin_len) *length-of-sockaddr_in* (ffi:slot (ffi:foreign-value sockaddr) 'sin_family) +socket-af-inet+ (ffi:slot (ffi:foreign-value sockaddr) 'sin_port) (%htons port) (ffi:slot (ffi:foreign-value sockaddr) 'sin_addr) (%htonl hbo)) + (ffi:with-c-place (place sockaddr) + (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in* + (ffi:slot place 'sin_family) +socket-af-inet+ + (ffi:slot place 'sin_port) (%htons port) + (ffi:slot place 'sin_addr) (%htonl hbo))) sockaddr)) (defun socket-create-datagram (local-port @@ -467,17 +473,49 @@ (ffi:foreign-free rsock_addr))) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + (defmethod initialize-instance :after ((usocket datagram-usocket) &key) + (with-slots (send-buffer recv-buffer) usocket + (setf send-buffer (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+) + recv-buffer (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+)))) + (defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) - (zerop (%close (socket usocket)))) + (with-slots (send-buffer recv-buffer socket) usocket + (ffi:foreign-free send-buffer) + (ffi:foreign-free recv-buffer) + (zerop (%close socket)))) - (defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (unsigned-byte 32) ; host (unsigned-byte 16))) ; port - ) + (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) + (remote-address-length (ffi:allocate-shallow 'ffi:int)) + nbytes) + (unwind-protect + (with-slots (recv-buffer) usocket + (multiple-value-bind (n buffer address address-len) + (%recvfrom (socket usocket) + recv-buffer + +max-datagram-packet-size+ + 0 ; flags + remote-address + remote-address-length) + (setq nbytes n) + (cond ((plusp n) + (if buffer ; replace exist buffer of create new return buffer + (replace buffer (ffi:foreign-value recv-buffer) + :end1 (min length +max-datagram-packet-size+) + :end2 (min n +max-datagram-packet-size+)) + (setq buffer (subseq (ffi:foreign-value recv-buffer) + 0 (min n +max-datagram-packet-size+))))) + ((zerop n)) ; do nothing + (t)))) ; TODO: handle error here. + (ffi:foreign-free remote-address) + (ffi:foreign-free remote-address-length)) + (values buffer nbytes 0 0))) ; TODO: remote-host and remote-port needed (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) ) Modified: usocket/branches/0.5.x/usocket.lisp ============================================================================== --- usocket/branches/0.5.x/usocket.lisp (original) +++ usocket/branches/0.5.x/usocket.lisp Thu Mar 31 02:25:43 2011 @@ -99,18 +99,21 @@ ((connected-p :type boolean :accessor connected-p :initarg :connected-p) - #+(or cmu scl lispworks) + #+(or cmu + scl + lispworks + (and clisp ffi (not rawsock))) (%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.") - #+lispworks - (recv-buffer - :documentation "Private RECV buffer.") - #+lispworks - (send-buffer - :documentation "Private SEND buffer.")) + #+(or lispworks + (and clisp ffi (not rawsock))) + (recv-buffer :documentation "Private RECV buffer.") + #+(or lispworks + (and clisp ffi (not rawsock))) + (send-buffer :documentation "Private SEND buffer.")) (:documentation "UDP (inet-datagram) socket")) (defun usocket-p (socket) From ctian at common-lisp.net Thu Mar 31 11:05:05 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 07:05:05 -0400 Subject: [usocket-cvs] r620 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 07:05:05 2011 New Revision: 620 Log: [CLISP] SOCKET-SEND & SOCKET-RECEIVE (FFI version), partly tested. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 07:05:05 2011 @@ -77,7 +77,8 @@ (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) - (declare (ignore nodelay)) + (declare (ignore nodelay) + (ignorable timeout local-host local-port)) (when deadline (unsupported 'deadline 'socket-connect)) (when nodelay-specified (unsupported 'nodelay 'socket-connect)) (case protocol @@ -310,7 +311,9 @@ ;; foreign functions (ffi:def-call-out %sendto (:name "sendto") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr ffi:uint8)) + (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 + #.+max-datagram-packet-size+)) + :in) (length ffi:int) (flags ffi:int) (address (ffi:c-ptr sockaddr)) @@ -321,9 +324,24 @@ #+win32 :stdc-stdcall) (:return-type ffi:int)) + (ffi:def-call-out %send (:name "send") + (:arguments (socket ffi:int) + (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 + #.+max-datagram-packet-size+)) + :in) + (length ffi:int) + (flags ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + (ffi:def-call-out %recvfrom (:name "recvfrom") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr ffi:uint8) :in-out) + (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 + #.+max-datagram-packet-size+)) + :in-out) (length ffi:int) (flags ffi:int) (address (ffi:c-ptr sockaddr) :in-out) @@ -437,7 +455,7 @@ (declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr host port) - (let ((hbo (host-to-hbo #(127 0 0 1)))) + (let ((hbo (host-to-hbo host))) #+ignore (setf (ffi:slot (ffi:foreign-value sockaddr) 'sin_len) *length-of-sockaddr_in* (ffi:slot (ffi:foreign-value sockaddr) 'sin_family) +socket-af-inet+ @@ -473,16 +491,20 @@ (ffi:foreign-free rsock_addr))) (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + (defun finalize-datagram-usocket (object) + (when (datagram-usocket-p object) + (socket-close object))) + (defmethod initialize-instance :after ((usocket datagram-usocket) &key) - (with-slots (send-buffer recv-buffer) usocket - (setf send-buffer (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+) - recv-buffer (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+)))) + (setf (slot-value usocket 'recv-buffer) + (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+)) + ;; finalize the object + (ext:finalize usocket 'finalize-datagram-usocket)) (defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) - (with-slots (send-buffer recv-buffer socket) usocket - (ffi:foreign-free send-buffer) + (with-slots (recv-buffer socket) usocket (ffi:foreign-free recv-buffer) (zerop (%close socket)))) @@ -493,30 +515,67 @@ (unsigned-byte 16))) ; port (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) (remote-address-length (ffi:allocate-shallow 'ffi:int)) - nbytes) + nbytes (host 0) (port 0)) (unwind-protect - (with-slots (recv-buffer) usocket - (multiple-value-bind (n buffer address address-len) - (%recvfrom (socket usocket) - recv-buffer - +max-datagram-packet-size+ - 0 ; flags - remote-address - remote-address-length) - (setq nbytes n) - (cond ((plusp n) - (if buffer ; replace exist buffer of create new return buffer - (replace buffer (ffi:foreign-value recv-buffer) - :end1 (min length +max-datagram-packet-size+) - :end2 (min n +max-datagram-packet-size+)) - (setq buffer (subseq (ffi:foreign-value recv-buffer) - 0 (min n +max-datagram-packet-size+))))) - ((zerop n)) ; do nothing - (t)))) ; TODO: handle error here. + (multiple-value-bind (n return-buffer address address-length) + (%recvfrom (socket usocket) + (ffi:foreign-value (slot-value usocket 'recv-buffer)) + +max-datagram-packet-size+ + 0 ; flags + (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) + (ffi:foreign-value remote-address-length)) + (assert (= n (length return-buffer))) + (setq nbytes n) + (when (= address-length *length-of-sockaddr_in*) + (let ((in (ffi:cast (ffi:foreign-value address) 'sockaddr_in))) + (setq host (%ntohl (ffi:slot (ffi:foreign-value in) 'sin_addr)) + port (%ntohs (ffi:slot (ffi:foreign-value in) 'sin_port))))) + (cond ((plusp n) + (if buffer ; replace exist buffer of create new return buffer + (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+)) + (end-2 (min n +max-datagram-packet-size+))) + (replace buffer return-buffer :end1 end-1 :end2 end-2)) + (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))) + ((zerop n)) ; do nothing + (t))) ; TODO: handle error here. (ffi:foreign-free remote-address) (ffi:foreign-free remote-address-length)) - (values buffer nbytes 0 0))) ; TODO: remote-host and remote-port needed + (values buffer nbytes host port))) - (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) - ) + ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime, + ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those + ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time. + ;; + ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP. + (defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) + (declare (type sequence buffer) + (type integer length)) + (let ((remote-address (when (and host port) + (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port))) + (send-buffer (let ((buffer-length (length buffer))) + (if (> buffer-length (* length 2)) + ;; if buffer is too big, then we copy out a subseq and only allocate as need + (ffi:allocate-deep 'ffi:uint8 (subseq buffer 0 length) :count length :read-only t) + ;; then we allocate the whole buffer directly, that should be faster. + (ffi:allocate-deep 'ffi:uint8 buffer :count (length buffer) :read-only t)))) + nbytes) + (unwind-protect + (let ((n (if remote-address + (%sendto (socket usocket) + (ffi:foreign-value send-buffer) + (min length +max-datagram-packet-size+) 0 + (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) + *length-of-sockaddr_in*) + (%send (socket usocket) + (ffi:foreign-value send-buffer) + (min length +max-datagram-packet-size+) 0)))) + (cond ((plusp n) + (setq nbytes n)) + ((zerop n) + (setq nbytes n)) + (t))) ; TODO: error handling + (ffi:foreign-free send-buffer) + (when remote-address + (ffi:foreign-free remote-address)) + nbytes))) ) ; progn From ctian at common-lisp.net Thu Mar 31 11:06:20 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 07:06:20 -0400 Subject: [usocket-cvs] r621 - usocket/branches/0.5.x Message-ID: Author: ctian Date: Thu Mar 31 07:06:20 2011 New Revision: 621 Log: [CLISP] remove SEND-BUFFER slot from USOCKET class, no need Modified: usocket/branches/0.5.x/usocket.lisp Modified: usocket/branches/0.5.x/usocket.lisp ============================================================================== --- usocket/branches/0.5.x/usocket.lisp (original) +++ usocket/branches/0.5.x/usocket.lisp Thu Mar 31 07:06:20 2011 @@ -111,8 +111,7 @@ #+(or lispworks (and clisp ffi (not rawsock))) (recv-buffer :documentation "Private RECV buffer.") - #+(or lispworks - (and clisp ffi (not rawsock))) + #+lispworks (send-buffer :documentation "Private SEND buffer.")) (:documentation "UDP (inet-datagram) socket")) From ctian at common-lisp.net Thu Mar 31 11:56:14 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 07:56:14 -0400 Subject: [usocket-cvs] r622 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 07:56:14 2011 New Revision: 622 Log: [CLISP] fixed SOCKET-RECEIVE, now all four values correctly returned. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 07:56:14 2011 @@ -516,6 +516,8 @@ (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) (remote-address-length (ffi:allocate-shallow 'ffi:int)) nbytes (host 0) (port 0)) + (setf (ffi:foreign-value remote-address-length) + *length-of-sockaddr_in*) (unwind-protect (multiple-value-bind (n return-buffer address address-length) (%recvfrom (socket usocket) @@ -527,9 +529,9 @@ (assert (= n (length return-buffer))) (setq nbytes n) (when (= address-length *length-of-sockaddr_in*) - (let ((in (ffi:cast (ffi:foreign-value address) 'sockaddr_in))) - (setq host (%ntohl (ffi:slot (ffi:foreign-value in) 'sin_addr)) - port (%ntohs (ffi:slot (ffi:foreign-value in) 'sin_port))))) + (let ((data (sockaddr-sa_data address))) + (setq host (ip-from-octet-buffer data :start 2) + port (port-from-octet-buffer data)))) (cond ((plusp n) (if buffer ; replace exist buffer of create new return buffer (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+)) @@ -579,3 +581,11 @@ (ffi:foreign-free remote-address)) nbytes))) ) ; progn + +;;; TODO: get-local-name & get-peer-name + +(defmethod get-local-name ((usocket datagram-usocket)) + ) + +(defmethod get-peer-name ((usocket datagram-usocket)) + ) From ctian at common-lisp.net Thu Mar 31 12:32:56 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 08:32:56 -0400 Subject: [usocket-cvs] r623 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 08:32:56 2011 New Revision: 623 Log: [CLISP] fixed SOCKET-SEND & SOCKET-RECEIVE for handling any data, confirmed by CL-NET-SNMP Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 08:32:56 2011 @@ -233,10 +233,6 @@ (defmethod socket-receive ((socket datagram-usocket) buffer length &key) "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." - (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer - (integer 0) ; size - (unsigned-byte 32) ; host - (unsigned-byte 16))) ; port (let* ((sock (socket socket)) (sockaddr (unless (connected-p socket) (rawsock:make-sockaddr :inet))) @@ -311,9 +307,7 @@ ;; foreign functions (ffi:def-call-out %sendto (:name "sendto") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 - #.+max-datagram-packet-size+)) - :in) + (buffer ffi:c-pointer) (length ffi:int) (flags ffi:int) (address (ffi:c-ptr sockaddr)) @@ -326,9 +320,7 @@ (ffi:def-call-out %send (:name "send") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 - #.+max-datagram-packet-size+)) - :in) + (buffer ffi:c-pointer) (length ffi:int) (flags ffi:int)) #+win32 (:library "WS2_32") @@ -339,9 +331,7 @@ (ffi:def-call-out %recvfrom (:name "recvfrom") (:arguments (socket ffi:int) - (buffer (ffi:c-ptr (ffi:c-array-max ffi:uint8 - #.+max-datagram-packet-size+)) - :in-out) + (buffer ffi:c-pointer) (length ffi:int) (flags ffi:int) (address (ffi:c-ptr sockaddr) :in-out) @@ -509,35 +499,31 @@ (zerop (%close socket)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) - (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer - (integer 0) ; size - (unsigned-byte 32) ; host - (unsigned-byte 16))) ; port (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) (remote-address-length (ffi:allocate-shallow 'ffi:int)) nbytes (host 0) (port 0)) (setf (ffi:foreign-value remote-address-length) *length-of-sockaddr_in*) (unwind-protect - (multiple-value-bind (n return-buffer address address-length) + (multiple-value-bind (n address address-length) (%recvfrom (socket usocket) - (ffi:foreign-value (slot-value usocket 'recv-buffer)) + (ffi:foreign-address (slot-value usocket 'recv-buffer)) +max-datagram-packet-size+ 0 ; flags (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) (ffi:foreign-value remote-address-length)) - (assert (= n (length return-buffer))) (setq nbytes n) (when (= address-length *length-of-sockaddr_in*) (let ((data (sockaddr-sa_data address))) (setq host (ip-from-octet-buffer data :start 2) port (port-from-octet-buffer data)))) (cond ((plusp n) - (if buffer ; replace exist buffer of create new return buffer - (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+)) - (end-2 (min n +max-datagram-packet-size+))) - (replace buffer return-buffer :end1 end-1 :end2 end-2)) - (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))) + (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer)))) + (if buffer ; replace exist buffer of create new return buffer + (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+)) + (end-2 (min n +max-datagram-packet-size+))) + (replace buffer return-buffer :end1 end-1 :end2 end-2)) + (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+)))))) ((zerop n)) ; do nothing (t))) ; TODO: handle error here. (ffi:foreign-free remote-address) @@ -564,12 +550,13 @@ (unwind-protect (let ((n (if remote-address (%sendto (socket usocket) - (ffi:foreign-value send-buffer) + (ffi:foreign-address send-buffer) (min length +max-datagram-packet-size+) 0 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) *length-of-sockaddr_in*) (%send (socket usocket) - (ffi:foreign-value send-buffer) + ;; (ffi:cast (ffi:foreign-value send-buffer) 'ffi:c-pointer) + (ffi:foreign-address send-buffer) (min length +max-datagram-packet-size+) 0)))) (cond ((plusp n) (setq nbytes n)) From ctian at common-lisp.net Thu Mar 31 12:55:20 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 08:55:20 -0400 Subject: [usocket-cvs] r624 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 08:55:20 2011 New Revision: 624 Log: [LispWorks] minor fixes for version <= 5.0; use predefined *length-of-sockaddr_in*. Modified: usocket/branches/0.5.x/backend/lispworks.lisp Modified: usocket/branches/0.5.x/backend/lispworks.lisp ============================================================================== --- usocket/branches/0.5.x/backend/lispworks.lisp (original) +++ usocket/branches/0.5.x/backend/lispworks.lisp Thu Mar 31 08:55:20 2011 @@ -358,15 +358,14 @@ :element-type '(unsigned-byte 8) :allocation :static))) +(defvar *length-of-sockaddr_in* + (fli:size-of '(:struct comm::sockaddr_in))) + (defun send-message (socket-fd message buffer &optional (length (length buffer)) host service) "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)) - (len :int - #-(or lispworks4 lispworks5.0) ; <= 5.0 - :initial-element - (fli:size-of '(:struct comm::sockaddr_in)))) + (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) @@ -374,7 +373,7 @@ (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))) + *length-of-sockaddr_in*)) (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0))))) (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) @@ -397,8 +396,9 @@ (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)) (len :int #-(or lispworks4 lispworks5.0) ; <= 5.0 - :initial-element - (fli:size-of '(:struct comm::sockaddr_in)))) + :initial-element *length-of-sockaddr_in*)) + #+(or lispworks4 lispworks5.0) ; <= 5.0 + (setf (fli:dereference len) *length-of-sockaddr_in*) (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) ;; setup new read timeout (when read-timeout From ctian at common-lisp.net Thu Mar 31 14:39:07 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 10:39:07 -0400 Subject: [usocket-cvs] r625 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 10:39:07 2011 New Revision: 625 Log: [CMUCL] clean compilation warnings (the VALUES declaration works) Modified: usocket/branches/0.5.x/backend/cmucl.lisp Modified: usocket/branches/0.5.x/backend/cmucl.lisp ============================================================================== --- usocket/branches/0.5.x/backend/cmucl.lisp (original) +++ usocket/branches/0.5.x/backend/cmucl.lisp Thu Mar 31 10:39:07 2011 @@ -194,8 +194,7 @@ (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))))) + (values real-buffer nbytes remote-host remote-port)))) (defmethod get-local-name ((usocket usocket)) (multiple-value-bind @@ -273,17 +272,17 @@ (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (multiple-value-bind - (count err) - (unix:unix-fast-select (1+ (reduce #'max - (wait-list-%wait wait-list))) - (alien:addr rfds) nil nil - (when timeout secs) musecs) + (multiple-value-bind (count err) + (unix:unix-fast-select (1+ (reduce #'max + (wait-list-%wait wait-list))) + (alien:addr rfds) nil nil + (when timeout secs) musecs) + (declare (ignore err)) (if (<= 0 count) ;; process the result... (dolist (x (wait-list-waiters wait-list)) (when (unix:fd-isset (socket x) rfds) (setf (state x) :READ))) - (progn - ;;###FIXME generate an error, except for EINTR - ))))))) + (progn + ;;###FIXME generate an error, except for EINTR + ))))))) From ctian at common-lisp.net Thu Mar 31 14:40:15 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 10:40:15 -0400 Subject: [usocket-cvs] r626 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 10:40:15 2011 New Revision: 626 Log: [CLISP] GET-SOCK-NAME / GET-PEER-NAME now works on Datagram usockets (FFI version) Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 10:40:15 2011 @@ -146,7 +146,7 @@ (remove-waiter (wait-list usocket) usocket)) (socket:socket-server-close (socket usocket))) -(defmethod get-local-name ((usocket usocket)) +(defmethod get-local-name ((usocket stream-usocket)) (multiple-value-bind (address port) (socket:socket-stream-local (socket usocket) t) @@ -161,13 +161,13 @@ (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) -(defmethod get-peer-address ((usocket stream-usocket)) +(defmethod get-peer-address ((usocket usocket)) (nth-value 0 (get-peer-name usocket))) (defmethod get-local-port ((usocket usocket)) (nth-value 1 (get-local-name usocket))) -(defmethod get-peer-port ((usocket stream-usocket)) +(defmethod get-peer-port ((usocket usocket)) (nth-value 1 (get-peer-name usocket))) (defun %setup-wait-list (wait-list) @@ -436,6 +436,26 @@ #+win32 :stdc-stdcall) (:return-type ffi:uint16)) + (ffi:def-call-out %getsockname (:name "getsockname") + (:arguments (sockfd ffi:int) + (localaddr (ffi:c-ptr sockaddr) :in-out) + (addrlen (ffi:c-ptr socklen_t) :in-out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getpeername (:name "getpeername") + (:arguments (sockfd ffi:int) + (peeraddr (ffi:c-ptr sockaddr) :in-out) + (addrlen (ffi:c-ptr socklen_t) :in-out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + ;; socket constants (defconstant +socket-af-inet+ 2) (defconstant +socket-sock-dgram+ 2) @@ -567,12 +587,35 @@ (when remote-address (ffi:foreign-free remote-address)) nbytes))) + + (declaim (inline get-socket-name)) + (defun get-socket-name (socket function) + (let ((address (ffi:allocate-shallow 'sockaddr_in)) + (address-length (ffi:allocate-shallow 'ffi:int)) + (host 0) (port 0)) + (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*) + (unwind-protect + (multiple-value-bind (rv return-address return-address-length) + (funcall function socket + (ffi:cast (ffi:foreign-value address) 'sockaddr) + (ffi:foreign-value address-length)) + (declare (ignore return-address-length)) + (if (zerop rv) + (let ((data (sockaddr-sa_data return-address))) + (setq host (ip-from-octet-buffer data :start 2) + port (port-from-octet-buffer data))) + (error "get-socket-name error"))) ; TODO: convert this + (ffi:foreign-free address) + (ffi:foreign-free address-length)) + (values (hbo-to-vector-quad host) port))) + + (defmethod get-local-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) '%getsockname)) + + (defmethod get-peer-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) '%getpeername)) + ) ; progn ;;; TODO: get-local-name & get-peer-name -(defmethod get-local-name ((usocket datagram-usocket)) - ) - -(defmethod get-peer-name ((usocket datagram-usocket)) - ) From ctian at common-lisp.net Thu Mar 31 16:05:17 2011 From: ctian at common-lisp.net (Chun Tian (binghe)) Date: Thu, 31 Mar 2011 12:05:17 -0400 Subject: [usocket-cvs] r627 - usocket/branches/0.5.x/backend Message-ID: Author: ctian Date: Thu Mar 31 12:05:17 2011 New Revision: 627 Log: [CLISP] GET-SOCK-NAME / GET-PEER-NAME now works on Datagram usockets (RAWSOCK version); various fixes for RAWSOCK. Modified: usocket/branches/0.5.x/backend/clisp.lisp Modified: usocket/branches/0.5.x/backend/clisp.lisp ============================================================================== --- usocket/branches/0.5.x/backend/clisp.lisp (original) +++ usocket/branches/0.5.x/backend/clisp.lisp Thu Mar 31 12:05:17 2011 @@ -101,7 +101,7 @@ #+(or rawsock ffi) (socket-create-datagram (or local-port *auto-port*) :local-host (or local-host *wildcard-host*) - :remote-host host + :remote-host (and host (host-to-vector-quad host)) :remote-port port) #-(or rawsock ffi) (unsupported '(protocol :datagram) 'socket-connect)))) @@ -234,17 +234,18 @@ "Returns the buffer, the number of octets copied into the buffer (received) and the address of the sender as values." (let* ((sock (socket socket)) - (sockaddr (unless (connected-p socket) - (rawsock:make-sockaddr :inet))) - (rv (if sockaddr - (rawsock:recvfrom sock buffer sockaddr :start 0 :end length) - (rawsock:recv sock buffer :start 0 :end length))) + (sockaddr (rawsock:make-sockaddr :inet)) + (real-length (or length +max-datagram-packet-size+)) + (real-buffer (or buffer + (make-array real-length :element-type '(unsigned-byte 8)))) + (rv (rawsock:recvfrom sock real-buffer sockaddr + :start 0 :end real-length)) (host 0) (port 0)) (unless (connected-p socket) (let ((data (rawsock:sockaddr-data sockaddr))) (setq host (ip-from-octet-buffer data :start 4) port (port-from-octet-buffer data :start 2)))) - (values buffer rv host port))) + (values real-buffer rv host port))) (defmethod socket-send ((socket datagram-usocket) buffer length &key host port) "Returns the number of octets sent." @@ -255,19 +256,40 @@ (make-sockaddr_in) (host-byte-order host) port)))) + (real-length (or length (length buffer))) + (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*))) + buffer + (make-array real-length + :element-type '(unsigned-byte 8) + :initial-contents (subseq buffer 0 real-length)))) (rv (if (and host port) - (rawsock:sendto sock buffer sockaddr + (rawsock:sendto sock real-buffer sockaddr :start 0 - :end length) - (rawsock:send sock buffer + :end real-length) + (rawsock:send sock real-buffer :start 0 - :end length)))) + :end real-length)))) rv)) (defmethod socket-close ((usocket datagram-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket))) + + (declaim (inline get-socket-name)) + (defun get-socket-name (socket function) + (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in)))) + (funcall function socket sockaddr) + (let ((data (rawsock:sockaddr-data sockaddr))) + (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2)) + (port-from-octet-buffer data :start 0))))) + + (defmethod get-local-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) 'rawsock:getsockname)) + + (defmethod get-peer-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) 'rawsock:getpeername)) + ) ; progn ;;; @@ -289,10 +311,6 @@ (sa_family sa_family_t) (sa_data (ffi:c-array ffi:char 14))) - #+ignore - (ffi:def-c-struct in_addr - (s_addr in_addr_t)) - (ffi:def-c-struct sockaddr_in (sin_len ffi:uint8) (sin_family sa_family_t) @@ -466,11 +484,6 @@ (declaim (inline fill-sockaddr_in)) (defun fill-sockaddr_in (sockaddr host port) (let ((hbo (host-to-hbo host))) - #+ignore - (setf (ffi:slot (ffi:foreign-value sockaddr) 'sin_len) *length-of-sockaddr_in* - (ffi:slot (ffi:foreign-value sockaddr) 'sin_family) +socket-af-inet+ - (ffi:slot (ffi:foreign-value sockaddr) 'sin_port) (%htons port) - (ffi:slot (ffi:foreign-value sockaddr) 'sin_addr) (%htonl hbo)) (ffi:with-c-place (place sockaddr) (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in* (ffi:slot place 'sin_family) +socket-af-inet+ @@ -616,6 +629,3 @@ (get-socket-name (socket usocket) '%getpeername)) ) ; progn - -;;; TODO: get-local-name & get-peer-name -