diff --git a/CHANGES b/CHANGES index 14ff091..47c6ce9 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,19 @@ -0.6.5: +0.8.0: + +* New feature: IOlib backend (all usocket features are supported when IOlib is available in your platform). + +0.7.0: (Oct 25, 2016) + +* General: Separated USOCKET and USOCKET-SERVER systems (only the server part depends on Portable-threads) +* General: USOCKET now depends on SPLIT-SEQUENCE (the exactly same vendor code is removed from usocket code base) +* New feature: [LW] (SOCKET-OPTION :TCP-NODELAY) and its SETF version now works on LispWorks 4/5/6/7. +* New feature: [LW] SOCKET-CONNECT now supports setting "tcp_nodelay" in version 4.x and 5.0. +* Bugfix: [CCL] fixed issues in SOCKET-SHUTDOWN +* Bugfix: [CLISP] fixed issues in WAIT-FOR-INPUT (Thanks to a patch by @vibs29, #27) +* Bugfix: [LW] fixed loading in version <= 6.0 (actually 0.6.5 only fixed loading in LW 6.1) +* Bugfix: [ECL] all compilation warnings were checked and fixed. + +0.6.5: (Oct 19, 2016) * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for :SEND-TIMEOUT (thanks to John Pallister) * Bugfix: Let (WAIT-FOR-INPUT NIL &TIMEOUT) return NIL with respect to TIMEOUT. @@ -6,7 +21,7 @@ * Bugfix: [LW] fixed SOCKET-SHUTDOWN in all versions. * Bugfix: [ABCL] Fixed incorrect IPv6 addresses (#26), patch from Elias Mårtenson (lokedhs) -0.6.4: +0.6.4: (Mar 17, 2016) * New feature: [SBCL] IPv6 support (patch from Guillaume LE VAILLANT, #15) * New feature: [API] SOCKET-SHUTDOWN added (patch from Thayne McCombs #9) @@ -15,19 +30,19 @@ * Bugfix: [ECL] included unistd.h for gethostname() (patch from Daniel Kochmanski, #7) * Bugfix: [LispWorks] SOCKET-RECEIVE now updates %READ-P (patch from Frank James) -0.6.3: +0.6.3: (May 23, 2015) * Bugfix: [CCL] Further fixed CCL-1.11 compatibility and a typo in SOCKET-CONNECT for CCL-1.10. * Bugfix: [ECL] Fixed build in some versions. * Bugfix: [LispWorks] SOCKET-SEND and SOCKET-RECEIVE now throw conditions if something goes wrong. -0.6.2: +0.6.2: (Apr 20, 2015) * Bugfix: [CCL] Fixed CCL-1.11 compatibility. * Bugfix: [ECL] Fixed compatibility on recent versions. * Bugfix: [LispWorks] Added support address-in-use-error condition on LW/Win32. (patch from Sergey Katrevich). -0.6.1: +0.6.1: (Jun 21, 2013) * New feature: [MOCL] Initial MOCL support (TCP only, no W-F-I, patch from github.com/Wukix/usocket). * New feature: [MCL] Initial UDP support for Macintosh Common Lisp (MCL/RMCL). @@ -35,7 +50,7 @@ * Bugfix: [CCL] Added (:external-format ccl:*default-external-format*) to SOCKET-CONNECT, to prevent it fallback to ISO-8859-1 on NIL. (Patch from Vsevolod Dyomkin) * Bugfix: [CCL] Performance improved WAIT-FOR-INPUT and other fixes. (patch from Faré ) -0.6.0: +0.6.0: (Dec 26, 2012) * New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. * New feature: SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. @@ -45,7 +60,7 @@ * Bugfix: [LispWorks] remove redundant call to hcl:flag-special-free-action. (reported by Kamil Shakirov) * Bugfix: [CLISP] improved HANDLE-CONDITION for more CLISP environments. -0.5.5: +0.5.5: (Feb 27, 2012) * Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov). * Enhancement: [Server] adding *remote-host* *remote-port* to socket-server stream handler functions (suggested by Matthew Curry) @@ -53,20 +68,20 @@ * Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard). * Bugfix: [LispWorks] Fixed SOCKET-CONNECT on Windows, now LOCAL-PORT never have *auto-port* (0) as default value. -0.5.4: +0.5.4: (Oct 1, 2011) * Bugfix: [ECL] Fixed for ECL's MAKE-BUILD by removing some unecessary code (reported by Juan Jose Garcia-Ripoll, the ECL maintainer) * Bugfix: [ACL] Fixed for Allegro CL modern mode. * Bugfix: [SBCL] SOCKET-CONNECT on TCP won't call bind() when keyword arguments LOCAL-HOST or LOCAL-PORT is not set. (reported by Robert Brown) -0.5.3: +0.5.3: (Aug 13, 2011) * Bugfix: [MCL] Fixed SOCKET-LISTEN on vector addresses like #(0 0 0 0) * Bugfix: [MCL] Fixed WAIT-FOR-INPUT on passive sockets (stream-server-usocket) * Bugfix: [LispWorks] Fixed using OPEN-UDP-SOCKET in delivered applications (thanks to Camille Troillard and Martin Simmons, this fix is from LispWorks-UDP project). * Bugfix: [SBCL] Fixed for "SBCL data flush problem", reported by Robert Brown and confirmed by Nikodemus Siivola. -0.5.2: +0.5.2: (May 11, 2011) * General: [SBCL] SOCKET-CONNECT's TIMEOUT argument was limited on non-Windows platforms. * Bugfix: [CLISP] WAIT-FOR-INPUT now functions right (with/without READY-ONLY), this made Hunchentoot working on CLISP. (Thanks to Anton Vodonosov ) @@ -77,7 +92,7 @@ * Enhancement: [ABCL] GET-ADDRESS now works with underlying IP6 addresses. * Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added. -0.5.1: +0.5.1: (Apr 2, 2011) * New feature: [CLISP] UDP (Datagram) support based on FFI (Win/Mac/Linux), no RAWSOCK needed. * Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode. @@ -92,7 +107,7 @@ * Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. * Bugfix: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version). -0.5.0: +0.5.0: (Mar 12, 2011) * New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL) * Support for UDP (datagram-usocket) was added (for all supported platform except MCL) @@ -101,7 +116,66 @@ * Completely rewritten full-feature ABCL backends using latest Java interfaces * Lots of bug fixed since 0.4.1 -[TODO] +0.4.1: (Dec 27, 2008) + +* fixes for ECL, LispWorks, SBCL, SCL + +0.4.0: (Oct 28, 2008) + +* select()-like api: make a single thread wait for multiple sockets. +* various socket options for socket-creation with SOCKET-CONNECT. + +0.3.6: (Jun 21, 2008) + +* Code fixups based on advice from the ECL and OpenMCL maintainers. +* New exported symbols: WITH-MAPPED-CONDITIONS, NS-CONDITION, NS-ERROR, NS-UNKNOWN-ERROR and NS-UNKNOWN-CONDITION. + +0.3.4: (Jul 25, 2007) + +* Fix clisp get-host-name, multiple ECL fixes. + +0.3.3: (Jun 05, 2007) + +* Fix where host resolution routine was unable to resolve would return NIL instead of erroring. + +0.3.2: (Mar 04, 2007) + +* Fixes for many backends related to closing sockets. +* LispWorks fix for broken server sockets. +* API guarantee adjustments in preparation of porting Drakma. + +0.3.1: (Feb 28, 2007) + +* fixed with-server-socket; prevent creation of invalid sockets; 2 more convenience macros. + +0.3.0: (Jan 21, 2007) + +* Server sockets + +0.2.5: (Jan 19, 2007) + +* Allegro compilation fix. + +0.2.4: (Jan 17, 2007) + +* Various fixes for CMUCL, OpenMCL, Allegro and LispWorks. + +0.2.3: (Jan 04, 2007) + +* Add :element-type support to support stacking flexi-streams on socket streams for portable :external-format support. + +0.2.2: (Jan 03, 2007) + +* Add ECL support and a small SBCL bugfix. + +0.2.1: (Dec 21, 2006) + +* Remove 'open-stream' interface which is supposed to be provided by the 'trivial-usocket' package. + +0.2.0: (Dec 18, 2006) + +* Add support for Scieneer Common Lisp, fix issue #6 and API preparation for server side sockets (not in this release) + +0.1.0: (Feb 13, 2006) -* New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide -* New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. +* Initial release diff --git a/backend/abcl.lisp b/backend/abcl.lisp index f4251e3..dc8ffd6 100644 --- a/backend/abcl.lisp +++ b/backend/abcl.lisp @@ -1,6 +1,3 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; New ABCL networking support (replacement to old armedbear.lisp) ;;;; Author: Chun Tian (binghe) @@ -8,6 +5,9 @@ (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + ;;; Java Classes ($*...) (defvar $*boolean (jclass "boolean")) (defvar $*byte (jclass "byte")) diff --git a/backend/allegro.lisp b/backend/allegro.lisp index 15aa446..90da04a 100644 --- a/backend/allegro.lisp +++ b/backend/allegro.lisp @@ -2,6 +2,9 @@ (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + #+cormanlisp (eval-when (:compile-toplevel :load-toplevel :execute) (require :acl-socket)) diff --git a/backend/clisp.lisp b/backend/clisp.lisp index 21ca3c5..63ea9d6 100644 --- a/backend/clisp.lisp +++ b/backend/clisp.lisp @@ -1,10 +1,10 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See LICENSE for licensing information. (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (eval-when (:compile-toplevel :load-toplevel :execute) #-ffi (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.") diff --git a/backend/ecl.lisp b/backend/ecl.lisp index a4c80b1..28ddd5a 100644 --- a/backend/ecl.lisp +++ b/backend/ecl.lisp @@ -1,6 +1,4 @@ ;;;; -*- Mode: Lisp -*- -;;;; $Id$ -;;;; $URL$ ;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only. ;;;; See LICENSE for licensing information. diff --git a/backend/iolib-sockopt.lisp b/backend/iolib-sockopt.lisp new file mode 100644 index 0000000..801a0d6 --- /dev/null +++ b/backend/iolib-sockopt.lisp @@ -0,0 +1,115 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; all SOCKET-OPTIONs shuold be implemented here + +(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)) + (if (keywordp option) + (error 'unimplemented :feature option :context 'socket-option) + (error 'type-error :datum option :expected-type 'keyword))) + +;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + )) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (declare (type number new-value) (ignorable new-value option)) + (let ((socket (socket usocket)) + (timeout new-value)) + timeout)) + +;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :send-timeout)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + )) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :send-timeout)) &key) + (declare (type number new-value) (ignorable new-value option)) + (let ((socket (socket usocket)) + (timeout new-value)) + timeout)) + +;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server + +(defmethod socket-option ((usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + )) + +(defmethod (setf socket-option) (new-value (usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + new-value)) + +;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client + +(defmethod socket-option ((usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + )) + +(defmethod (setf socket-option) (new-value (usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + new-value)) + +;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :tcp-no-delay)) &key) + (declare (ignore option)) + (socket-option usocket :tcp-nodelay)) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + )) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :tcp-no-delay)) &key) + (declare (ignore option)) + (setf (socket-option usocket :tcp-nodelay) new-value)) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + new-value)) diff --git a/backend/iolib.lisp b/backend/iolib.lisp new file mode 100644 index 0000000..3d7ac34 --- /dev/null +++ b/backend/iolib.lisp @@ -0,0 +1,93 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:load-toplevel :execute) + (setq *backend* :iolib)) + +(defun get-host-name () + ) + +(defparameter +iolib-error-map+ + '((:address-in-use . address-in-use-error) + (:address-not-available . address-not-available-error) + (:network-down . network-down-error) + (:network-reset . network-reset-error) + (:network-unreachable . network-unreachable-error) + (:connection-aborted . connection-aborted-error) + (:connection-reset . connection-reset-error) + (:no-buffer-space . no-buffers-error) + (:shutdown . shutdown-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-down . host-down-error) + (:host-unreachable . host-unreachable-error))) + +(defun handle-condition (condition &optional (socket nil)) + ) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline + (nodelay t) ;; nodelay == t is the ACL default + local-host local-port) + ) + +(defmethod socket-close ((usocket usocket)) + ) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + ) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + ) + +(defmethod get-local-address ((usocket usocket)) + ) + +(defmethod get-peer-address ((usocket stream-usocket)) + ) + +(defmethod get-local-port ((usocket usocket)) + ) + +(defmethod get-peer-port ((usocket stream-usocket)) + ) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + ) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + ) + +(defun get-host-by-address (address) + ) + +(defun get-hosts-by-name (name) + ) + +(defun %setup-wait-list (wait-list) + ) + +(defun %add-waiter (wait-list waiter) + ) + +(defun %remove-waiter (wait-list waiter) + ) + +(defun wait-for-input-internal (wait-list &key timeout) + ) diff --git a/backend/lispworks.lisp b/backend/lispworks.lisp index b6c1ea2..67d02a1 100644 --- a/backend/lispworks.lisp +++ b/backend/lispworks.lisp @@ -2,6 +2,9 @@ (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (eval-when (:compile-toplevel :load-toplevel :execute) (require "comm") @@ -251,6 +254,34 @@ len) (float (/ (fli:dereference timeout) 1000)))) +#+lispworks4 +(defun set-socket-tcp-nodelay (socket-fd new-value) + "Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)" + (declare (type integer socket-fd) + (type (integer 0 1) new-value)) + (fli:with-dynamic-foreign-objects ((zero-or-one :int)) + (setf (fli:dereference zero-or-one) new-value) + (when (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_tcp_nodelay* + (fli:copy-pointer zero-or-one + :type '(:pointer #+win32 :char #-win32 :void)) + (fli:size-of :int))) + new-value))) + +(defun get-socket-tcp-nodelay (socket-fd) + "Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((zero-or-one :int) + (len :int)) + (if (zerop (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_tcp_nodelay* + (fli:copy-pointer zero-or-one + :type '(:pointer #+win32 :char #-win32 :void)) + len)) + zero-or-one 0))) ; on error, return 0 + (defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname)) (declare (ignorable original-hostname)) #+(or lispworks4 lispworks5 lispworks6.0) @@ -264,7 +295,7 @@ comm::*socket_af_inet* server-addr (fli:pointer-element-size server-addr))) - #-(or lispworks4 lispworks5 lispworks6.0) + #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1 (progn (when (stringp hostname) (setq hostname (comm:string-ip-address hostname)) @@ -356,9 +387,8 @@ (error "cannot create socket")))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'base-char) - timeout deadline (nodelay t nodelay-specified) + timeout deadline (nodelay t) local-host local-port) - ;; What's the meaning of this keyword? (when deadline (unimplemented 'deadline 'socket-connect)) @@ -367,11 +397,6 @@ (when timeout (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5")) - #+(or lispworks4 lispworks5.0) ; < 5.1 - (when (and nodelay-specified - (not (eq nodelay :if-supported))) - (unsupported 'nodelay 'socket-connect :minimum "LispWorks 5.1")) - #+lispworks4 (when local-host (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) @@ -383,7 +408,7 @@ (:stream (let ((hostname (host-to-hostname host)) (stream)) - (setf stream + (setq stream (with-mapped-conditions () (comm:open-tcp-stream hostname port :element-type element-type @@ -397,6 +422,15 @@ #-(or lispworks4 lispworks5.0) ; >= 5.1 #-(or lispworks4 lispworks5.0) :nodelay nodelay))) + + ;; Then handle `nodelay' separately for older versions <= 5.0 + #+(or lispworks4 lispworks5.0) + (when (and stream nodelay) + (#+lispworks4 set-socket-tcp-nodelay + #+lispworks5.0 comm::set-socket-tcp-nodelay + (comm:socket-stream-socket stream) + (bool->int nodelay))) ; ":if-supported" maps to 1 too. + (if stream (make-stream-socket :socket (comm:socket-stream-socket stream) :stream stream) @@ -654,6 +688,9 @@ (nth-value 1 (get-peer-name usocket))) (defun lw-hbo-to-vector-quad (hbo) + #+(or lispworks4 lispworks5 lispworks6.0) + (hbo-to-vector-quad hbo) + #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 (if (comm:ipv6-address-p hbo) (ipv6-host-to-vector (comm:ipv6-address-string hbo)) (hbo-to-vector-quad hbo))) diff --git a/backend/mcl.lisp b/backend/mcl.lisp index 5ef29c8..10f64e1 100644 --- a/backend/mcl.lisp +++ b/backend/mcl.lisp @@ -1,11 +1,11 @@ -;;;; $Id$ -;;;; $URL$ - ;; MCL backend for USOCKET 0.4.1 ;; Terje Norderhaug , January 1, 2009 (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (defun handle-condition (condition &optional socket) ; incomplete, needs to handle additional conditions (flet ((raise-error (&optional socket-condition) diff --git a/backend/mocl.lisp b/backend/mocl.lisp index 58bdf17..82b926f 100644 --- a/backend/mocl.lisp +++ b/backend/mocl.lisp @@ -1,10 +1,10 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See LICENSE for licensing information. (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (declare (ignore socket)) diff --git a/backend/openmcl.lisp b/backend/openmcl.lisp index 2fab670..172dca9 100644 --- a/backend/openmcl.lisp +++ b/backend/openmcl.lisp @@ -2,6 +2,9 @@ (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (defun get-host-name () (ccl::%stack-block ((resultbuf 256)) (when (zerop (#_gethostname resultbuf 256)) @@ -157,9 +160,9 @@ (with-mapped-conditions (usocket) (close (socket usocket)))) -(defmethod socket-shutdown ((usocket stream-usocket) direction) +(defmethod socket-shutdown ((usocket usocket) direction) (with-mapped-conditions (usocket) - (openmcl-socket:shutdown sock :direction direction))) + (openmcl-socket:shutdown (socket usocket) :direction direction))) #-ipv6 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) diff --git a/backend/sbcl.lisp b/backend/sbcl.lisp index 865ae29..bdcacd2 100644 --- a/backend/sbcl.lisp +++ b/backend/sbcl.lisp @@ -4,6 +4,9 @@ (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + #+sbcl (progn #-win32 @@ -366,8 +369,10 @@ happen. Use with care." (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) - (let* ((local (when host + (let* (#+sbcl + (local (when host (car (get-hosts-by-name (host-to-hostname host))))) + #+sbcl (ipv6 (and local (= 16 (length local)))) (reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (ip #+sbcl (if (and local (not (eq host *wildcard-host*))) @@ -460,6 +465,7 @@ happen. Use with care." (defmethod socket-receive ((socket datagram-usocket) buffer length &key (element-type '(unsigned-byte 8))) + #+sbcl (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (simple-array (unsigned-byte 8) (*)) ; host @@ -747,12 +753,11 @@ happen. Use with care." (progn (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () - (multiple-value-bind - (secs usecs) + (multiple-value-bind (secs usecs) (split-timeout (or timeout 1)) - (multiple-value-bind - (result-fds err) + (multiple-value-bind (result-fds err) (read-select wl (when timeout secs) usecs) + (declare (ignore result-fds)) (unless (null err) (error (map-errno-error err))))))) diff --git a/backend/scl.lisp b/backend/scl.lisp index 2689cda..3f210e5 100644 --- a/backend/scl.lisp +++ b/backend/scl.lisp @@ -1,10 +1,10 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See LICENSE for licensing information. (in-package :usocket) +(eval-when (:load-toplevel :execute) + (setq *backend* :native)) + (defparameter +scl-error-map+ (append +unix-errno-condition-map+ +unix-errno-error-map+)) diff --git a/condition.lisp b/condition.lisp index 3657312..b68d77c 100644 --- a/condition.lisp +++ b/condition.lisp @@ -1,6 +1,3 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See LICENSE for licensing information. (in-package :usocket) diff --git a/option.lisp b/option.lisp index 011fc92..b775e29 100644 --- a/option.lisp +++ b/option.lisp @@ -4,11 +4,6 @@ (in-package :usocket) -;;; Small utility functions -(declaim (inline bool->int) (inline int->bool)) -(defun bool->int (bool) (if bool 1 0)) -(defun int->bool (int) (= 1 int)) - ;;; Interface definition (defgeneric socket-option (socket option &key) @@ -275,10 +270,15 @@ () ; TODO new-value)) -;;; Socket option: TCP-NO-DELAY (TCP_NODELAY), for TCP client +;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client (defmethod socket-option ((usocket stream-usocket) (option (eql :tcp-no-delay)) &key) + (declare (ignore option)) + (socket-option usocket :tcp-nodelay)) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) (declare (ignorable option)) (let ((socket (socket usocket))) (declare (ignorable socket)) @@ -295,7 +295,7 @@ #+ecl (sb-bsd-sockets::sockopt-tcp-nodelay socket) #+lispworks - () ; TODO + (int->bool (get-socket-tcp-nodelay socket)) #+mcl () ; TODO #+mocl @@ -307,6 +307,11 @@ (defmethod (setf socket-option) (new-value (usocket stream-usocket) (option (eql :tcp-no-delay)) &key) + (declare (ignore option)) + (setf (socket-option usocket :tcp-nodelay) new-value)) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) (declare (type boolean new-value) (ignorable new-value option)) (let ((socket (socket usocket))) (declare (ignorable socket)) @@ -323,7 +328,11 @@ #+ecl (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) #+lispworks - (comm::set-socket-tcp-nodelay socket new-value) + (progn + #-lispworks4 + (comm::set-socket-tcp-nodelay socket new-value) + #+lispworks4 + (set-socket-tcp-nodelay socket (bool->int new-value))) #+mcl () ; TODO #+mocl diff --git a/package.lisp b/package.lisp index d2f1d23..f33b48a 100644 --- a/package.lisp +++ b/package.lisp @@ -1,14 +1,13 @@ ;;;; See the LICENSE file for licensing information. +(unless (find-package :usocket) ; do not redefine packages (defpackage :usocket - (:use :common-lisp #+abcl :java) + (:use :common-lisp :split-sequence #+abcl :java) (:export #:*version* + #:*backend* #:*wildcard-host* #:*auto-port* - #:*remote-host* ; special variables (udp) - #:*remote-port* - #:+max-datagram-packet-size+ #:socket-connect ; socket constructors and methods @@ -25,7 +24,6 @@ #: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) @@ -86,4 +84,9 @@ #:insufficient-implementation ; conditions regarding usocket support level #:unsupported - #:unimplemented)) + #:unimplemented + + #:socket-server + #:*remote-host* + #:*remote-port*)) +) ; unless diff --git a/server.lisp b/server.lisp index e050d13..93b1bf4 100644 --- a/server.lisp +++ b/server.lisp @@ -1,6 +1,3 @@ -;;;; $Id$ -;;;; $URL$ - (in-package :usocket) (defun socket-server (host port function &optional arguments @@ -32,7 +29,7 @@ :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread - (values (spawn-thread (or name "USOCKET Server") #'real-call) socket) + (values (portable-threads:spawn-thread (or name "USOCKET Server") #'real-call) socket) (real-call))))) (defvar *remote-host*) @@ -98,7 +95,7 @@ `(,socket ,@(when element-type `(:element-type ,element-type))))) (client-stream (socket-stream client-socket))) (if multi-threading - (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments) + (apply #'portable-threads:spawn-thread "USOCKET Client" real-function client-socket arguments) (prog1 (apply real-function client-socket arguments) (close client-stream) (socket-close client-socket))) diff --git a/test/package.lisp b/test/package.lisp index 15935dc..16ad1ab 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -1,6 +1,3 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See the LICENSE file for licensing information. (in-package :cl-user) diff --git a/usocket-server.asd b/usocket-server.asd new file mode 100644 index 0000000..6e60677 --- /dev/null +++ b/usocket-server.asd @@ -0,0 +1,14 @@ +;;;; -*- Mode: Lisp -*- +;;;; +;;;; See the LICENSE file for licensing information. + +(in-package :asdf) + +(defsystem #:usocket-server + :name "usocket (server)" + :author "Chun Tian (binghe)" + :version "0.8.0" + :licence "MIT" + :description "Universal socket library for Common Lisp (server side)" + :depends-on (:usocket :portable-threads) + :components ((:file "server"))) diff --git a/usocket-test.asd b/usocket-test.asd index 4c2edac..ddb989c 100644 --- a/usocket-test.asd +++ b/usocket-test.asd @@ -11,7 +11,7 @@ :version "0.2.0" :licence "MIT" :description "Tests for usocket" - :depends-on (:usocket + :depends-on (:usocket-server :rt) :components ((:module "test" :serial t diff --git a/usocket.asd b/usocket.asd index 537dbae..80bbb53 100644 --- a/usocket.asd +++ b/usocket.asd @@ -2,39 +2,56 @@ ;;;; ;;;; See the LICENSE file for licensing information. -(defsystem usocket - :name "usocket" +(in-package :asdf) + +;;; NOTE: the key "art" here is, no need to recompile any file when switching +;;; between a native backend and IOlib backend. -- Chun Tian (binghe) + +#+sample +(pushnew :usocket-iolib *features*) + +(defsystem #:usocket + :name "usocket (client)" :author "Erik Enge & Erik Huelsmann" :maintainer "Chun Tian (binghe) & Hans Huebner" - :version "0.6.5" + :version "0.8.0" :licence "MIT" :description "Universal socket library for Common Lisp" - :depends-on (#+(or sbcl ecl) :sb-bsd-sockets) + :depends-on (:split-sequence + #+(and (or sbcl ecl) (not usocket-iolib)) :sb-bsd-sockets + #+usocket-iolib :iolib) :components ((:file "package") (:module "vendor" :depends-on ("package") :components (#+mcl (:file "kqueue") - #+mcl (:file "OpenTransportUDP") - (:file "spawn-thread") - (:file "split-sequence"))) + #+mcl (:file "OpenTransportUDP"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) + #-usocket-iolib (:module "backend" :depends-on ("condition") :components (#+abcl (:file "abcl") #+(or allegro cormanlisp) (:file "allegro") #+clisp (:file "clisp") + #+(or openmcl clozure) + (:file "openmcl") #+clozure (:file "clozure" :depends-on ("openmcl")) #+cmu (:file "cmucl") + #+(or sbcl ecl) (:file "sbcl") #+ecl (:file "ecl" :depends-on ("sbcl")) #+lispworks (:file "lispworks") #+mcl (:file "mcl") #+mocl (:file "mocl") - #+openmcl (:file "openmcl") - #+(or ecl sbcl) (:file "sbcl") - #+scl (:file "scl"))) + #+scl (:file "scl") + #+usocket-iolib (:file "iolib"))) + #-usocket-iolib (:file "option" :depends-on ("backend")) - (:file "server" :depends-on ("backend" "option")))) + #+usocket-iolib + (:module "backend" :depends-on ("condition") + :components ((:file "iolib" :depends-on ("iolib-sockopt")) + (:file "iolib-sockopt"))) + )) (defmethod perform ((op test-op) (c (eql (find-system :usocket)))) + (oos 'load-op :usocket-server) (oos 'load-op :usocket-test) (oos 'test-op :usocket-test)) diff --git a/usocket.lisp b/usocket.lisp index f93573d..6578a8a 100644 --- a/usocket.lisp +++ b/usocket.lisp @@ -2,6 +2,8 @@ (in-package :usocket) +(defvar *backend*) ; either :native or :iolib + (defparameter *wildcard-host* #(0 0 0 0) "Hostname to pass when all interfaces in the current system are to be bound. If this variable is passed to socket-listen, IPv6 capable @@ -683,3 +685,10 @@ streams to be created by `socket-accept'. `reuseaddress' is supported for backward compatibility (but deprecated); when both `reuseaddress' and `reuse-address' have been specified, the latter takes precedence. ") + +;;; Small utility functions mapping true/false to 1/0, moved here from option.lisp + +(proclaim '(inline bool->int int->bool)) + +(defun bool->int (bool) (if bool 1 0)) +(defun int->bool (int) (= 1 int)) diff --git a/vendor/spawn-thread.lisp b/vendor/spawn-thread.lisp deleted file mode 100644 index 81aa57a..0000000 --- a/vendor/spawn-thread.lisp +++ /dev/null @@ -1,78 +0,0 @@ -;;;; $Id$ -;;;; $URL$ - -;;;; SPWAN-THREAD from GBBopen's PortableThreads.lisp - -(in-package :usocket) - -#+(and digitool ccl-5.1) -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew ':digitool-mcl *features*)) - -;;; --------------------------------------------------------------------------- -;;; Add clozure feature to legacy OpenMCL: - -#+(and openmcl (not clozure)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew ':clozure *features*)) - -;;; =========================================================================== -;;; Features & warnings - -#+(or (and clisp (not mt)) - cormanlisp - (and cmu (not mp)) - (and ecl (not threads)) - gcl - mocl - (and sbcl (not sb-thread))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew ':threads-not-available *features*)) - -;;; --------------------------------------------------------------------------- - -#+threads-not-available -(defun threads-not-available (operation) - (warn "Threads are not available in ~a running on ~a; ~s was used." - (lisp-implementation-type) - (machine-type) - operation)) - -;;; =========================================================================== -;;; Spawn-Thread - -(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) - (mt:make-thread #'(lambda () (apply function args)) - :name name) - #+clozure - (apply #'ccl:process-run-function name function args) - #+(and cmu mp) - (mp:make-process #'(lambda () (apply function args)) - :name name) - #+digitool-mcl - (apply #'ccl:process-run-function name function args) - #+(and ecl threads) - (apply #'mp:process-run-function name function args) - #+lispworks - (apply #'mp:process-run-function name nil function args) - #+(and sbcl sb-thread) - (sb-thread:make-thread #'(lambda () (apply function args)) - :name name) - #+scl - (mp:make-process #'(lambda () (apply function args)) - :name name) - #+abcl - (threads:make-thread #'(lambda () (apply function args)) - :name name) - #+threads-not-available - (declare (ignore name function args)) - #+threads-not-available - (threads-not-available 'spawn-thread)) diff --git a/vendor/split-sequence.lisp b/vendor/split-sequence.lisp deleted file mode 100644 index 6701b8c..0000000 --- a/vendor/split-sequence.lisp +++ /dev/null @@ -1,245 +0,0 @@ -;;;; SPLIT-SEQUENCE -;;; -;;; This code was based on Arthur Lemmens' in -;;; ; -;;; -;;; changes include: -;;; -;;; * altering the behaviour of the :from-end keyword argument to -;;; return the subsequences in original order, for consistency with -;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only -;;; affects the answer if :count is less than the number of -;;; subsequences, by analogy with the above-referenced functions). -;;; -;;; * changing the :maximum keyword argument to :count, by analogy -;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. -;;; -;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather -;;; than SPLIT. -;;; -;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. -;;; -;;; * The second return value is now an index rather than a copy of a -;;; portion of the sequence; this index is the `right' one to feed to -;;; CL:SUBSEQ for continued processing. - -;;; There's a certain amount of code duplication here, which is kept -;;; to illustrate the relationship between the SPLIT-SEQUENCE -;;; functions and the CL:POSITION functions. - -;;; Examples: -;;; -;;; * (split-sequence #\; "a;;b;c") -;;; -> ("a" "" "b" "c"), 6 -;;; -;;; * (split-sequence #\; "a;;b;c" :from-end t) -;;; -> ("a" "" "b" "c"), 0 -;;; -;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) -;;; -> ("c"), 4 -;;; -;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) -;;; -> ("a" "b" "c"), 6 -;;; -;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") -;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 -;;; -;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") -;;; -> ("ab" "a" "a" "ab" "a"), 11 -;;; -;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) -;;; -> ("oo" "bar" "b"), 9 - -#+ignore ; comment by usocket -(defpackage "SPLIT-SEQUENCE" - (:use "CL") - (:nicknames "PARTITION") - (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" - "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) - -(in-package :usocket #+ignore "SPLIT-SEQUENCE") - -(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by delimiter. - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE. In particular, the -behaviour of :from-end is possibly different from other versions of -this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (nconc (when test-supplied - (list :test test)) - (when test-not-supplied - (list :test-not test-not)) - (when key-supplied - (list :key key))))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position delimiter seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position delimiter seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by items satisfying -predicate. - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE-IF. In particular, the -behaviour of :from-end is possibly different from other versions of -this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (when key-supplied - (list :key key)))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position-if predicate seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position-if predicate seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) - "Return a list of subsequences in seq delimited by items satisfying -(CL:COMPLEMENT predicate). - -If :remove-empty-subseqs is NIL, empty subsequences will be included -in the result; otherwise they will be discarded. All other keywords -work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, -the behaviour of :from-end is possibly different from other versions -of this function; :from-end values of NIL and T are equivalent unless -:count is supplied. The second return value is an index suitable as an -argument to CL:SUBSEQ into the sequence indicating where processing -stopped." - (let ((len (length seq)) - (other-keys (when key-supplied - (list :key key)))) - (unless end (setq end len)) - (if from-end - (loop for right = end then left - for left = (max (or (apply #'position-if-not predicate seq - :end right - :from-end t - other-keys) - -1) - (1- start)) - unless (and (= right (1+ left)) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values (nreverse subseqs) right) - else - collect (subseq seq (1+ left) right) into subseqs - and sum 1 into nr-elts - until (< left start) - finally (return (values (nreverse subseqs) (1+ left)))) - (loop for left = start then (+ right 1) - for right = (min (or (apply #'position-if-not predicate seq - :start left - other-keys) - len) - end) - unless (and (= right left) - remove-empty-subseqs) ; empty subseq we don't want - if (and count (>= nr-elts count)) - ;; We can't take any more. Return now. - return (values subseqs left) - else - collect (subseq seq left right) into subseqs - and sum 1 into nr-elts - until (>= right end) - finally (return (values subseqs right)))))) - -;;; clean deprecation - -(defun partition (&rest args) - (apply #'split-sequence args)) - -(defun partition-if (&rest args) - (apply #'split-sequence-if args)) - -(defun partition-if-not (&rest args) - (apply #'split-sequence-if-not args)) - -(define-compiler-macro partition (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") - form) - -(define-compiler-macro partition-if (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") - form) - -(define-compiler-macro partition-if-not (&whole form &rest args) - (declare (ignore args)) - (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") - form) - -#+ignore ; comment by usocket -(pushnew :split-sequence *features*)