pax_global_header00006660000000000000000000000064136001356640014516gustar00rootroot0000000000000052 comment=fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2 usocket-0.8.3/000077500000000000000000000000001360013566400132035ustar00rootroot00000000000000usocket-0.8.3/.gitignore000066400000000000000000000000031360013566400151640ustar00rootroot00000000000000*~ usocket-0.8.3/CHANGES000066400000000000000000000250331360013566400142010ustar00rootroot000000000000000.8.3: * New experimental backend: Mezzano (contributed by Bruno Cichon, #51) * Bugfix: WAIT-FOR-INPUT fails to honor :ready-only t (#57, thanks to @Reepca for reporting this issue) * Bugfix: [ECL] Fix read-select in backend/sbcl.lisp to loop if interrupted (#54, #55, thanks to @thijs) * [CCL] Fix compiling with (readtable-case readtable-case) of :invert. (#56, patch from @genworks) * [Genera] added file attibutes (to all USOCKET lisp files) for Genera. 0.8.2: (June 11, 2019) * General: now the HOST-OR-IP slot of NS-CONDITION has been exported. (#46) * Bugfix: NS-HOST-NOT-FOUND-ERROR condition has unbound HOST-OR-IP slot (#46) * Bugfix: [SBCL/LW] WAIT-FOR-INPUT waits only in the first call (when W-F-I is called with a single usocket, introduced in 0.8.0) (#50, thanks to @Hamayama for reporting/hints/testing this issue) 0.8.1: (Feb 27, 2019) * New backend: clasp (patch from Christian Schafmeister, #45) * Bugfix: [SBCL] fixed loading usocket.asd in SBCL 1.5.0 0.8.0: (Feb 4, 2019) * New backend (experimental): IOlib. (Push :USOCKET-IOLIB to *FEATURES* to enable this feature) * New feature: Optimized WAIT-FOR-INPUT for single-socket case (one-time consing) * New feature: Exported host-to-hostname (#42) * Bugfix: [SBCL] more robust/thread-safe WAIT-FOR-INPUT-INTERNAL 0.7.1: (Aug 31, 2018) * New feature: GET-(RANDOM)-HOST-BY-NAME (now exported) prefer IPv4 on mixed IPv4/IPv6 (suggested by Mark H. David) * New backend: Symbolics Open Genera (Lisp machine) (patch from @Symbolics, #33) * Bugfix: [CLISP] fixed issues in server sockets and error handling. (patch from @vibs29, #28, #29) * Bugfix: [SBCL, ECL] Fix wait-for-input on Windows SBCL and ECL. (patch from Stas Boukarev, #30) * Bugfix: [LW] fixed non-existing system calls in LW 5.0 (comm::socket-set-tcp-nodelay) 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. * Bugfix: [LW] fixed loading in LispWorks 5.x & 6.x. * Bugfix: [LW] fixed SOCKET-SHUTDOWN in all versions. * Bugfix: [ABCL] Fixed incorrect IPv6 addresses (#26), patch from Elias Mårtenson (lokedhs) 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) * New feature: [Corman] minimal initial support of this platform * Bugfix: [SBCL/win32] wait-for-input nil-timeout bug (patch from Michal Herda, #13) * 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: (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: (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: (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). * New feature: Added TCP-NO-DELAY (TCP_NODELAY) support in SOCKET-OPTION, for TCP client * 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: (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. * New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers now) * Bugfix: [ECL] ECL now list sb-bsd-sockets as a dependency but relies on REQUIRE. (patched by Juanjo) * Bugfix: [ABCL] Make USOCKET compile warning-free on ABCL again: MAKE-IMMEDIATE-OBJECT was deprecated a while ago in favor of 2 predefined constants. * 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: (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) * Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard by Martin Simmons). * 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: (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: (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: (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 ) * Bugfix: [ABCL] Fix SOCKET-ACCEPT to follow the documented API so that when called without an :ELEMENT-TYPE argument. (Thanks to Mark Evenson, the ABCL developer) * Bugfix: [LispWorks] Fixed SOCKET-ACCEPT (Windows only) on WAIT-FOR-INPUTed sockets. * Bugfix: [SBCL, ECL] Fixed wrongly STATE set/unset for WAIT-FOR-INPUT on Windows (report by Elliott Slaughter) * Enhancement: Additional NAME keyword argument for SOCKET-SERVER for setting the server thread name. * Enhancement: [ABCL] GET-ADDRESS now works with underlying IPv6 addresses. * Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added. 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. * Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. * Enhancement: [CLISP] Better network error type detection based on OS error code. * Enhancement: [LispWorks] Better network error type detection based on OS error code. * Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions (since 0.4.0) * 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: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version). 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) * Add WAIT-FOR-INPUT support for SBCL and ECL on win32. * Simple TCP and UDP server API: SOCKET-SERVER * Completely rewritten full-feature ABCL backends using latest Java interfaces * Lots of bug fixed since 0.4.1 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) * Initial release usocket-0.8.3/CONTRIBUTORS000066400000000000000000000022021360013566400150570ustar00rootroot00000000000000-*- Mode: outline -*- List of major USOCKET contributors: * Erik Enge * Erik Huelsmann - original authors * Chun Tian * Hans Huebner - current maintainers * Attila Lendvai - better handling of unsupported Lisps * Vladimir Sekissov - fixes for CMUCL implementation * Pierre Thierry - added license information * Stelian Ionescu - finished conversion from generic functions - enabled running thread-safe code in unthreaded lisps * Douglas Crosher - added Scieneer Common Lisp support * Frank James - UDP fixes and test cases * Mark H. David - UDP test cases - Suggestions on fixing GET-HOST-BY-NAME and HOST-TO-HBO * Elliott Slaughter - Advanced WAIT-FOR-INPUT test case * Anton Vodonosov - CLISP fixes * Terje Norderhaug - MCL vendor code * @Hamayama - Reporting/hints/testing of issue #50 (regression in 0.8.0, 0.8.1) usocket-0.8.3/LICENSE000066400000000000000000000023441360013566400142130ustar00rootroot00000000000000(This is the MIT / X Consortium license as taken from http://www.opensource.org/licenses/mit-license.html) Copyright (c) 2003 Erik Enge Copyright (c) 2006-2007 Erik Huelsmann Copyright (c) 2008-2019 Hans Hueber and Chun Tian Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. usocket-0.8.3/README.md000066400000000000000000000130561360013566400144670ustar00rootroot00000000000000## USOCKET - Universal socket library for Common Lisp https://common-lisp.net/project/usocket/ This is the usocket Common Lisp sockets library: a library to bring sockets access to the broadest of common lisp implementations as possible. ## The library currently supports: 1. Allegro CL 2. ABCL (ArmedBear) 3. Clasp 4. Clozure CL 5. Corman Lisp 6. GNU CLISP 7. CMUCL 8. ECL 9. LispWorks (4.3 and up) 10. Digitool MCL and RMCL (5.0 and up) 11. Mezzano 12. MOCL 13. SBCL 14. Scieneer CL 15. Symbolics Lisp Machine (Genera) If your favorite common lisp misses in the list above, please contact usocket-devel@common-lisp.net and submit a request. Please include references to available sockets functions in your lisp implementation. The library has been ASDF (http://cliki.net/ASDF) enabled, meaning that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL the package in your system package site. (Or use your usual ASDF tricks to use the checkout directly.) ## Remarks on licensing Even though the source code has an MIT style license attached to it, when compiling this code with some of the supported lisp implementations you may not end up with an MIT style binary version due to the licensing of the implementations themselves. ECL is such an example and - when it will become supported - GCL is like that too. ## Non-support of :external-format Because of its definition in the hyperspec, there's no common external-format between lisp implementations: every vendor has chosen a different way to solve the problem of newline translation or character set recoding. Because there's no way to avoid platform specific code in the application when using external-format, the purpose of a portability layer gets defeated. So, for now, usocket doesn't support external-format. The workaround to get reasonably portable external-format support is to layer a flexi-stream (from flexi-streams) on top of a usocket stream. ## API definition - usocket (class) - stream-usocket (class; usocket derivative) - stream-server-usocket (class; usocket derivative) - socket-connect (function) [ to create an active/connected socket ] socket-connect host port &key element-type where `host' is a vectorized ip or a string representation of a dotted ip address or a hostname for lookup in the DNS system - socket-listen (function) [ to create a passive/listening socket ] socket-listen host port &key reuseaddress backlog element-type where `host' has the same definition as above - socket-accept (method) [ to create an active/connected socket ] socket-accept socket &key element-type returns (server side) a connected socket derived from a listening/passive socket. - socket-close (method) socket-close socket where socket a previously returned socket - socket (usocket slot accessor), the internal/implementation defined socket representation - socket-stream (usocket slot accessor), socket-stream socket the return value of which satisfies the normal stream interface - socket-shutdown ### Errors: - address-in-use-error - address-not-available-error - bad-file-descriptor-error - connection-refused-error - connection-aborted-error - connection-reset-error - invalid-argument-error - no-buffers-error - operation-not-supported-error - operation-not-permitted-error - protocol-not-supported-error - socket-type-not-supported-error - network-unreachable-error - network-down-error - network-reset-error - host-down-error - host-unreachable-error - shutdown-error - timeout-error - unkown-error ### Non-fatal conditions: - interrupted-condition - unkown-condition (for a description of the API methods and functions see https://common-lisp.net/project/usocket/api-docs.shtml) ## Test suite The test suite unfortunately isn't mature enough yet to run without some manual configuration. Several elements are required which are hard to programatically detect. Please adjust the test file before running the tests, for these variables: - +non-existing-host+: The stringified IP address of a host on the same subnet. No physical host may be present. - +unused-local-port+: A port number of a port not in use on the machine the tests run on. - +common-lisp-net+: A vector with 4 integer elements which make up an IP address. This must be the IP "common-lisp.net" resolves to. ## Known problems - CMUCL error reporting wrt sockets raises only simple-errors meaning there's no way to tell different error conditions apart. All errors are mapped to unknown-error on CMUCL. - The ArmedBear backend doesn't do any error mapping (yet). Java defines exceptions at the wrong level (IMO), since the exception reported bares a relation to the function failing, not the actual error that occurred: for example 'Address already in use' (when creating a passive socket) is reported as a BindException with an error text of 'Address already in use'. There's no way to sanely map 'BindException' to a meaningfull error in usocket. [This does not mean the backend should not at least map to 'unknown-error'!] - When using the library with ECL, you need the C compiler installed to be able to compile and load the Foreign Function Interface. Not all ECL targets support DFFI yet, so on some targets this would be the case anyway. By depending on this technique, usocket can reuse the FFI code on all platforms (including Windows). This benefit currently outweighs the additional requirement. (hey, it's *Embeddable* Common Lisp, so, you probably wanted to embed it all along, right?) usocket-0.8.3/TODO000066400000000000000000000002631360013566400136740ustar00rootroot00000000000000- Fix condition systems (making all implementation generate same error) - Add INET6 support. - IOlib backend For more TODO items, see http://trac.common-lisp.net/usocket/report. usocket-0.8.3/backend/000077500000000000000000000000001360013566400145725ustar00rootroot00000000000000usocket-0.8.3/backend/.gitignore000066400000000000000000000000031360013566400165530ustar00rootroot00000000000000*~ usocket-0.8.3/backend/abcl.lisp000066400000000000000000000473641360013566400164020ustar00rootroot00000000000000;;;; New ABCL networking support (replacement to old armedbear.lisp) ;;;; Author: Chun Tian (binghe) ;;;; See LICENSE for licensing information. (in-package :usocket) ;;; Java Classes ($*...) (defvar $*boolean (jclass "boolean")) (defvar $*byte (jclass "byte")) (defvar $*byte[] (jclass "[B")) (defvar $*int (jclass "int")) (defvar $*long (jclass "long")) (defvar $*|Byte| (jclass "java.lang.Byte")) (defvar $*DatagramChannel (jclass "java.nio.channels.DatagramChannel")) (defvar $*DatagramPacket (jclass "java.net.DatagramPacket")) (defvar $*DatagramSocket (jclass "java.net.DatagramSocket")) (defvar $*Inet4Address (jclass "java.net.Inet4Address")) (defvar $*InetAddress (jclass "java.net.InetAddress")) (defvar $*InetSocketAddress (jclass "java.net.InetSocketAddress")) (defvar $*Iterator (jclass "java.util.Iterator")) (defvar $*SelectableChannel (jclass "java.nio.channels.SelectableChannel")) (defvar $*SelectionKey (jclass "java.nio.channels.SelectionKey")) (defvar $*Selector (jclass "java.nio.channels.Selector")) (defvar $*ServerSocket (jclass "java.net.ServerSocket")) (defvar $*ServerSocketChannel (jclass "java.nio.channels.ServerSocketChannel")) (defvar $*Set (jclass "java.util.Set")) (defvar $*Socket (jclass "java.net.Socket")) (defvar $*SocketAddress (jclass "java.net.SocketAddress")) (defvar $*SocketChannel (jclass "java.nio.channels.SocketChannel")) (defvar $*String (jclass "java.lang.String")) ;;; Java Constructor ($%.../n) (defvar $%Byte/0 (jconstructor $*|Byte| $*byte)) (defvar $%DatagramPacket/3 (jconstructor $*DatagramPacket $*byte[] $*int $*int)) (defvar $%DatagramPacket/5 (jconstructor $*DatagramPacket $*byte[] $*int $*int $*InetAddress $*int)) (defvar $%DatagramSocket/0 (jconstructor $*DatagramSocket)) (defvar $%DatagramSocket/1 (jconstructor $*DatagramSocket $*int)) (defvar $%DatagramSocket/2 (jconstructor $*DatagramSocket $*int $*InetAddress)) (defvar $%InetSocketAddress/1 (jconstructor $*InetSocketAddress $*int)) (defvar $%InetSocketAddress/2 (jconstructor $*InetSocketAddress $*InetAddress $*int)) (defvar $%ServerSocket/0 (jconstructor $*ServerSocket)) (defvar $%ServerSocket/1 (jconstructor $*ServerSocket $*int)) (defvar $%ServerSocket/2 (jconstructor $*ServerSocket $*int $*int)) (defvar $%ServerSocket/3 (jconstructor $*ServerSocket $*int $*int $*InetAddress)) (defvar $%Socket/0 (jconstructor $*Socket)) (defvar $%Socket/2 (jconstructor $*Socket $*InetAddress $*int)) (defvar $%Socket/4 (jconstructor $*Socket $*InetAddress $*int $*InetAddress $*int)) ;;; Java Methods ($@...[/Class]/n) (defvar $@accept/0 (jmethod $*ServerSocket "accept")) (defvar $@bind/DatagramSocket/1 (jmethod $*DatagramSocket "bind" $*SocketAddress)) (defvar $@bind/ServerSocket/1 (jmethod $*ServerSocket "bind" $*SocketAddress)) (defvar $@bind/ServerSocket/2 (jmethod $*ServerSocket "bind" $*SocketAddress $*int)) (defvar $@bind/Socket/1 (jmethod $*Socket "bind" $*SocketAddress)) (defvar $@byteValue/0 (jmethod $*|Byte| "byteValue")) (defvar $@channel/0 (jmethod $*SelectionKey "channel")) (defvar $@close/DatagramSocket/0 (jmethod $*DatagramSocket "close")) (defvar $@close/Selector/0 (jmethod $*Selector "close")) (defvar $@close/ServerSocket/0 (jmethod $*ServerSocket "close")) (defvar $@close/Socket/0 (jmethod $*Socket "close")) (defvar $@shutdownInput/Socket/0 (jmethod $*Socket "shutdownInput")) (defvar $@shutdownOutput/Socket/0 (jmethod $*Socket "shutdownOutput")) (defvar $@configureBlocking/1 (jmethod $*SelectableChannel "configureBlocking" $*boolean)) (defvar $@connect/DatagramChannel/1 (jmethod $*DatagramChannel "connect" $*SocketAddress)) (defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress)) (defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int)) (defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress)) (defvar $@getAddress/0 (jmethod $*InetAddress "getAddress")) (defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String)) (defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String)) (defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel")) (defvar $@getChannel/ServerSocket/0 (jmethod $*ServerSocket "getChannel")) (defvar $@getChannel/Socket/0 (jmethod $*Socket "getChannel")) (defvar $@getAddress/DatagramPacket/0 (jmethod $*DatagramPacket "getAddress")) (defvar $@getHostName/0 (jmethod $*InetAddress "getHostName")) (defvar $@getInetAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getInetAddress")) (defvar $@getInetAddress/ServerSocket/0 (jmethod $*ServerSocket "getInetAddress")) (defvar $@getInetAddress/Socket/0 (jmethod $*Socket "getInetAddress")) (defvar $@getLength/DatagramPacket/0 (jmethod $*DatagramPacket "getLength")) (defvar $@getLocalAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalAddress")) (defvar $@getLocalAddress/Socket/0 (jmethod $*Socket "getLocalAddress")) (defvar $@getLocalPort/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalPort")) (defvar $@getLocalPort/ServerSocket/0 (jmethod $*ServerSocket "getLocalPort")) (defvar $@getLocalPort/Socket/0 (jmethod $*Socket "getLocalPort")) (defvar $@getOffset/DatagramPacket/0 (jmethod $*DatagramPacket "getOffset")) (defvar $@getPort/DatagramPacket/0 (jmethod $*DatagramPacket "getPort")) (defvar $@getPort/DatagramSocket/0 (jmethod $*DatagramSocket "getPort")) (defvar $@getPort/Socket/0 (jmethod $*Socket "getPort")) (defvar $@hasNext/0 (jmethod $*Iterator "hasNext")) (defvar $@iterator/0 (jmethod $*Set "iterator")) (defvar $@next/0 (jmethod $*Iterator "next")) (defvar $@open/DatagramChannel/0 (jmethod $*DatagramChannel "open")) (defvar $@open/Selector/0 (jmethod $*Selector "open")) (defvar $@open/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "open")) (defvar $@open/SocketChannel/0 (jmethod $*SocketChannel "open")) (defvar $@receive/1 (jmethod $*DatagramSocket "receive" $*DatagramPacket)) (defvar $@register/2 (jmethod $*SelectableChannel "register" $*Selector $*int)) (defvar $@select/0 (jmethod $*Selector "select")) (defvar $@select/1 (jmethod $*Selector "select" $*long)) (defvar $@selectedKeys/0 (jmethod $*Selector "selectedKeys")) (defvar $@send/1 (jmethod $*DatagramSocket "send" $*DatagramPacket)) (defvar $@setReuseAddress/1 (jmethod $*ServerSocket "setReuseAddress" $*boolean)) (defvar $@setSoTimeout/DatagramSocket/1 (jmethod $*DatagramSocket "setSoTimeout" $*int)) (defvar $@setSoTimeout/Socket/1 (jmethod $*Socket "setSoTimeout" $*int)) (defvar $@setTcpNoDelay/1 (jmethod $*Socket "setTcpNoDelay" $*boolean)) (defvar $@socket/DatagramChannel/0 (jmethod $*DatagramChannel "socket")) (defvar $@socket/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "socket")) (defvar $@socket/SocketChannel/0 (jmethod $*SocketChannel "socket")) (defvar $@validOps/0 (jmethod $*SelectableChannel "validOps")) ;;; Java Field Variables ($+...) (defvar $+op-accept (jfield $*SelectionKey "OP_ACCEPT")) (defvar $+op-connect (jfield $*SelectionKey "OP_CONNECT")) (defvar $+op-read (jfield $*SelectionKey "OP_READ")) (defvar $+op-write (jfield $*SelectionKey "OP_WRITE")) ;;; Wrapper functions (return-type: java-object) (defun %get-address (address) (jcall $@getAddress/0 address)) (defun %get-all-by-name (string) ; return a simple vector (jstatic $@getAllByName/1 $*InetAddress string)) (defun %get-by-name (string) (jstatic $@getByName/1 $*InetAddress string)) (defun host-to-inet4 (host) "USOCKET host formats to Java Inet4Address, used internally." (%get-by-name (host-to-hostname host))) ;;; HANDLE-CONTITION (defparameter +abcl-error-map+ `(("java.net.BindException" . operation-not-permitted-error) ("java.net.ConnectException" . connection-refused-error) ("java.net.NoRouteToHostException" . network-unreachable-error) ; untested ("java.net.PortUnreachableException" . protocol-not-supported-error) ; untested ("java.net.ProtocolException" . protocol-not-supported-error) ; untested ("java.net.SocketException" . socket-type-not-supported-error) ; untested ("java.net.SocketTimeoutException" . timeout-error))) (defparameter +abcl-nameserver-error-map+ `(("java.net.UnknownHostException" . ns-host-not-found-error))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) (typecase condition (java-exception (let ((java-cause (java-exception-cause condition))) (let* ((usock-error (cdr (assoc (jclass-of java-cause) +abcl-error-map+ :test #'string=))) (usock-error (if (functionp usock-error) (funcall usock-error condition) usock-error)) (nameserver-error (cdr (assoc (jclass-of java-cause) +abcl-nameserver-error-map+ :test #'string=)))) (if nameserver-error (error nameserver-error :socket socket :host-or-ip host-or-ip) (when usock-error (error usock-error :socket socket)))))))) ;;; GET-HOSTS-BY-NAME (defun get-address (address) (when address (let* ((array (%get-address address)) (length (jarray-length array))) (labels ((jbyte (n) (let ((byte (jarray-ref array n))) (if (minusp byte) (+ 256 byte) byte)))) (cond ((= 4 length) (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3))) ((= 16 length) (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3) (jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7) (jbyte 8) (jbyte 9) (jbyte 10) (jbyte 11) (jbyte 12) (jbyte 13) (jbyte 14) (jbyte 15))) (t nil)))))) ; neither a IPv4 nor IPv6 address?! (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (map 'list #'get-address (%get-all-by-name name)))) ;;; GET-HOST-BY-ADDRESS (defun get-host-by-address (host) (let ((inet4 (host-to-inet4 host))) (with-mapped-conditions (nil host) (jcall $@getHostName/0 inet4)))) ;;; SOCKET-CONNECT (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-supplied-p) local-host local-port) (when deadline (unsupported 'deadline 'socket-connect)) (let (socket stream usocket) (ecase protocol (:stream ; TCP (let ((channel (jstatic $@open/SocketChannel/0 $*SocketChannel)) (address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port))) (setq socket (jcall $@socket/SocketChannel/0 channel)) ;; bind to local address if needed (when (or local-host local-port) (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0)))) (with-mapped-conditions (nil host) (jcall $@bind/Socket/1 socket local-address)))) ;; connect to dest address (with-mapped-conditions (nil host) (jcall $@connect/SocketChannel/1 channel address)) (setq stream (ext:get-socket-stream socket :element-type element-type) usocket (make-stream-socket :stream stream :socket socket)) (when nodelay-supplied-p (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+ java:+true+ java:+false+))) (when timeout (jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout)))))) (:datagram ; UDP (let ((channel (jstatic $@open/DatagramChannel/0 $*DatagramChannel))) (setq socket (jcall $@socket/DatagramChannel/0 channel)) ;; bind to local address if needed (when (or local-host local-port) (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0)))) (with-mapped-conditions (nil local-host) (jcall $@bind/DatagramSocket/1 socket local-address)))) ;; connect to dest address if needed (when (and host port) (let ((address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port))) (with-mapped-conditions (nil host) (jcall $@connect/DatagramChannel/1 channel address)))) (setq usocket (make-datagram-socket socket :connected-p (if (and host port) t nil))) (when timeout (jcall $@setSoTimeout/DatagramSocket/1 socket (truncate (* 1000 timeout))))))) usocket)) ;;; SOCKET-LISTEN (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5 backlog-supplied-p) (element-type 'character)) (declare (type boolean reuse-address)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel)) (socket (jcall $@socket/ServerSocketChannel/0 channel)) (endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0)))) (jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+)) (with-mapped-conditions (socket host) (if backlog-supplied-p (jcall $@bind/ServerSocket/2 socket endpoint backlog) (jcall $@bind/ServerSocket/1 socket endpoint))) (make-stream-server-socket socket :element-type element-type))) ;;; SOCKET-ACCEPT (defmethod socket-accept ((usocket stream-server-usocket) &key (element-type 'character element-type-p)) (with-mapped-conditions (usocket) (let* ((client-socket (jcall $@accept/0 (socket usocket))) (element-type (if element-type-p element-type (element-type usocket))) (stream (ext:get-socket-stream client-socket :element-type element-type))) (make-stream-socket :stream stream :socket client-socket)))) ;;; SOCKET-CLOSE (defmethod socket-close ((usocket stream-server-usocket)) (with-mapped-conditions (usocket) (jcall $@close/ServerSocket/0 (socket usocket)))) (defmethod socket-close ((usocket stream-usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket)) (jcall $@close/Socket/0 (socket usocket)))) (defmethod socket-close ((usocket datagram-usocket)) (with-mapped-conditions (usocket) (jcall $@close/DatagramSocket/0 (socket usocket)))) (defmethod socket-shutdown ((usocket stream-usocket) direction) (with-mapped-conditions (usocket) (ecase direction (:input (jcall $@shutdownInput/Socket/0 (socket usocket))) (:output (jcall $@shutdownOutput/Socket/0 (socket usocket)))))) ;;; GET-LOCAL/PEER-NAME/ADDRESS/PORT (defmethod get-local-name ((usocket usocket)) (values (get-local-address usocket) (get-local-port usocket))) (defmethod get-peer-name ((usocket usocket)) (values (get-peer-address usocket) (get-peer-port usocket))) (defmethod get-local-address ((usocket stream-usocket)) (get-address (jcall $@getLocalAddress/Socket/0 (socket usocket)))) (defmethod get-local-address ((usocket stream-server-usocket)) (get-address (jcall $@getInetAddress/ServerSocket/0 (socket usocket)))) (defmethod get-local-address ((usocket datagram-usocket)) (get-address (jcall $@getLocalAddress/DatagramSocket/0 (socket usocket)))) (defmethod get-peer-address ((usocket stream-usocket)) (get-address (jcall $@getInetAddress/Socket/0 (socket usocket)))) (defmethod get-peer-address ((usocket datagram-usocket)) (get-address (jcall $@getInetAddress/DatagramSocket/0 (socket usocket)))) (defmethod get-local-port ((usocket stream-usocket)) (jcall $@getLocalPort/Socket/0 (socket usocket))) (defmethod get-local-port ((usocket stream-server-usocket)) (jcall $@getLocalPort/ServerSocket/0 (socket usocket))) (defmethod get-local-port ((usocket datagram-usocket)) (jcall $@getLocalPort/DatagramSocket/0 (socket usocket))) (defmethod get-peer-port ((usocket stream-usocket)) (jcall $@getPort/Socket/0 (socket usocket))) (defmethod get-peer-port ((usocket datagram-usocket)) (jcall $@getPort/DatagramSocket/0 (socket usocket))) ;;; SOCKET-SEND & SOCKET-RECEIVE (defun *->byte (data) (declare (type (unsigned-byte 8) data)) ; required by SOCKET-SEND (jnew $%Byte/0 (if (> data 127) (- data 256) data))) (defun byte->* (byte &optional (element-type '(unsigned-byte 8))) (let* ((ub8 (if (minusp byte) (+ 256 byte) byte))) (if (eq element-type 'character) (code-char ub8) ub8))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (let* ((socket (socket usocket)) (byte-array (jnew-array $*byte size)) (packet (if (and host port) (jnew $%DatagramPacket/5 byte-array 0 size (host-to-inet4 host) port) (jnew $%DatagramPacket/3 byte-array 0 size)))) ;; prepare sending data (loop for i from offset below (+ size offset) do (setf (jarray-ref byte-array i) (*->byte (aref buffer i)))) (with-mapped-conditions (usocket host) (jcall $@send/1 socket packet)))) ;;; 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)) (packet (jnew $%DatagramPacket/3 byte-array 0 real-length))) (with-mapped-conditions (usocket) (jcall $@receive/1 socket packet)) (let* ((receive-length (jcall $@getLength/DatagramPacket/0 packet)) (return-buffer (or buffer (make-array receive-length :element-type element-type)))) (loop for i from 0 below receive-length do (setf (aref return-buffer i) (byte->* (jarray-ref byte-array i) element-type))) (let ((return-host (if (connected-p usocket) (get-peer-address usocket) (get-address (jcall $@getAddress/DatagramPacket/0 packet)))) (return-port (if (connected-p usocket) (get-peer-port usocket) (jcall $@getPort/DatagramPacket/0 packet)))) (values return-buffer receive-length return-host return-port))))) ;;; WAIT-FOR-INPUT (defun socket-channel-class (usocket) (cond ((stream-usocket-p usocket) $*SocketChannel) ((stream-server-usocket-p usocket) $*ServerSocketChannel) ((datagram-usocket-p usocket) $*DatagramChannel))) (defun get-socket-channel (usocket) (let ((method (cond ((stream-usocket-p usocket) $@getChannel/Socket/0) ((stream-server-usocket-p usocket) $@getChannel/ServerSocket/0) ((datagram-usocket-p usocket) $@getChannel/DatagramSocket/0)))) (jcall method (socket usocket)))) (defun wait-for-input-internal (wait-list &key timeout) (let* ((sockets (wait-list-waiters wait-list)) (ops (logior $+op-read $+op-accept)) (selector (jstatic $@open/Selector/0 $*Selector)) (channels (mapcar #'get-socket-channel sockets))) (unwind-protect (with-mapped-conditions () (dolist (channel channels) (jcall $@configureBlocking/1 channel java:+false+) (jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel)))) (let ((ready-count (if timeout (jcall $@select/1 selector (truncate (* timeout 1000))) (jcall $@select/0 selector)))) (when (plusp ready-count) (let* ((keys (jcall $@selectedKeys/0 selector)) (iterator (jcall $@iterator/0 keys)) (%wait (wait-list-%wait wait-list))) (loop while (jcall $@hasNext/0 iterator) do (let* ((key (jcall $@next/0 iterator)) (channel (jcall $@channel/0 key))) (setf (state (gethash channel %wait)) :read))))))) (jcall $@close/Selector/0 selector) (dolist (channel channels) (jcall $@configureBlocking/1 channel java:+true+))))) ;;; WAIT-LIST ;;; NOTE from original worker (Erik): ;;; Note that even though Java has the concept of the Selector class, which ;;; remotely looks like a wait-list, it requires the sockets to be non-blocking. ;;; usocket however doesn't make any such guarantees and is therefore unable to ;;; use the concept outside of the waiting routine itself (blergh!). (defun %setup-wait-list (wl) (setf (wait-list-%wait wl) (make-hash-table :test #'equal :rehash-size 1.3d0))) (defun %add-waiter (wl w) (setf (gethash (get-socket-channel w) (wait-list-%wait wl)) w)) (defun %remove-waiter (wl w) (remhash (get-socket-channel w) (wait-list-%wait wl))) usocket-0.8.3/backend/allegro.lisp000066400000000000000000000206171360013566400171160ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) #+cormanlisp (eval-when (:compile-toplevel :load-toplevel :execute) (require :acl-socket)) #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :sock) ;; for wait-for-input: (require :process) ;; note: the line below requires ACL 6.2+ (require :osi)) (defun get-host-name () ;; note: the line below requires ACL 7.0+ to actually *work* on windows #+allegro (excl.osi:gethostname) #+cormanlisp "") (defparameter +allegro-identifier-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))) ;; TODO: what's the error class of Corman Lisp? (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (typecase condition #+allegro (excl:socket-error (let ((usock-error (cdr (assoc (excl:stream-error-identifier condition) +allegro-identifier-error-map+)))) (declare (type symbol usock-error)) (if usock-error (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (error 'unknown-error :real-error condition :socket socket)))))) (defun to-format (element-type) (if (subtypep element-type 'character) :text :binary)) (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) (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when (eq nodelay :if-supported) (setf nodelay t)) (let ((socket)) (setf socket (with-mapped-conditions (socket (or host local-host)) (ecase protocol (:stream (labels ((make-socket () (socket:make-socket :remote-host (host-to-hostname host) :remote-port port :local-host (when local-host (host-to-hostname local-host)) :local-port local-port :format (to-format element-type) :nodelay nodelay))) #+allegro (if timeout (mp:with-timeout (timeout nil) (make-socket)) (make-socket)) #+cormanlisp (make-socket))) (:datagram (apply #'socket:make-socket (nconc (list :type protocol :address-family :internet :local-host (when local-host (host-to-hostname local-host)) :local-port local-port :format (to-format element-type)) (if (and host port) (list :connect :active :remote-host (host-to-hostname host) :remote-port port) (list :connect :passive)))))))) (ecase protocol (:stream (make-stream-socket :socket socket :stream socket)) (:datagram (make-datagram-socket socket :connected-p (and host port t)))))) ;; One socket close method is sufficient, ;; because socket-streams are also sockets. (defmethod socket-close ((usocket usocket)) "Close socket." (with-mapped-conditions (usocket) (close (socket usocket)))) (defmethod socket-shutdown ((usocket stream-usocket) direction) (with-mapped-conditions (usocket) (socket:shutdown (socket usocket) :direction direction))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) ;; Allegro and OpenMCL socket interfaces bear very strong resemblence ;; whatever you change here, change it also for OpenMCL (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (sock (with-mapped-conditions (nil host) (apply #'socket:make-socket (append (list :connect :passive :reuse-address reuseaddress :local-port port :backlog backlog :format (to-format element-type) ;; allegro now ignores :format ) (when (ip/= host *wildcard-host*) (list :local-host host))))))) (make-stream-server-socket sock :element-type element-type))) (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (declare (ignore element-type)) ;; allegro streams are multivalent (let ((stream-sock (with-mapped-conditions (socket) (socket:accept-connection (socket socket))))) (make-stream-socket :socket stream-sock :stream stream-sock))) (defmethod get-local-address ((usocket usocket)) (hbo-to-vector-quad (socket:local-host (socket usocket)))) (defmethod get-peer-address ((usocket stream-usocket)) (hbo-to-vector-quad (socket:remote-host (socket usocket)))) (defmethod get-local-port ((usocket usocket)) (socket:local-port (socket usocket))) (defmethod get-peer-port ((usocket stream-usocket)) #+allegro (socket:remote-port (socket 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))) #+allegro (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (with-mapped-conditions (usocket host) (let ((s (socket usocket))) (socket:send-to s (if (zerop offset) buffer (subseq buffer offset (+ offset size))) size :remote-host host :remote-port port)))) #+allegro (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) (let ((s (socket usocket))) (socket:receive-from s length :buffer buffer :extract t)))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) (socket:ipaddr-to-hostname (host-to-hbo address)))) (defun get-hosts-by-name (name) ;;###FIXME: ACL has the acldns module which returns all A records ;; only problem: it doesn't fall back to tcp (from udp) if the returned ;; structure is too long. (with-mapped-conditions (nil name) (list (hbo-to-vector-quad (socket:lookup-hostname (host-to-hostname name)))))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (push (socket waiter) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) (setf (wait-list-%wait wait-list) (remove (socket waiter) (wait-list-%wait wait-list)))) #+allegro (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (let ((active-internal-sockets (if timeout (mp:wait-for-input-available (wait-list-%wait wait-list) :timeout timeout) (mp:wait-for-input-available (wait-list-%wait wait-list))))) ;; this is quadratic, but hey, the active-internal-sockets ;; list is very short and it's only quadratic in the length of that one. ;; When I have more time I could recode it to something of linear ;; complexity. ;; [Same code is also used in openmcl.lisp] (dolist (x active-internal-sockets) (setf (state (gethash x (wait-list-map wait-list))) :read)) wait-list))) usocket-0.8.3/backend/clasp.lisp000066400000000000000000000121451360013566400165700ustar00rootroot00000000000000(in-package :usocket) #-clasp (progn #-:wsock (ffi:clines "#include " "#include " "#include ") #+:wsock (ffi:clines "#ifndef FD_SETSIZE" "#define FD_SETSIZE 1024" "#endif" "#include ") (ffi:clines #+:msvc "#include " #-:msvc "#include " "#include ")) (progn #-clasp (defun cerrno () (ffi:c-inline () () :int "errno" :one-liner t)) #+clasp (defun cerrno () (sockets-internal:errno)) #-clasp (defun fd-setsize () (ffi:c-inline () () :fixnum "FD_SETSIZE" :one-liner t)) #+clasp (defun fd-setsize () (sockets-internal:fd-setsize)) #-clasp (defun fdset-alloc () (ffi:c-inline () () :pointer-void "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t)) #+clasp (defun fdset-alloc () (sockets-internal::alloc-atomic-sizeof-fd-set)) #-clasp (defun fdset-zero (fdset) (ffi:c-inline (fdset) (:pointer-void) :void "FD_ZERO((fd_set*)#0)" :one-liner t)) #+clasp(defun fdset-zero (fdset) (sockets-internal:fdset-zero fdset)) #-clasp (defun fdset-set (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void "FD_SET(#1,(fd_set*)#0)" :one-liner t)) #+clasp(defun fdset-set (fdset fd) (sockets-internal:fdset-set fd fdset)) #-clasp (defun fdset-clr (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void "FD_CLR(#1,(fd_set*)#0)" :one-liner t)) #+clasp(defun fdset-clr (fdset fd) (sockets-internal:fdset-clr fd fdset)) #-clasp (defun fdset-fd-isset (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool "FD_ISSET(#1,(fd_set*)#0)" :one-liner t)) #+clasp(defun fdset-fd-isset (fdset fd) (sockets-internal:fdset-isset fd fdset)) (declaim (inline cerrno fd-setsize fdset-alloc fdset-zero fdset-set fdset-clr fdset-fd-isset)) #-clasp (defun get-host-name () (ffi:c-inline () () :object "{ char *buf = (char *) ecl_alloc_atomic(257); if (gethostname(buf,256) == 0) @(return) = make_simple_base_string(buf); else @(return) = Cnil; }" :one-liner nil :side-effects nil)) #+clasp (defun get-host-name () (sockets-internal:get-host-name)) #-clasp (defun read-select (wl to-secs &optional (to-musecs 0)) (let* ((sockets (wait-list-waiters wl)) (rfds (wait-list-%wait wl)) (max-fd (reduce #'(lambda (x y) (let ((sy (sb-bsd-sockets:socket-file-descriptor (socket y)))) (if (< x sy) sy x))) (cdr sockets) :initial-value (sb-bsd-sockets:socket-file-descriptor (socket (car sockets)))))) (fdset-zero rfds) (dolist (sock sockets) (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor (socket sock)))) (let ((count (ffi:c-inline (to-secs to-musecs rfds max-fd) (t :unsigned-int :pointer-void :int) :int " int count; struct timeval tv; if (#0 != Cnil) { tv.tv_sec = fixnnint(#0); tv.tv_usec = #1; } @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL, (#0 != Cnil) ? &tv : NULL); " :one-liner nil))) (cond ((= 0 count) (values nil nil)) ((< count 0) ;; check for EINTR and EAGAIN; these should not err (values nil (cerrno))) (t (dolist (sock sockets) (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor (socket sock))) (setf (state sock) :READ)))))))) #+clasp (defun read-select (wl to-secs &optional (to-musecs 0)) (let* ((sockets (wait-list-waiters wl)) (rfds (wait-list-%wait wl)) (max-fd (reduce #'(lambda (x y) (let ((sy (sb-bsd-sockets:socket-file-descriptor (socket y)))) (if (< x sy) sy x))) (cdr sockets) :initial-value (sb-bsd-sockets:socket-file-descriptor (socket (car sockets)))))) (fdset-zero rfds) (dolist (sock sockets) (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor (socket sock)))) (let ((count (sockets-internal:do-select to-secs to-musecs rfds max-fd))) (cond ((= 0 count) (values nil nil)) ((< count 0) ;; check for EINTR and EAGAIN; these should not err (values nil (cerrno))) (t (dolist (sock sockets) (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor (socket sock))) (setf (state sock) :READ)))))))) ) usocket-0.8.3/backend/clisp.lisp000066400000000000000000000643241360013566400166060ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (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 (:name "gethostname") (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) :OUT :ALLOCA) (len ffi:int)) #+win32 (:library "WS2_32") #-win32 (:library :default) (:language #-win32 :stdc #+win32 :stdc-stdcall) (:return-type ffi:int)) (defun get-host-name () #+ffi (multiple-value-bind (retcode name) (get-host-name-internal 256) (when (= retcode 0) name)) #-ffi "localhost") (defun get-host-by-address (address) (with-mapped-conditions (nil address) (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) (posix:hostent-name hostent)))) (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (let ((hostent (posix:resolve-host-ipaddr name))) (mapcar #'host-to-vector-quad (posix:hostent-addr-list hostent))))) ;; Format: ((UNIX Windows) . CONDITION) (defparameter +clisp-error-map+ #-win32 `((:EADDRINUSE . address-in-use-error) (:EADDRNOTAVAIL . address-not-available-error) (:EBADF . bad-file-descriptor-error) (:ECONNREFUSED . connection-refused-error) (:ECONNRESET . connection-reset-error) (:ECONNABORTED . connection-aborted-error) (:EINVAL . invalid-argument-error) (:ENOBUFS . no-buffers-error) (:ENOMEM . out-of-memory-error) (:ENOTSUP . operation-not-supported-error) (:EPERM . operation-not-permitted-error) (:EPROTONOSUPPORT . protocol-not-supported-error) (:ESOCKTNOSUPPORT . socket-type-not-supported-error) (:ENETUNREACH . network-unreachable-error) (:ENETDOWN . network-down-error) (:ENETRESET . network-reset-error) (:ESHUTDOWN . already-shutdown-error) (:ETIMEDOUT . timeout-error) (:EHOSTDOWN . host-down-error) (:EHOSTUNREACH . host-unreachable-error) ;; when blocked reading, and we close our socket due to a timeout. ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values. (:EAGAIN . timeout-error) (:EWOULDBLOCK . timeout-error)) ;linux #+win32 `((:WSAEADDRINUSE . address-in-use-error) (:WSAEADDRNOTAVAIL . address-not-available-error) (:WSAEBADF . bad-file-descriptor-error) (:WSAECONNREFUSED . connection-refused-error) (:WSAECONNRESET . connection-reset-error) (:WSAECONNABORTED . connection-aborted-error) (:WSAEINVAL . invalid-argument-error) (:WSAENOBUFS . no-buffers-error) (:WSAENOMEM . out-of-memory-error) (:WSAENOTSUP . operation-not-supported-error) (:WSAEPERM . operation-not-permitted-error) (:WSAEPROTONOSUPPORT . protocol-not-supported-error) (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error) (:WSAENETUNREACH . network-unreachable-error) (:WSAENETDOWN . network-down-error) (:WSAENETRESET . network-reset-error) (:WSAESHUTDOWN . already-shutdown-error) (:WSAETIMEDOUT . timeout-error) (:WSAEHOSTDOWN . host-down-error) (:WSAEHOSTUNREACH . host-unreachable-error))) (defun parse-errno (condition) "Returns a number or keyword if it can parse what is within parens, else NIL" (let ((s (princ-to-string condition))) (let ((pos1 (position #\( s)) (pos2 (position #\) s))) ;mac: number, linux: keyword (ignore-errors (if (digit-char-p (char s (1+ pos1))) (parse-integer s :start (1+ pos1) :end pos2) (let ((*package* (find-package "KEYWORD"))) (car (read-from-string s t nil :start pos1 :end (1+ pos2))))))))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch a usocket condition instead of a CLISP specific one, if we can." (let ((errno (cond ;clisp 2.49+ ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT")) (parse-errno condition)) ;clisp 2.49 ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM")) (car (simple-condition-format-arguments condition)))))) (when errno (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno)))) (let ((usock-error (cdr (assoc error-keyword +clisp-error-map+)))) (when usock-error (if (subtypep usock-error 'error) (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (cond ((subtypep usock-error 'ns-condition) (signal usock-error :socket socket :host-or-ip host-or-ip)) (t (signal usock-error :socket socket)))))))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignorable timeout local-host local-port)) (when deadline (unsupported 'deadline 'socket-connect)) (when (and nodelay-specified (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (case protocol (:stream (let ((socket) (hostname (host-to-hostname host))) (with-mapped-conditions (socket host) (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 #+(or rawsock ffi) (with-mapped-conditions (nil (or host local-host)) (socket-create-datagram (or local-port *auto-port*) :local-host (or local-host *wildcard-host*) :remote-host (and host (host-to-vector-quad host)) :remote-port port)) #-(or rawsock ffi) (unsupported '(protocol :datagram) 'socket-connect)))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to ;; to explicitly turn it on; unfortunately, there's no way to turn it off... (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) (let ((sock (apply #'socket:socket-server (append (list port :backlog backlog) (when (ip/= host *wildcard-host*) (list :interface host)))))) (with-mapped-conditions (nil host) (make-stream-server-socket sock :element-type element-type)))) (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (let ((stream (with-mapped-conditions (socket) (socket:socket-accept (socket socket) :element-type (or element-type (element-type socket)))))) (make-stream-socket :socket stream :stream stream))) ;; Only one close method required: ;; sockets and their associated streams ;; are the same object (defmethod socket-close ((usocket usocket)) "Close socket." (with-mapped-conditions (usocket) (close (socket usocket)))) (defmethod socket-close ((usocket stream-server-usocket)) (socket:socket-server-close (socket usocket))) (defmethod socket-shutdown ((usocket stream-usocket) direction) (with-mapped-conditions (usocket) (socket:socket-stream-shutdown (socket usocket) direction))) (defmethod get-local-name ((usocket stream-usocket)) (multiple-value-bind (address port) (socket:socket-stream-local (socket usocket) t) (values (dotted-quad-to-vector-quad address) port))) (defmethod get-local-name ((usocket stream-server-usocket)) (values (get-local-address usocket) (get-local-port usocket))) (defmethod get-peer-name ((usocket stream-usocket)) (multiple-value-bind (address port) (socket:socket-stream-peer (socket usocket) t) (values (dotted-quad-to-vector-quad address) port))) (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) (defmethod get-local-address ((usocket stream-server-usocket)) (dotted-quad-to-vector-quad (socket:socket-server-host (socket 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-local-port ((usocket stream-server-usocket)) (socket:socket-server-port (socket usocket))) (defmethod get-peer-port ((usocket usocket)) (nth-value 1 (get-peer-name usocket))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) ;; clisp's #'socket-status takes a list whose elts look either like, ;; (socket-stream direction . x) or like, ;; (socket-server . x) ;; and it replaces the x's. (push (cons (socket waiter) (cond ((stream-usocket-p waiter) (cons NIL NIL)) (t NIL))) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) (setf (wait-list-%wait wait-list) (remove (socket waiter) (wait-list-%wait wait-list) :key #'car))) (defmethod wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) (dolist (x (wait-list-%wait wait-list)) (when (consp (cdr x)) ;it's a socket-stream not socket-server (setf (cadr x) :INPUT))) (let* ((request-list (wait-list-%wait wait-list)) (status-list (if timeout (socket:socket-status request-list secs musecs) (socket:socket-status request-list))) (sockets (wait-list-waiters wait-list))) (do* ((x (pop sockets) (pop sockets)) (y (cdr (last (pop status-list))) (cdr (last (pop status-list))))) ((null x)) (when (member y '(T :INPUT :EOF)) (setf (state x) :READ))) wait-list)))) ;;; ;;; 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 port sockaddr_in) (ip-to-octet-buffer ip sockaddr_in :start 2) sockaddr_in) (defun socket-create-datagram (local-port &key (local-host *wildcard-host*) remote-host remote-port) (let ((sock (rawsock:socket :inet :dgram 0)) (lsock_addr (fill-sockaddr_in (make-sockaddr_in) local-host local-port)) (rsock_addr (when remote-host (fill-sockaddr_in (make-sockaddr_in) remote-host (or remote-port local-port))))) (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) (when 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 (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))))) (let ((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 (if buffer real-buffer (subseq real-buffer 0 rv)) rv host port)))) (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0)) "Returns the number of octets sent." (let* ((sock (socket socket)) (sockaddr (when (and host port) (rawsock:make-sockaddr :inet (fill-sockaddr_in (make-sockaddr_in) (host-byte-order host) port)))) (real-size (min size +max-datagram-packet-size+)) (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*))) buffer (make-array real-size :element-type '(unsigned-byte 8) :initial-contents (subseq buffer 0 real-size)))) (rv (if (and host port) (rawsock:sendto sock real-buffer sockaddr :start offset :end (+ offset real-size)) (rawsock:send sock real-buffer :start offset :end (+ offset real-size))))) rv)) (defmethod socket-close ((usocket datagram-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 ;;; ;;; UDP/Datagram sockets (FFI version) ;;; #+(and ffi (not rawsock)) (progn ;; C primitive types (ffi:def-c-type socklen_t ffi:uint32) ;; C structures (ffi:def-c-struct sockaddr #+macos (sa_len ffi:uint8) (sa_family #-macos ffi:ushort #+macos ffi:uint8) (sa_data (ffi:c-array ffi:char 14))) (ffi:def-c-struct sockaddr_in #+macos (sin_len ffi:uint8) (sin_family #-macos ffi:short #+macos ffi:uint8) (sin_port #-macos ffi:ushort #+macos ffi:uint16) (sin_addr ffi:uint32) (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-pointer) (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 %send (:name "send") (:arguments (socket ffi:int) (buffer ffi:c-pointer) (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-pointer) (length ffi:int) (flags ffi:int) (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 #+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 %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) (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)) (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)) (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) (defconstant +socket-ip-proto-udp+ 17) (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") (defparameter *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 host))) (ffi:with-c-place (place sockaddr) #+macos (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*) (setf (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 &key (local-host *wildcard-host*) remote-host remote-port) (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+)) (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))))) (unless (plusp sock) (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno))) (unwind-protect (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr) *length-of-sockaddr_in*))) (unless (zerop rv) (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno))) (when rsock_addr (let ((rv (%connect sock (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr) *length-of-sockaddr_in*))) (unless (zerop rv) (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno)))))) (ffi:foreign-free lsock_addr) (when remote-host (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) (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)) (with-slots (recv-buffer socket) usocket (ffi:foreign-free recv-buffer) (zerop (%close socket)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (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 address address-length) (%recvfrom (socket usocket) (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)) (when (minusp n) (error "SOCKET-RECEIVE ERROR: ~A" (os:errno))) (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) (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)))) (ffi:foreign-free remote-address) (ffi:foreign-free remote-address-length)) (values buffer nbytes 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 size &key host port (offset 0)) (declare (type sequence buffer) (type (integer 0 *) size offset)) (let ((remote-address (when (and host port) (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port))) (send-buffer (ffi:allocate-deep 'ffi:uint8 (if (zerop offset) buffer (subseq buffer offset (+ offset size))) :count size :read-only t)) (real-size (min size +max-datagram-packet-size+)) (nbytes 0)) (unwind-protect (let ((n (if remote-address (%sendto (socket usocket) (ffi:foreign-address send-buffer) real-size 0 ; flags (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) *length-of-sockaddr_in*) (%send (socket usocket) (ffi:foreign-address send-buffer) real-size 0)))) (cond ((plusp n) (setq nbytes n)) ((zerop n) (setq nbytes n)) (t (error "SOCKET-SEND ERROR: ~A" (os:errno))))) (ffi:foreign-free send-buffer) (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: ~A" (os:errno)))) (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 usocket-0.8.3/backend/clozure.lisp000066400000000000000000000054771360013566400171630ustar00rootroot00000000000000;;;; See LICENSE for licensing information. ;;;; Functions for CCL 1.11 (IPv6) only, see openmcl.lisp for rest of functions. (in-package :usocket) #+ipv6 (defun socket-connect (host port &key (protocol :stream) element-type timeout deadline nodelay local-host local-port) (when (eq nodelay :if-supported) (setf nodelay t)) (with-mapped-conditions (nil host) (let* ((remote (when (and host port) (openmcl-socket:resolve-address :host (host-to-hostname host) :port port :socket-type protocol))) (local (when (and local-host local-port) (openmcl-socket:resolve-address :host (host-to-hostname local-host) :port local-port :socket-type protocol))) (mcl-sock (apply #'openmcl-socket:make-socket `(:type ,protocol ,@(when (or remote local) `(:address-family ,(openmcl-socket:socket-address-family (or remote local)))) ,@(when remote `(:remote-address ,remote)) ,@(when local `(:local-address ,local)) :format ,(to-format element-type protocol) :external-format ,ccl:*default-external-format* :deadline ,deadline :nodelay ,nodelay :connect-timeout ,timeout :input-timeout ,timeout)))) (ecase protocol (:stream (make-stream-socket :stream mcl-sock :socket mcl-sock)) (:datagram (make-datagram-socket mcl-sock :connected-p (and remote t))))))) #+ipv6 (defun socket-listen (host port &key (reuse-address nil reuse-address-supplied-p) (reuseaddress (when reuse-address-supplied-p reuse-address)) (backlog 5) (element-type 'character)) (let ((local-address (openmcl-socket:resolve-address :host (host-to-hostname host) :port port :connect :passive))) (with-mapped-conditions (nil host) (make-stream-server-socket (openmcl-socket:make-socket :connect :passive :address-family (openmcl-socket:socket-address-family local-address) :local-address local-address :reuse-address reuseaddress :backlog backlog :format (to-format element-type :stream)) :element-type element-type)))) #+ipv6 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (let* ((ccl-socket (socket usocket)) (socket-keys (ccl::socket-keys ccl-socket))) (with-mapped-conditions (usocket host) (if (and host port) (openmcl-socket:send-to ccl-socket buffer size :remote-host (host-to-hostname host) :remote-port port :offset offset) (openmcl-socket:send-to ccl-socket buffer size :remote-address (getf socket-keys :remote-address) :offset offset))))) usocket-0.8.3/backend/cmucl.lisp000066400000000000000000000264411360013566400165750ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) #+win32 (defun remap-for-win32 (z) (mapcar #'(lambda (x) (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) (cdr x))) z)) (defparameter +cmucl-error-map+ #+win32 (append (remap-for-win32 +unix-errno-condition-map+) (remap-for-win32 +unix-errno-error-map+)) #-win32 (append +unix-errno-condition-map+ +unix-errno-error-map+)) (defun cmucl-map-socket-error (err &key condition socket host-or-ip) (let ((usock-error (cdr (assoc err +cmucl-error-map+ :test #'member)))) (if usock-error (if (subtypep usock-error 'error) (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (cond ((subtypep usock-error 'ns-condition) (signal usock-error :socket socket :host-or-ip host-or-ip)) (t (signal usock-error :socket socket)))) (error 'unknown-error :socket socket :real-error condition)))) ;; CMUCL error handling is brain-dead: it doesn't preserve any ;; information other than the OS error string from which the ;; error can be determined. The OS error string isn't good enough ;; given that it may have been localized (l10n). ;; ;; The above applies to versions pre 19b; 19d and newer are expected to ;; contain even better error reporting. ;; ;; ;; Just catch the errors and encapsulate them in an unknown-error (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (typecase condition (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) :socket socket :condition condition :host-or-ip host-or-ip)))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) (local-host nil local-host-p) (local-port nil local-port-p) &aux (local-bind-p (fboundp 'ext::bind-inet-socket))) (when timeout (unsupported 'timeout 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when (and nodelay-specified (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (when (and local-host-p (not local-bind-p)) (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)")) (when (and local-port-p (not local-bind-p)) (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)")) (let ((socket)) (ecase protocol (:stream (setf socket (let ((args (list (host-to-hbo host) port protocol))) (when (and local-bind-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) (with-mapped-conditions (socket host) (apply #'ext:connect-to-inet-socket args)))) (if socket (let* ((stream (sys:make-fd-stream socket :input t :output t :element-type element-type :buffering :full)) ;;###FIXME the above line probably needs an :external-format (usocket (make-stream-socket :socket socket :stream stream))) usocket) (let ((err (unix:unix-errno))) (when err (cmucl-map-socket-error err))))) (:datagram (setf socket (if (and host port) (let ((args (list (host-to-hbo host) port protocol))) (when (and local-bind-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) (with-mapped-conditions (socket (or host local-host)) (apply #'ext:connect-to-inet-socket args))) (if (or local-host-p local-port-p) (with-mapped-conditions (socket (or host local-host)) (apply #'ext:create-inet-listener (nconc (list (or local-port 0) protocol) (when (and local-host-p (ip/= local-host *wildcard-host*)) (list :host (host-to-hbo local-host)))))) (with-mapped-conditions (socket (or host local-host)) (ext:create-inet-socket protocol))))) (if 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) (let ((err (unix:unix-errno))) (when err (cmucl-map-socket-error err)))))))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (server-sock (with-mapped-conditions (nil host) (apply #'ext:create-inet-listener (nconc (list port :stream :backlog backlog :reuse-address reuseaddress) (when (ip/= host *wildcard-host*) (list :host (host-to-hbo host)))))))) (make-stream-server-socket server-sock :element-type element-type))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (with-mapped-conditions (usocket) (let* ((sock (ext:accept-tcp-connection (socket usocket))) (stream (sys:make-fd-stream sock :input t :output t :element-type (or element-type (element-type usocket)) :buffering :full))) (make-stream-socket :socket sock :stream stream)))) ;; Sockets and socket streams are represented ;; by different objects. Be sure to close the ;; socket stream when closing a stream socket. (defmethod socket-close ((usocket stream-usocket)) "Close socket." (with-mapped-conditions (usocket) (close (socket-stream usocket)))) (defmethod socket-close ((usocket usocket)) "Close socket." (with-mapped-conditions (usocket) (ext:close-socket (socket usocket)))) (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-shutdown ((usocket usocket) direction) (with-mapped-conditions (usocket) (ext:inet-shutdown (socket usocket) (ecase direction (:input ext:shut-rd) (:output ext:shut-wr))))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0) &aux (real-buffer (if (zerop offset) buffer (subseq buffer offset (+ offset size))))) (with-mapped-conditions (usocket host) (if (and host port) (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port) #-unicode (unix:unix-send (socket usocket) real-buffer size 0) #+unicode (%unix-send (socket usocket) real-buffer size 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 (length buffer)))) (multiple-value-bind (nbytes remote-host remote-port) (with-mapped-conditions (usocket) (ext:inet-recvfrom (socket usocket) real-buffer real-length)) (values real-buffer nbytes remote-host remote-port)))) (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) (ext:get-socket-host-and-port (socket usocket)) (values (hbo-to-vector-quad address) port))) (defmethod get-peer-name ((usocket stream-usocket)) (multiple-value-bind (address port) (ext:get-peer-host-and-port (socket usocket)) (values (hbo-to-vector-quad address) port))) (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) (defmethod get-peer-address ((usocket stream-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)) (nth-value 1 (get-peer-name usocket))) (defun lookup-host-entry (host) (multiple-value-bind (entry errno) (ext:lookup-host-entry host) (if entry entry ;;###The constants below work on *most* OSes, but are defined as the ;; constants mentioned in C (let ((exception (second (assoc errno '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND (2 ns-no-recovery-error) ;; NO_DATA (3 ns-no-recovery-error) ;; NO_RECOVERY (4 ns-try-again-condition)))))) ;; TRY_AGAIN (when exception (error exception)))))) (defun get-host-by-address (address) (handler-case (ext:host-entry-name (lookup-host-entry (host-byte-order address))) (condition (condition) (handle-condition condition address)))) (defun get-hosts-by-name (name) (handler-case (mapcar #'hbo-to-vector-quad (ext:host-entry-addr-list (lookup-host-entry name))) (condition (condition) (handle-condition condition name)))) (defun get-host-name () (unix:unix-gethostname)) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (push (socket waiter) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) (setf (wait-list-%wait wait-list) (remove (socket waiter) (wait-list-%wait wait-list)))) (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (alien:with-alien ((rfds (alien:struct unix:fd-set))) (unix:fd-zero rfds) (dolist (socket (wait-list-%wait wait-list)) (unix:fd-set socket rfds)) (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) (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 ))))))) usocket-0.8.3/backend/ecl.lisp000066400000000000000000000120251360013566400162260ustar00rootroot00000000000000;;;; -*- Mode: Lisp -*- ;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only. ;;;; See LICENSE for licensing information. (in-package :usocket) #+(and ecl-bytecmp windows) (eval-when (:load-toplevel :execute) (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32")) #+(and ecl-bytecmp windows) (progn (ffi:def-function ("gethostname" c-gethostname) ((name (* :unsigned-char)) (len :int)) :returning :int :module "ws2_32") (defun get-host-name () "Returns the hostname" (ffi:with-foreign-object (name '(:array :unsigned-char 256)) (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) (ffi:convert-from-foreign-string name)))) (ffi:def-foreign-type ws-socket :unsigned-int) (ffi:def-foreign-type ws-dword :unsigned-long) (ffi:def-foreign-type ws-event :unsigned-int) (ffi:def-struct wsa-network-events (network-events :long) (error-code (:array :int 10))) (ffi:def-function ("WSACreateEvent" wsa-event-create) () :returning ws-event :module "ws2_32") (ffi:def-function ("WSACloseEvent" c-wsa-event-close) ((event-object ws-event)) :returning :int :module "ws2_32") (defun wsa-event-close (ws-event) (not (zerop (c-wsa-event-close ws-event)))) (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) ((socket ws-socket) (event-object ws-event) (network-events (* wsa-network-events))) :returning :int :module "ws2_32") (ffi:def-function ("WSAEventSelect" wsa-event-select) ((socket ws-socket) (event-object ws-event) (network-events :long)) :returning :int :module "ws2_32") (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) ((number-of-events ws-dword) (events (* ws-event)) (wait-all-p :int) (timeout ws-dword) (alertable-p :int)) :returning ws-dword :module "ws2_32") (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) (c-wsa-wait-for-multiple-events number-of-events events (if wait-all-p -1 0) timeout (if alertable-p -1 0))) (ffi:def-function ("ioctlsocket" wsa-ioctlsocket) ((socket ws-socket) (cmd :long) (argp (* :unsigned-long))) :returning :int :module "ws2_32") (ffi:def-function ("WSAGetLastError" wsa-get-last-error) () :returning :int :module "ws2_32") (defun maybe-wsa-error (rv &optional socket) (unless (zerop rv) (raise-usock-err (wsa-get-last-error) socket))) (defun bytes-available-for-read (socket) (ffi:with-foreign-object (int-ptr :unsigned-long) (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr) socket) (let ((int (ffi:deref-pointer int-ptr :unsigned-long))) (prog1 int (when (plusp int) (setf (state socket) :read)))))) (defun map-network-events (func network-events) (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events)) (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code))) (unless (zerop event-map) (dotimes (i fd-max-events) (unless (zerop (ldb (byte 1 i) event-map)) (funcall func (ffi:deref-array error-array '(:array :int 10) i))))))) (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) (if (%ready-p socket) (progn (setf (state socket) :READ)) (ffi:with-foreign-object (network-events 'wsa-network-events) (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events))) (if (zerop rv) (map-network-events #'(lambda (err-code) (if (zerop err-code) (progn (setf (state socket) :READ) (when (stream-server-usocket-p socket) (setf (%ready-p socket) t))) (raise-usock-err err-code socket))) network-events) (maybe-wsa-error rv socket))))))) (defun os-wait-list-%wait (wait-list) (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event)) (defun (setf os-wait-list-%wait) (value wait-list) (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value)) (defun free-wait-list (wl) (when (wait-list-p wl) (unless (null (wait-list-%wait wl)) (wsa-event-close (os-wait-list-%wait wl)) (ffi:free-foreign-object (wait-list-%wait wl)) (setf (wait-list-%wait wl) nil)))) (defun %setup-wait-list (wait-list) (setf (wait-list-%wait wait-list) (ffi:allocate-foreign-object 'ws-event)) (setf (os-wait-list-%wait wait-list) (wsa-event-create)) (ext:set-finalizer wait-list #'free-wait-list)) (defun os-socket-handle (usocket) (socket-handle usocket)) ) ; #+(and ecl-bytecmp windows) usocket-0.8.3/backend/genera.lisp000066400000000000000000000233241360013566400167300ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*- ;;;; See LICENSE for licensing information. (in-package :usocket) (defclass genera-socket () ((foreign-address :initform 0 :initarg :foreign-address :accessor gs-foreign-address) (foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port) (local-address :initform 0 :initarg :local-address :accessor gs-local-address) (local-port :initform 0 :initarg :local-port :accessor gs-local-port)) ) (defclass genera-stream-socket (genera-socket) ((stream :initform nil :initarg :stream :accessor gs-stream)) ) (defclass genera-stream-server-socket (genera-socket) ((backlog :initform nil :initarg :backlog :accessor gs-backlog) (element-type :initform nil :initarg :element-type :accessor gs-element-type) (pending-connections :initform nil :accessor gs-pending-connections)) ) (defclass genera-datagram-socket (genera-socket) ((connection :initform nil :initarg :connection :accessor gs-connection)) ) (defun host-to-host-object (host) (let ((host (host-to-hostname host))) (cond ((string-equal host "localhost") net:*local-host*) ((ip-address-string-p host) (let ((quad (dotted-quad-to-vector-quad host))) ;;---*** NOTE: This test is temporary until we have a loopback interface (if (= (aref quad 0) 127) net:*local-host* (net:parse-host (format nil "INTERNET|~A" host))))) (t (net:parse-host host))))) (defun element-type-to-format (element-type protocol) (cond ((null element-type) (ecase protocol (:stream :text) (:datagram :binary))) ((subtypep element-type 'character) :text) (t :binary))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) (typecase condition ;;---*** TODO: Add additional conditions as appropriate (sys:connection-refused (error 'connection-refused-error :socket socket)) ((or tcp::tcp-destination-unreachable-during-connection tcp::udp-destination-unreachable) (error 'host-unreachable-error :socket socket)) (sys:host-not-responding-during-connection (error 'timeout-error :socket socket)) (sys:unknown-host-name (error 'ns-host-not-found-error :host-or-ip host-or-ip)) (sys:network-error (error 'unknown-error :socket socket :real-error condition :errno -1)))) (defun socket-connect (host port &key (protocol :stream) element-type timeout deadline (nodelay nil nodelay-p) local-host local-port) (declare (ignore local-host)) (when deadline (unsupported 'deadline 'socket-connect)) (when (and nodelay-p (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (with-mapped-conditions (nil host) (ecase protocol (:stream (let* ((host-object (host-to-host-object host)) (format (element-type-to-format element-type protocol)) (characters (eq format :text)) (timeout (if timeout (* 60 timeout) tcp:*tcp-connect-timeout*)) (stream (tcp:open-tcp-stream host-object port local-port :characters characters :ascii-translation characters :timeout timeout)) (gs (make-instance 'genera-stream-socket :stream stream))) (setf (gs-foreign-address gs) (scl:send stream :foreign-address)) (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) (setf (gs-local-address gs) (scl:send stream :local-address)) (setf (gs-local-port gs) (scl:send stream :local-port)) (make-stream-socket :socket gs :stream stream))) (:datagram ;;---*** TODO (unsupported 'datagram 'socket-connect))))) (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) (socket-close (socket usocket)))) (defmethod socket-close ((socket genera-stream-socket)) (with-slots (stream) socket (when stream (scl:send (shiftf stream nil) :close nil)))) (defmethod socket-close ((socket genera-stream-server-socket)) (with-slots (local-port pending-connections) socket (when local-port (tcp:remove-tcp-port-listener local-port)) (dolist (tcb pending-connections) (tcp::reject-tcb tcb)))) (defmethod socket-close ((socket genera-datagram-socket)) (with-slots (connection) socket (when connection (scl:send (shiftf connection nil) :close nil)) ;;---*** TODO: listening? )) ;;; Cribbed from TCP::MAKE-TCB (defun gensym-tcp-port () (loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*last-gensym-port-number* do (cond ((loop for existing-tcb in tcp::*tcb-list* thereis (= number (tcp::tcb-local-port existing-tcb)))) ((and (<= #.(expt 2 10) number) (< number #.(expt 2 16))) (return number)) (t (setq tcp::*last-gensym-port-number* #.(expt 2 10)))))) (defun socket-listen (host port &key (reuse-address nil reuse-address-p) (reuseaddress nil reuseaddress-p) (backlog 5) (element-type 'character)) (let ((host-object (host-to-host-object host)) (port (if (zerop port) (gensym-tcp-port) port)) (reuse-address (cond (reuse-address-p reuse-address) (reuseaddress-p reuseaddress) (t nil)))) (when (<= port 1024) ;; Don't allow listening on "privileged" ports to mimic Unix/Linux semantics (error 'operation-not-permitted-error :socket nil)) (when (tcp:tcp-port-protocol-name port) ;; Can't replace a Genera server (error 'address-in-use-error :socket nil)) (when (tcp:tcp-port-listener port) (unless reuse-address (error 'address-in-use-error :socket nil))) (let ((gs (make-instance 'genera-stream-server-socket :backlog backlog :element-type element-type))) (setf (gs-local-address gs) (loop for (network address) in (scl:send host-object :network-addresses) when (typep network 'tcp:internet-network) return address)) (setf (gs-local-port gs) port) (flet ((add-to-queue (tcb) (cond ((and (not (zerop (gs-local-address gs))) (not (= (gs-local-address gs) (tcp::tcb-local-address tcb)))) ;; Reject if not destined for the proper address (tcp::reject-tcb tcb)) ((<= (length (gs-pending-connections gs)) (gs-backlog gs)) (tcp::accept-tcb tcb) (tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received) (setf (gs-pending-connections gs) (append (gs-pending-connections gs) (list tcb)))) (t ;; Reject if backlog is full (tcp::reject-tcb tcb))))) (tcp:add-tcp-port-listener port #'add-to-queue)) (make-stream-server-socket gs :element-type element-type)))) (defmethod socket-accept ((socket stream-server-usocket) &key element-type) (with-slots (pending-connections) (socket socket) (loop (process:process-block "Wait for connection" #'(lambda () (not (null pending-connections)))) (let ((tcb (pop pending-connections))) (when tcb (let* ((format (element-type-to-format (or element-type (element-type socket)) :stream)) (characters (eq format :text)) (stream (tcp::make-tcp-stream tcb :characters characters :ascii-translation characters)) (gs (make-instance 'genera-stream-socket :stream stream))) (setf (gs-foreign-address gs) (scl:send stream :foreign-address)) (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) (setf (gs-local-address gs) (scl:send stream :local-address)) (setf (gs-local-port gs) (scl:send stream :local-port)) (return (make-stream-socket :socket gs :stream stream)))))))) (defmethod get-local-address ((usocket usocket)) (hbo-to-vector-quad (gs-local-address (socket usocket)))) (defmethod get-peer-address ((usocket stream-usocket)) (hbo-to-vector-quad (gs-foreign-address (socket usocket)))) (defmethod get-local-port ((usocket usocket)) (gs-local-port (socket usocket))) (defmethod get-peer-port ((usocket stream-usocket)) (gs-foreign-port (socket 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)) ;;---*** TODO (unsupported 'datagram 'socket-send)) (defmethod socket-receive ((socket datagram-usocket) buffer length &key) ;;---*** TODO (unsupported 'datagram 'socket-receive)) (defun get-host-by-address (address) ) ;; TODO (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (let ((host-object (host-to-host-object name))) (loop for (network address) in (scl:send host-object :network-addresses) when (typep network 'tcp:internet-network) collect (hbo-to-vector-quad address))))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun %remove-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (process:process-block-with-timeout timeout "Wait for input" #'(lambda (wait-list) (let ((ready-sockets nil)) (dolist (waiter (wait-list-waiters wait-list) ready-sockets) (setf (state waiter) (cond ((stream-usocket-p waiter) (if (listen (socket-stream waiter)) :read nil)) ((datagram-usocket-p waiter) (let ((connection (gs-connection (socket waiter)))) (if (and connection (not (scl:send connection :connection-pending-p))) :read nil))) ((stream-server-usocket-p waiter) (if (gs-pending-connections (socket waiter)) :read nil)))) (when (not (null (state waiter))) (setf ready-sockets t))))) wait-list) wait-list)) usocket-0.8.3/backend/iolib.lisp000066400000000000000000000271241360013566400165670ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (defparameter *backend* :iolib) (eval-when (:load-toplevel :execute) (shadowing-import 'iolib/sockets:socket-option) (export 'socket-option)) (defparameter +iolib-error-map+ `((iolib/sockets:socket-address-in-use-error . address-in-use-error) (iolib/sockets:socket-address-family-not-supported-error . socket-type-not-supported-error) (iolib/sockets:socket-address-not-available-error . address-not-available-error) (iolib/sockets:socket-network-down-error . network-down-error) (iolib/sockets:socket-network-reset-error . network-reset-error) (iolib/sockets:socket-network-unreachable-error . network-unreachable-error) ;; (iolib/sockets:socket-no-network-error . ?) (iolib/sockets:socket-connection-aborted-error . connection-aborted-error) (iolib/sockets:socket-connection-reset-error . connection-reset-error) (iolib/sockets:socket-connection-refused-error . connection-refused-error) (iolib/sockets:socket-connection-timeout-error . timeout-error) ;; (iolib/sockets:socket-connection-in-progress-error . ?) (iolib/sockets:socket-endpoint-shutdown-error . network-down-error) (iolib/sockets:socket-no-buffer-space-error . no-buffers-error) (iolib/sockets:socket-host-down-error . host-down-error) (iolib/sockets:socket-host-unreachable-error . host-unreachable-error) ;; (iolib/sockets:socket-already-connected-error . ?) (iolib/sockets:socket-not-connected-error . connection-refused-error) (iolib/sockets:socket-option-not-supported-error . operation-not-permitted-error) (iolib/syscalls:eacces . operation-not-permitted-error) (iolib/sockets:socket-operation-not-supported-error . operation-not-supported-error) (iolib/sockets:unknown-protocol . protocol-not-supported-error) ;; (iolib/sockets:unknown-interface . ?) (iolib/sockets:unknown-service . protocol-not-supported-error) (iolib/sockets:socket-error . socket-error) ;; Nameservice errors (src/sockets/dns/conditions.lisp) (iolib/sockets:resolver-error . ns-error) (iolib/sockets:resolver-fail-error . ns-host-not-found-error) (iolib/sockets:resolver-again-error . ns-try-again-condition) (iolib/sockets:resolver-no-name-error . ns-no-recovery-error) (iolib/sockets:resolver-unknown-error . ns-unknown-error) )) ;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 addresses, ;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)). Here we do the ;; conversion. (defun iolib-vector-to-vector-quad (host) (etypecase host ((or (vector t 4) ; IPv4 (array (unsigned-byte 8) (4))) host) ((or (vector t 8) ; IPv6 (array (unsigned-byte 16) (8))) (loop with vector = (make-array 16 :element-type '(unsigned-byte 8)) for i below 16 by 2 for word = (aref host (/ i 2)) do (setf (aref vector i) (ldb (byte 8 8) word) (aref vector (1+ i)) (ldb (byte 8 0) word)) finally (return vector))))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (let* ((usock-error (cdr (assoc (type-of condition) +iolib-error-map+))) (usock-error (if (functionp usock-error) (funcall usock-error condition) usock-error))) (if usock-error (if (typep usock-error 'socket-error) (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (cond ((subtypep usock-error 'ns-condition) (signal usock-error :socket socket :host-or-ip host-or-ip)) (t (signal usock-error :socket socket)))) (error 'unknown-error :real-error condition :socket socket)))) (defun ipv6-address-p (host) (iolib/sockets:ipv6-address-p (iolib/sockets:ensure-hostname host))) (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) (declare (ignore element-type deadline nodelay)) (with-mapped-conditions (nil host) (let* ((remote (when (and host port) (iolib/sockets:ensure-hostname host))) (local (when (and local-host local-port) (iolib/sockets:ensure-hostname local-host))) (ipv6-p (or (and remote (ipv6-address-p remote) (and local (ipv6-address-p local))))) (socket (apply #'iolib/sockets:make-socket `(:type ,protocol :address-family :internet :ipv6 ,ipv6-p :connect ,(cond ((eq protocol :stream) :active) ((and host port) :active) (t :passive)) ,@(when local `(:local-host ,local :local-port ,local-port)) :nodelay nodelay)))) (when remote (apply #'iolib/sockets:connect `(,socket ,remote :port ,port ,@(when timeout `(:wait ,timeout)))) (unless (iolib/sockets:socket-connected-p socket) (close socket) (error 'iolib/sockets:socket-error))) (ecase protocol (:stream (make-stream-socket :stream socket :socket socket)) (:datagram (make-datagram-socket socket :connected-p (and remote t))))))) (defmethod socket-close ((usocket usocket)) (close (socket usocket))) (defmethod socket-shutdown ((usocket stream-usocket) direction) (with-mapped-conditions () (case direction (:input (iolib/sockets:shutdown (socket usocket) :read t)) (:output (iolib/sockets:shutdown (socket usocket) :write t)) (t ; :io by default (iolib/sockets:shutdown (socket usocket) :read t :write t))))) (defun socket-listen (host port &key reuseaddress reuse-address (backlog 5) (element-type 'character)) (declare (ignore element-type)) (with-mapped-conditions (nil host) (make-stream-server-socket (iolib/sockets:make-socket :connect :passive :address-family :internet :local-host (iolib/sockets:ensure-hostname host) :local-port port :backlog backlog :reuse-address (or reuse-address reuseaddress))))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (declare (ignore element-type)) (with-mapped-conditions (usocket) (let ((socket (iolib/sockets:accept-connection (socket usocket)))) (make-stream-socket :socket socket :stream socket)))) (defmethod get-local-address ((usocket usocket)) (iolib-vector-to-vector-quad (iolib/sockets:address-to-vector (iolib/sockets:local-host (socket usocket))))) (defmethod get-peer-address ((usocket stream-usocket)) (iolib-vector-to-vector-quad (iolib/sockets:address-to-vector (iolib/sockets:remote-host (socket usocket))))) (defmethod get-local-port ((usocket usocket)) (iolib/sockets:local-port (socket usocket))) (defmethod get-peer-port ((usocket stream-usocket)) (iolib/sockets:remote-port (socket 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)) (apply #'iolib/sockets:send-to `(,(socket usocket) ,buffer :start ,offset :end ,(+ offset size) ,@(when (and host port) `(:remote-host ,(iolib/sockets:ensure-hostname host) :remote-port ,port))))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key start end) (multiple-value-bind (buffer size host port) (iolib/sockets:receive-from (socket usocket) :buffer buffer :size length :start start :end end) (values buffer size (iolib-vector-to-vector-quad host) port))) (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (multiple-value-bind (address more-addresses) (iolib/sockets:lookup-hostname name :ipv6 iolib/sockets:*ipv6*) (mapcar #'(lambda (x) (iolib-vector-to-vector-quad (iolib/sockets:address-name x))) (cons address more-addresses))))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) nil)) ;; TODO (defvar *event-base* (make-instance 'iolib/multiplex:event-base)) (defun %setup-wait-list (wait-list) (setf (wait-list-%wait wait-list) (or *event-base* ;; iolib/multiplex:*default-multiplexer* is used here (make-instance 'iolib/multiplex:event-base)))) (defun make-usocket-read-handler (usocket disconnector) (lambda (fd event exception) (declare (ignore fd event exception)) (handler-case (if (eq (state usocket) :write) (setf (state usocket) :read-write) (setf (state usocket) :read)) (end-of-file () (funcall disconnector :close))))) (defun make-usocket-write-handler (usocket disconnector) (lambda (fd event exception) (declare (ignore fd event exception)) (handler-case (if (eq (state usocket) :read) (setf (state usocket) :read-write) (setf (state usocket) :write)) (end-of-file () (funcall disconnector :close)) (iolib/streams:hangup () (funcall disconnector :close))))) (defun make-usocket-error-handler (usocket disconnector) (lambda (fd event exception) (declare (ignore fd event exception)) (handler-case (setf (state usocket) nil) (end-of-file () (funcall disconnector :close)) (iolib/streams:hangup () (funcall disconnector :close))))) (defun make-usocket-disconnector (event-base usocket) (declare (ignore event-base)) (lambda (&rest events) (let ((socket (socket usocket))) ;; if were asked to close the socket, we do so here (when (member :close events) (close socket :abort t))))) (defun %add-waiter (wait-list waiter) (let ((event-base (wait-list-%wait wait-list)) (fd (iolib/sockets:socket-os-fd (socket waiter)))) ;; reset socket state (setf (state waiter) nil) ;; set read handler (unless (iolib/multiplex::fd-monitored-p event-base fd :read) (iolib/multiplex:set-io-handler event-base fd :read (make-usocket-read-handler waiter (make-usocket-disconnector event-base waiter)))) ;; set write handler #+ignore (unless (iolib/multiplex::fd-monitored-p event-base fd :write) (iolib/multiplex:set-io-handler event-base fd :write (make-usocket-write-handler waiter (make-usocket-disconnector event-base waiter)))) ;; set error handler (unless (iolib/multiplex::fd-has-error-handler-p event-base fd) (iolib/multiplex:set-error-handler event-base fd (make-usocket-error-handler waiter (make-usocket-disconnector event-base waiter)))))) (defun %remove-waiter (wait-list waiter) (let ((event-base (wait-list-%wait wait-list))) (iolib/multiplex:remove-fd-handlers event-base (iolib/sockets:socket-os-fd (socket waiter)) :read t :write nil :error t))) ;; NOTE: `wait-list-waiters` returns all usockets (defun wait-for-input-internal (wait-list &key timeout) (let ((event-base (wait-list-%wait wait-list))) (handler-case (iolib/multiplex:event-dispatch event-base :timeout timeout) (iolib/streams:hangup ()) (end-of-file ())) ;; close the event-base after use (unless (eq event-base *event-base*) (close event-base)))) usocket-0.8.3/backend/lispworks.lisp000066400000000000000000001177221360013566400175320ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (eval-when (:compile-toplevel :load-toplevel :execute) (require "comm") #+lispworks3 (error "LispWorks 3 is not supported")) ;;; --------------------------------------------------------------------------- ;;; Warn if multiprocessing is not running on Lispworks (defun check-for-multiprocessing-started (&optional errorp) (unless mp:*current-process* (funcall (if errorp 'error 'warn) "You must start multiprocessing on Lispworks by calling~ ~%~3t(~s)~ ~%for ~s function properly." 'mp:initialize-multiprocessing 'wait-for-input))) (eval-when (:load-toplevel :execute) (check-for-multiprocessing-started)) #+win32 (eval-when (:load-toplevel :execute) (fli:register-module "ws2_32")) (fli:define-foreign-function (get-host-name-internal "gethostname" :source) ((return-string (:reference-return (:ef-mb-string :limit 257))) (namelen :int)) :lambda-list (&aux (namelen 256) return-string) :result-type :int #+win32 :module #+win32 "ws2_32") (defun get-host-name () (multiple-value-bind (return-code name) (get-host-name-internal) (when (zerop return-code) name))) #+win32 (defun remap-maybe-for-win32 (z) (mapcar #'(lambda (x) (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) (cdr x))) z)) (defparameter +lispworks-error-map+ #+win32 (append (remap-maybe-for-win32 +unix-errno-condition-map+) (remap-maybe-for-win32 +unix-errno-error-map+)) #-win32 (append +unix-errno-condition-map+ +unix-errno-error-map+)) (defun raise-usock-err (errno socket &optional condition (host-or-ip nil)) (let ((usock-error (cdr (assoc errno +lispworks-error-map+ :test #'member)))) (if usock-error (if (subtypep usock-error 'error) (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (cond ((subtypep usock-error 'ns-condition) (signal usock-error :socket socket :host-or-ip host-or-ip)) (t (signal usock-error :socket socket)))) (error 'unknown-error :socket socket :real-error condition :errno errno)))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (typecase condition (condition (let ((errno #-win32 (lw:errno-value) #+win32 (wsa-get-last-error))) (unless (zerop errno) (raise-usock-err errno socket condition host-or-ip)))))) (defconstant *socket_sock_dgram* 2 "Connectionless, unreliable datagrams of fixed maximum length.") (defconstant *socket_ip_proto_udp* 17) (defconstant *sockopt_so_rcvtimeo* #-linux #x1006 #+linux 20 "Socket receive timeout") (defconstant *sockopt_so_sndtimeo* #-linux #x1007 #+linux 21 "Socket send timeout") (fli:define-c-struct timeval (tv-sec :long) (tv-usec :long)) ;;; ssize_t ;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags, ;;; struct sockaddr *restrict address, socklen_t *restrict address_len); (fli:define-foreign-function (%recvfrom "recvfrom" :source) ((socket :int) (buffer (:pointer (:unsigned :byte))) (length :int) (flags :int) (address (:pointer (:struct comm::sockaddr))) (address-len (:pointer :int))) :result-type :int #+win32 :module #+win32 "ws2_32") ;;; ssize_t ;;; sendto(int socket, const void *buffer, size_t length, int flags, ;;; const struct sockaddr *dest_addr, socklen_t dest_len); (fli:define-foreign-function (%sendto "sendto" :source) ((socket :int) (buffer (:pointer (:unsigned :byte))) (length :int) (flags :int) (address (:pointer (:struct comm::sockaddr))) (address-len :int)) :result-type :int #+win32 :module #+win32 "ws2_32") #-win32 (defun set-socket-receive-timeout (socket-fd seconds) "Set socket option: RCVTIMEO, argument seconds can be a float number" (declare (type integer socket-fd) (type number seconds)) (multiple-value-bind (sec usec) (truncate seconds) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) (fli:with-foreign-slots (tv-sec tv-usec) timeout (setf tv-sec sec tv-usec (truncate (* 1000000 usec))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) (fli:size-of '(:struct timeval)))) seconds))))) #-win32 (defun set-socket-send-timeout (socket-fd seconds) "Set socket option: SNDTIMEO, argument seconds can be a float number" (declare (type integer socket-fd) (type number seconds)) (multiple-value-bind (sec usec) (truncate seconds) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) (fli:with-foreign-slots (tv-sec tv-usec) timeout (setf tv-sec sec tv-usec (truncate (* 1000000 usec))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_sndtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) (fli:size-of '(:struct timeval)))) seconds))))) #+win32 (defun set-socket-receive-timeout (socket-fd seconds) "Set socket option: RCVTIMEO, argument seconds can be a float number. On win32, you must bind the socket before use this function." (declare (type integer socket-fd) (type number seconds)) (fli:with-dynamic-foreign-objects ((timeout :int)) (setf (fli:dereference timeout) (truncate (* 1000 seconds))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :char)) (fli:size-of :int))) seconds))) #+win32 (defun set-socket-send-timeout (socket-fd seconds) "Set socket option: SNDTIMEO, argument seconds can be a float number. On win32, you must bind the socket before use this function." (declare (type integer socket-fd) (type number seconds)) (fli:with-dynamic-foreign-objects ((timeout :int)) (setf (fli:dereference timeout) (truncate (* 1000 seconds))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_sndtimeo* (fli:copy-pointer timeout :type '(:pointer :char)) (fli:size-of :int))) seconds))) #-win32 (defun get-socket-receive-timeout (socket-fd) "Get socket option: RCVTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) (len :int)) (comm::getsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) len) (fli:with-foreign-slots (tv-sec tv-usec) timeout (float (+ tv-sec (/ tv-usec 1000000)))))) #-win32 (defun get-socket-send-timeout (socket-fd) "Get socket option: SNDTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) (len :int)) (comm::getsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_sndtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) len) (fli:with-foreign-slots (tv-sec tv-usec) timeout (float (+ tv-sec (/ tv-usec 1000000)))))) #+win32 (defun get-socket-receive-timeout (socket-fd) "Get socket option: RCVTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout :int) (len :int)) (comm::getsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) len) (float (/ (fli:dereference timeout) 1000)))) #+win32 (defun get-socket-send-timeout (socket-fd) "Get socket option: SNDTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout :int) (len :int)) (comm::getsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_sndtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) len) (float (/ (fli:dereference timeout) 1000)))) #+(or lispworks4 lispworks5.0) (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) (let ((server-addr (fli:allocate-dynamic-foreign-object :type '(:struct comm::sockaddr_in)))) (values (comm::initialize-sockaddr_in server-addr comm::*socket_af_inet* hostname service protocol) comm::*socket_af_inet* server-addr (fli:pointer-element-size server-addr))) #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1 (progn (when (stringp hostname) (setq hostname (comm:string-ip-address hostname)) (unless hostname (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address)))) (unless resolved-hostname (return-from initialize-dynamic-sockaddr :unknown-host)) (setq hostname resolved-hostname)))) (if (or (null hostname) (integerp hostname) (comm:ipv6-address-p hostname)) (let ((server-addr (fli:allocate-dynamic-foreign-object :type '(:struct comm::lw-sockaddr)))) (multiple-value-bind (error family) (comm::initialize-sockaddr_in server-addr hostname service protocol) (values error family server-addr (if (eql family comm::*socket_af_inet*) (fli:size-of '(:struct comm::sockaddr_in)) (fli:size-of '(:struct comm::sockaddr_in6)))))) :bad-host))) (defun open-udp-socket (&key local-address local-port read-timeout (address-family comm::*socket_af_inet*)) "Open a unconnected UDP socket. For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), for binding on random free unused port, set LOCAL-PORT to 0." ;; Note: move (ensure-sockets) here to make sure delivered applications ;; correctly have networking support initialized. ;; ;; Following words was from Martin Simmons, forwarded by Camille Troillard: ;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp ;; (it is too early and also unnecessary). ;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I ;; think open-udp-socket should probably do it too. Calling it more than once is ;; safe and it will be very fast after the first time. #+win32 (comm::ensure-sockets) (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*))) (if socket-fd (progn (when read-timeout (set-socket-receive-timeout socket-fd read-timeout)) (if local-port (fli:with-dynamic-foreign-objects () (multiple-value-bind (error local-address-family client-addr client-addr-length) (initialize-dynamic-sockaddr local-address local-port "udp") (if (or error (not (eql address-family local-address-family))) (progn (comm::close-socket socket-fd) (error "cannot resolve hostname ~S, service ~S: ~A" local-address local-port (or error "address family mismatch"))) (if (comm::bind socket-fd client-addr client-addr-length) ;; success, return socket fd socket-fd (progn (comm::close-socket socket-fd) (error "cannot bind")))))) socket-fd)) (error "cannot create socket")))) (defun connect-to-udp-server (hostname service &key local-address local-port read-timeout) "Something like CONNECT-TO-TCP-SERVER" (fli:with-dynamic-foreign-objects () (multiple-value-bind (error address-family server-addr server-addr-length) (initialize-dynamic-sockaddr hostname service "udp") (when error (error "cannot resolve hostname ~S, service ~S: ~A" hostname service error)) (let ((socket-fd (open-udp-socket :local-address local-address :local-port local-port :read-timeout read-timeout :address-family address-family))) (if socket-fd (if (comm::connect socket-fd server-addr server-addr-length) ;; success, return socket fd socket-fd ;; fail, close socket and return nil (progn (comm::close-socket socket-fd) (error "cannot connect"))) (error "cannot create socket")))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'base-char) timeout deadline (nodelay t) local-host local-port) ;; What's the meaning of this keyword? (when deadline (unimplemented 'deadline 'socket-connect)) #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5 (when timeout (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5")) #+lispworks4 (when local-host (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) #+lispworks4 (when local-port (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) (ecase protocol (:stream (let ((hostname (host-to-hostname host)) (stream)) (setq stream (with-mapped-conditions (nil host) (comm:open-tcp-stream hostname port :element-type element-type #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 #-(and lispworks4 (not lispworks4.4)) :timeout timeout #-lispworks4 #-lispworks4 #-lispworks4 #-lispworks4 :local-address (when local-host (host-to-hostname local-host)) :local-port local-port #-(or lispworks4 lispworks5.0) ; >= 5.1 #-(or lispworks4 lispworks5.0) :nodelay nodelay))) ;; Then handle `nodelay' separately for older versions <= 5.0 #+(or lispworks4 lispworks5.0) (when (and stream nodelay) (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) ;; 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) (with-mapped-conditions (nil host) (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 (nil local-host) (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)))) usocket)))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'base-char)) #+lispworks4.1 (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1") #+lispworks4.1 (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1") (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (comm::*use_so_reuseaddr* reuseaddress) (hostname (host-to-hostname host)) (socket-res-list (with-mapped-conditions (nil host) (multiple-value-list #-lispworks4.1 (comm::create-tcp-socket-for-service port :address hostname :backlog backlog) #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) (sock (if (not (or (second socket-res-list) (third socket-res-list))) (first socket-res-list) (when (eq (second socket-res-list) :bind) (error 'address-in-use-error))))) (make-stream-server-socket sock :element-type element-type))) ;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which ;; should NOT be applied on socket FDs who have already been called on W-F-I, ;; so we have to check the %READY-P slot to decide if this waiting is necessary, ;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (let* ((socket (with-mapped-conditions (usocket) #+win32 (if (%ready-p usocket) (comm::accept-connection-to-socket (socket usocket)) (comm::get-fd-from-socket (socket usocket))) #-win32 (comm::get-fd-from-socket (socket usocket)))) (stream (make-instance 'comm:socket-stream :socket socket :direction :io :element-type (or element-type (element-type usocket))))) #+win32 (when socket (setf (%ready-p usocket) nil)) (make-stream-socket :socket socket :stream stream))) ;; Sockets and their streams are different objects ;; close the stream in order to make sure buffers ;; are correctly flushed and the socket closed. (defmethod socket-close ((usocket stream-usocket)) "Close socket." (close (socket-stream usocket))) (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) (comm::close-socket (socket usocket)))) (defmethod socket-close :after ((socket datagram-usocket)) "Additional socket-close method for datagram-usocket" (setf (%open-p socket) nil)) (defconstant +shutdown-read+ 0) (defconstant +shutdown-write+ 1) (defconstant +shutdown-read-write+ 2) ;;; int ;;; shutdown(int socket, int what); (fli:define-foreign-function (%shutdown "shutdown" :source) ((socket :int) (what :int)) :result-type :int #+win32 :module #+win32 "ws2_32") (defmethod socket-shutdown ((usocket datagram-usocket) direction) (unless (member direction '(:input :output :io)) (error 'invalid-argument-error)) (let ((what (case direction (:input +shutdown-read+) (:output +shutdown-write+) (:io +shutdown-read-write+)))) (with-mapped-conditions (usocket) #-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+ (comm::shutdown (socket usocket) what) #+(or lispworks4 lispworks5 lispworks6) (= 0 (%shutdown (socket usocket) what))))) (defmethod socket-shutdown ((usocket stream-usocket) direction) (unless (member direction '(:input :output :io)) (error 'invalid-argument-error)) (with-mapped-conditions (usocket) #-(or lispworks4 lispworks5 lispworks6) (comm:socket-stream-shutdown (socket usocket) direction) #+(or lispworks4 lispworks5 lispworks6) (let ((what (case direction (:input +shutdown-read+) (:output +shutdown-write+) (:io +shutdown-read-write+)))) (= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what))))) (defmethod initialize-instance :after ((socket datagram-usocket) &key) (setf (slot-value socket 'send-buffer) (make-array +max-datagram-packet-size+ :element-type '(unsigned-byte 8) :allocation :static)) (setf (slot-value socket 'recv-buffer) (make-array +max-datagram-packet-size+ :element-type '(unsigned-byte 8) :allocation :static))) (defvar *length-of-sockaddr_in* (fli:size-of '(:struct comm::sockaddr_in))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0) &aux (socket-fd (socket usocket)) (message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together? "Send message to a socket, using sendto()/send()" (declare (type integer socket-fd) (type sequence buffer)) (when host (setq host (host-to-hostname host))) (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) (replace message buffer :start2 offset :end2 (+ offset size)) (let ((n (if (and host port) (fli:with-dynamic-foreign-objects () (multiple-value-bind (error family client-addr client-addr-length) (initialize-dynamic-sockaddr host port "udp") (declare (ignore family)) (when error (error "cannot resolve hostname ~S, port ~S: ~A" host port error)) (%sendto socket-fd ptr (min size +max-datagram-packet-size+) 0 (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) client-addr-length))) (comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0)))) (declare (type fixnum n)) (if (plusp n) n (let ((errno #-win32 (lw:errno-value) #+win32 (wsa-get-last-error))) (if (zerop errno) n (raise-usock-err errno socket-fd host))))))) (defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout (max-buffer-size +max-datagram-packet-size+)) "Receive message from socket, read-timeout is a float number in seconds. This function will return 4 values: 1. receive buffer 2. number of receive bytes 3. remote address 4. remote port" (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (unsigned-byte 32) ; host (unsigned-byte 16)) ; port (type sequence buffer)) (let ((socket-fd (socket socket)) (message (slot-value socket 'recv-buffer)) ; TODO: how multiple threads do this in parallel? (read-timeout timeout) old-timeout) (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)) (len :int #-(or lispworks4 lispworks5.0) ; <= 5.0 :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 (setf old-timeout (get-socket-receive-timeout socket-fd)) (set-socket-receive-timeout socket-fd read-timeout)) (let ((n (%recvfrom socket-fd ptr max-buffer-size 0 (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) len))) (declare (type fixnum n)) ;; restore old read timeout (when (and read-timeout (/= old-timeout read-timeout)) (set-socket-receive-timeout socket-fd old-timeout)) ;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT #+win32 (setf (%ready-p socket) nil) (if (plusp n) (values (if buffer (replace buffer message :end1 (min length max-buffer-size) :end2 (min n max-buffer-size)) (subseq message 0 (min n max-buffer-size))) (min n max-buffer-size) (comm::ntohl (fli:foreign-slot-value (fli:foreign-slot-value client-addr 'comm::sin_addr :object-type '(:struct comm::sockaddr_in) :type '(:struct comm::in_addr) :copy-foreign-object nil) 'comm::s_addr :object-type '(:struct comm::in_addr))) (comm::ntohs (fli:foreign-slot-value client-addr 'comm::sin_port :object-type '(:struct comm::sockaddr_in) :type '(:unsigned :short) :copy-foreign-object nil))) (let ((errno #-win32 (lw:errno-value) #+win32 (wsa-get-last-error))) (if (zerop errno) (values nil n 0 0) (raise-usock-err errno socket-fd))))))))) (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) (comm:get-socket-address (socket usocket)) (values (hbo-to-vector-quad address) port))) (defmethod get-peer-name ((usocket stream-usocket)) (multiple-value-bind (address port) (comm:get-socket-peer-address (socket usocket)) (values (hbo-to-vector-quad address) port))) (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) (defmethod get-peer-address ((usocket stream-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)) (nth-value 1 (get-peer-name usocket))) #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 (defun ipv6-address-p (hostname) (when (stringp hostname) (setq hostname (comm:string-ip-address hostname)) (unless hostname (let ((resolved-hostname (comm:get-host-entry hostname :fields '(:address)))) (unless resolved-hostname (return-from ipv6-address-p nil)) (setq hostname resolved-hostname)))) (comm:ipv6-address-p hostname)) (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))) (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (mapcar #'lw-hbo-to-vector-quad (comm:get-host-entry name :fields '(:addresses))))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) nil)) ;; TODO (defun os-socket-handle (usocket) (socket usocket)) (defun usocket-listen (usocket) (if (stream-usocket-p usocket) (when (listen (socket-stream usocket)) usocket) (when (comm::socket-listen (socket usocket)) usocket))) ;;; ;;; Non Windows implementation ;;; The Windows implementation needs to resort to the Windows API in order ;;; to achieve what we want (what we want is waiting without busy-looping) ;;; #-win32 (progn (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun %remove-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () ;; unfortunately, it's impossible to share code between ;; non-win32 and win32 platforms... ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? (dolist (x (wait-list-waiters wait-list)) (mp:notice-fd (os-socket-handle x))) (labels ((wait-function (socks) (let (rv) (dolist (x socks rv) (when (usocket-listen x) (setf (state x) :READ rv t)))))) (if timeout (mp:process-wait-with-timeout "Waiting for a socket to become active" (truncate timeout) #'wait-function (wait-list-waiters wait-list)) (mp:process-wait "Waiting for a socket to become active" #'wait-function (wait-list-waiters wait-list)))) (dolist (x (wait-list-waiters wait-list)) (mp:unnotice-fd (os-socket-handle x))) wait-list)) ) ; end of block ;;; ;;; The Windows side of the story ;;; We want to wait without busy looping ;;; This code only works in threads which don't have (hidden) ;;; windows which need to receive messages. There are workarounds in the Windows API ;;; but are those available to 'us'. ;;; #+win32 (progn ;; LispWorks doesn't provide an interface to wait for a socket ;; to become ready (under Win32, that is) meaning that we need ;; to resort to system calls to achieve the same thing. ;; Luckily, it provides us access to the raw socket handles (as we ;; wrote the code above. (defconstant fd-read 1) (defconstant fd-read-bit 0) (defconstant fd-write 2) (defconstant fd-write-bit 1) (defconstant fd-oob 4) (defconstant fd-oob-bit 2) (defconstant fd-accept 8) (defconstant fd-accept-bit 3) (defconstant fd-connect 16) (defconstant fd-connect-bit 4) (defconstant fd-close 32) (defconstant fd-close-bit 5) (defconstant fd-qos 64) (defconstant fd-qos-bit 6) (defconstant fd-group-qos 128) (defconstant fd-group-qos-bit 7) (defconstant fd-routing-interface 256) (defconstant fd-routing-interface-bit 8) (defconstant fd-address-list-change 512) (defconstant fd-address-list-change-bit 9) (defconstant fd-max-events 10) (defconstant fionread 1074030207) ;; Note: ;; ;; If special finalization has to occur for a given ;; system resource (handle), an associated object should ;; be created. A special cleanup action should be added ;; to the system and a special cleanup action should ;; be flagged on all objects created for resources like it ;; ;; We have 2 functions to do so: ;; * hcl:add-special-free-action (function-symbol) ;; * hcl:flag-special-free-action (object) ;; ;; Note that the special free action will be called on all ;; objects which have been flagged for special free, so be ;; sure to check for the right argument type! (fli:define-foreign-type ws-socket () '(:unsigned :int)) (fli:define-foreign-type win32-handle () '(:unsigned :int)) (fli:define-c-struct wsa-network-events (network-events :long) (error-code (:c-array :int 10))) (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source) () :lambda-list nil :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) ((event-object win32-handle)) :result-type :int :module "ws2_32") ;; not used (fli:define-foreign-function (wsa-reset-event "WSAResetEvent" :source) ((event-object win32-handle)) :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source) ((socket ws-socket) (event-object win32-handle) (network-events (:reference-return wsa-network-events))) :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source) ((socket ws-socket) (event-object win32-handle) (network-events :long)) :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source) () :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source) ((socket :long) (cmd :long) (argp (:ptr :long))) :result-type :int :module "ws2_32") ;; The Windows system ;; Now that we have access to the system calls, this is the plan: ;; 1. Receive a wait-list with associated sockets to wait for ;; 2. Add all those sockets to an event handle ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that) ;; 4. After listening, detect if there are errors ;; (this step is different from Unix, where we can have only one error) ;; 5. If so, raise one of them ;; 6. If not so, return the sockets which have input waiting for them (defun maybe-wsa-error (rv &optional socket) (unless (zerop rv) (raise-usock-err (wsa-get-last-error) socket))) (defun bytes-available-for-read (socket) (fli:with-dynamic-foreign-objects ((int-ptr :long)) (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) (if (= 0 rv) (fli:dereference int-ptr) 0)))) (defun socket-ready-p (socket) (if (typep socket 'stream-usocket) (< 0 (bytes-available-for-read socket)) (%ready-p socket))) (defun waiting-required (sockets) (notany #'socket-ready-p sockets)) (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) (system:wait-for-single-object (wait-list-%wait wait-list) "Waiting for socket activity" timeout)) (update-ready-and-state-slots wait-list)) (defun map-network-events (func network-events) (let ((event-map (fli:foreign-slot-value network-events 'network-events)) (error-array (fli:foreign-slot-pointer network-events 'error-code))) (unless (zerop event-map) (dotimes (i fd-max-events) (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? (funcall func (fli:foreign-aref error-array i))))))) (defun update-ready-and-state-slots (wait-list) (loop with sockets = (wait-list-waiters wait-list) for socket in sockets do (if (or (and (stream-usocket-p socket) (listen (socket-stream socket))) (%ready-p socket)) (setf (state socket) :READ) (multiple-value-bind (rv network-events) (wsa-enum-network-events (os-socket-handle socket) (wait-list-%wait wait-list) t) (if (zerop rv) (map-network-events #'(lambda (err-code) (if (zerop err-code) (setf (%ready-p socket) t (state socket) :READ) (raise-usock-err err-code socket))) network-events) (maybe-wsa-error rv socket)))))) ;; The wait-list part (defun free-wait-list (wl) (when (wait-list-p wl) (unless (null (wait-list-%wait wl)) (wsa-event-close (wait-list-%wait wl)) (setf (wait-list-%wait wl) nil)))) (eval-when (:load-toplevel :execute) (hcl:add-special-free-action 'free-wait-list)) (defun %setup-wait-list (wait-list) (hcl:flag-special-free-action wait-list) (setf (wait-list-%wait wait-list) (wsa-event-create))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter (stream-server-usocket (logior fd-connect fd-accept fd-close)) (stream-usocket (logior fd-connect fd-read fd-oob fd-close)) (datagram-usocket (logior fd-read))))) (maybe-wsa-error (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events) waiter))) (defun %remove-waiter (wait-list waiter) (maybe-wsa-error (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0) waiter)) ) ; end of WIN32-block (defun set-socket-reuse-address (socket-fd reuse-address-p) (declare (type integer socket-fd) (type boolean reuse-address-p)) (fli:with-dynamic-foreign-objects ((value :int)) (setf (fli:dereference value) (if reuse-address-p 1 0)) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* comm::*sockopt_so_reuseaddr* (fli:copy-pointer value :type '(:pointer :void)) (fli:size-of :int))) reuse-address-p))) (defun get-socket-reuse-address (socket-fd) (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((value :int) (len :int)) (if (zerop (comm::getsockopt socket-fd comm::*sockopt_sol_socket* comm::*sockopt_so_reuseaddr* (fli:copy-pointer value :type '(:pointer :void)) len)) (= 1 (fli:dereference value))))) usocket-0.8.3/backend/mcl.lisp000066400000000000000000000267321360013566400162500ustar00rootroot00000000000000;; MCL backend for USOCKET 0.4.1 ;; Terje Norderhaug , January 1, 2009 (in-package :usocket) (defun handle-condition (condition &optional socket (host-or-ip nil)) ; incomplete, needs to handle additional conditions (flet ((raise-error (&optional socket-condition host-or-ip) (if socket-condition (cond ((typep socket-condition ns-error) (error socket-condition :socket socket :host-or-ip host-or-ip)) (t (error socket-condition :socket socket))) (error 'unknown-error :socket socket :real-error condition)))) (typecase condition (ccl:host-stopped-responding (raise-error 'host-down-error host-or-ip)) (ccl:host-not-responding (raise-error 'host-unreachable-error host-or-ip)) (ccl:connection-reset (raise-error 'connection-reset-error)) (ccl:connection-timed-out (raise-error 'timeout-error)) (ccl:opentransport-protocol-error (raise-error 'protocol-not-supported-error)) (otherwise (raise-error condition host-or-ip))))) (defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay local-host local-port (protocol :stream)) (when (eq nodelay :if-supported) (setf nodelay t)) (ecase protocol (:stream (with-mapped-conditions (nil host) (let* ((socket (make-instance 'active-socket :remote-host (when host (host-to-hostname host)) :remote-port port :local-host (when local-host (host-to-hostname local-host)) :local-port local-port :deadline deadline :nodelay nodelay :connect-timeout (and timeout (round (* timeout 60))) :element-type element-type)) (stream (socket-open-stream socket))) (make-stream-socket :socket socket :stream stream)))) (:datagram (with-mapped-conditions (nil (or host local-host)) (make-datagram-socket (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host)) :local-port local-port)))))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (socket (with-mapped-conditions () (make-instance 'passive-socket :local-port port :local-host (host-to-hbo host) :reuse-address reuseaddress :backlog backlog)))) (make-stream-server-socket socket :element-type element-type))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (let* ((socket (socket usocket)) (stream (with-mapped-conditions (usocket) (socket-accept socket :element-type element-type)))) (make-stream-socket :socket socket :stream stream))) (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) (socket-close (socket usocket)))) (defmethod socket-shutdown ((usocket usocket) direction) (declare (ignore usocket direction)) ;; As far as I can tell there isn't a way to shutdown a socket in mcl. (unsupported "shutdown" 'socket-shutdown)) (defmethod ccl::stream-close ((usocket usocket)) (socket-close usocket)) (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (list (hbo-to-vector-quad (ccl::get-host-address (host-to-hostname name)))))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) (ccl::inet-host-name (host-to-hbo address)))) (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 get-local-address ((usocket usocket)) (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) "")))) (defmethod get-local-port ((usocket usocket)) (local-port (socket usocket))) (defmethod get-peer-address ((usocket stream-usocket)) (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket))))) (defmethod get-peer-port ((usocket stream-usocket)) (remote-port (socket usocket))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun %remove-waiter (wait-list waiter) (declare (ignore wait-list waiter))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; BASIC MCL SOCKET IMPLEMENTATION (defclass socket () ((local-port :reader local-port :initarg :local-port) (local-host :reader local-host :initarg :local-host) (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type))) (defclass active-socket (socket) ((remote-host :reader remote-host :initarg :remote-host) (remote-port :reader remote-port :initarg :remote-port) (deadline :initarg :deadline) (nodelay :initarg :nodelay) (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout :type (or null fixnum) :documentation "ticks (60th of a second)"))) (defmethod socket-open-stream ((socket active-socket)) (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket) :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte) :connect-timeout (connect-timeout socket))) (defmethod socket-close ((socket active-socket)) NIL) (defclass passive-socket (socket) ((streams :accessor socket-streams :type list :initform NIL :documentation "Circular list of streams with first element the next to open") (reuse-address :reader reuse-address :initarg :reuse-address) (lock :reader socket-lock :initform (ccl:make-lock "Socket")))) (defmethod initialize-instance :after ((socket passive-socket) &key backlog) (loop repeat backlog collect (socket-open-listener socket) into streams finally (setf (socket-streams socket) (cdr (rplacd (last streams) streams)))) (when (zerop (local-port socket)) (setf (slot-value socket 'local-port) (or (ccl::process-wait-with-timeout "binding port" (* 10 60) #'ccl::stream-local-port (car (socket-streams socket))) (error "timeout"))))) (defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket))) (flet ((connection-established-p (stream) (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) (let ((state (ccl::opentransport-stream-connection-state stream))) (not (eq :unbnd state)))))) (with-mapped-conditions () (ccl:with-lock-grabbed (lock nil "Socket Lock") (let ((connection (shiftf (car (socket-streams socket)) (socket-open-listener socket element-type)))) (pop (socket-streams socket)) (ccl:process-wait "Accepting" #'connection-established-p connection) connection))))) (defmethod socket-close ((socket passive-socket)) (loop with streams = (socket-streams socket) for (stream tail) on streams do (close stream :abort T) until (eq tail streams) finally (setf (socket-streams socket) NIL))) (defmethod socket-open-listener (socket &optional element-type) ; see http://code.google.com/p/mcl/issues/detail?id=28 (let* ((ccl::*passive-interface-address* (local-host socket)) (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress) :reuse-local-port-p (reuse-address socket) :element-type (if (subtypep (or element-type (element-type socket)) 'character) 'ccl::base-character 'unsigned-byte)))) (declare (special ccl::*passive-interface-address*)) new)) (defmethod input-available-p ((stream ccl::opentransport-stream)) (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body) "Evaluates the body if and only if the lock is successfully grabbed" ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock (let ((needs-unlocking-p (gensym)) (lock-var (gensym))) `(let* ((,lock-var ,lock) (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*)) (,needs-unlocking-p (needs-unlocking-p ,lock-var))) (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*)) (when ,needs-unlocking-p (,(if multiple-value-p 'multiple-value-prog1 'prog1) (progn ,@body) (ccl::%release-io-buffer-lock ,lock-var))))))) (labels ((needs-unlocking-p (lock) (declare (type ccl::lock lock)) ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line: (ccl::%io-buffer-lock-really-grabbed-p lock) (ccl:store-conditional lock nil ccl:*current-process*))) "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock" (let ((io-buffer (ccl::stream-io-buffer stream))) (or (not (eql 0 (ccl::io-buffer-incount io-buffer))) (ccl::io-buffer-untyi-char io-buffer) (locally (declare (optimize (speed 3) (safety 0))) (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer)) (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer)))))))) (defmethod connection-established-p ((stream ccl::opentransport-stream)) (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) (let ((state (ccl::opentransport-stream-connection-state stream))) (not (eq :unbnd state))))) (defun wait-for-input-internal (wait-list &key timeout &aux result) (labels ((ready-sockets (sockets) (dolist (sock sockets result) (when (cond ((stream-usocket-p sock) (input-available-p (socket-stream sock))) ((stream-server-usocket-p sock) (let ((ot-stream (first (socket-streams (socket sock))))) (or (input-available-p ot-stream) (connection-established-p ot-stream))))) (push sock result))))) (with-mapped-conditions () (ccl:process-wait-with-timeout "socket input" (when timeout (truncate (* timeout 60))) #'ready-sockets (wait-list-waiters wait-list))) (nreverse result))) ;;; datagram socket methods (defmethod initialize-instance :after ((usocket datagram-usocket) &key) (with-slots (socket send-buffer recv-buffer) usocket (setq send-buffer (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))) (setq recv-buffer (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (with-mapped-conditions (usocket host) (with-slots (socket send-buffer) usocket (unless (and host port) (unsupported 'host 'socket-send)) (ccl::send-message socket send-buffer buffer size host port offset)))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (with-mapped-conditions (usocket) (with-slots (socket recv-buffer) usocket (ccl::receive-message socket recv-buffer buffer length)))) (defmethod socket-close ((socket datagram-usocket)) nil) ; TODO usocket-0.8.3/backend/mezzano.lisp000066400000000000000000000071621360013566400171540ustar00rootroot00000000000000;;;; -*- Mode: Common-Lisp -*- ;;;; See LICENSE for licensing information. (in-package :usocket) (defun handle-condition (condition &optional (socket nil)) (typecase condition ;; TODO: Add additional conditions as appropriate (mezzano.network.tcp:connection-timed-out (error 'timeout-error :socket socket)))) (defun socket-connect (host port &key (protocol :stream) element-type timeout deadline (nodelay nil nodelay-p) local-host local-port) (declare (ignore local-host local-port)) (when deadline (unsupported 'deadline 'socket-connect)) (when (and nodelay-p (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (when timeout (unsupported 'timeout 'socket-connect)) (with-mapped-conditions () (ecase protocol (:stream (let ((s (mezzano.network.tcp:tcp-stream-connect host port :element-type element-type))) (make-stream-socket :socket s :stream s))) (:datagram ;; TODO: (unsupported 'datagram 'socket-connect))))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) (let ((ip (mezzano.network.ip:make-ipv4-address host))) (make-stream-server-socket (mezzano.network.tcp:tcp-listen ip port :backlog backlog) :element-type element-type))) (defun get-hosts-by-name (name) (declare (ignore name))) (defun get-host-by-address (address) (declare (ignore address))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun %remove-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun wait-for-input-internal (wait-list &key timeout) (declare (ignore wait-list timeout))) (defmethod socket-close ((usocket stream-usocket)) (with-mapped-conditions () (close (socket-stream usocket)))) (defmethod socket-close ((usocket stream-server-usocket)) (with-mapped-conditions () (mezzano.network.tcp:close-tcp-listener (socket usocket)))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (declare (ignore element-type)) (with-mapped-conditions (usocket) (let ((s (mezzano.network.tcp:tcp-accept (socket usocket)))) (make-stream-socket :socket s :stream s)))) (defmethod get-local-name ((usocket stream-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 get-local-address ((usocket stream-usocket)) (mezzano.network.ip:ipv4-address-to-string (mezzano.network.tcp:tcp-connection-local-ip (mezzano.network.tcp:tcp-stream-connection (socket usocket))))) (defmethod get-local-port ((usocket stream-usocket)) (mezzano.network.tcp:tcp-connection-local-port (mezzano.network.tcp:tcp-stream-connection (socket usocket)))) (defmethod get-peer-address ((usocket stream-usocket)) (mezzano.network.ip:ipv4-address-to-string (mezzano.network.tcp:tcp-connection-remote-ip (mezzano.network.tcp:tcp-stream-connection (socket usocket))))) (defmethod get-peer-port ((usocket stream-usocket)) (mezzano.network.tcp:tcp-connection-remote-port (mezzano.network.tcp:tcp-stream-connection (socket usocket)))) usocket-0.8.3/backend/mocl.lisp000066400000000000000000000125751360013566400164270ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (declare (ignore socket)) (signal condition)) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) (local-host nil local-host-p) (local-port nil local-port-p)) (when (and nodelay-specified (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when timeout (unimplemented 'timeout 'socket-connect)) (when local-host-p (unimplemented 'local-host 'socket-connect)) (when local-port-p (unimplemented 'local-port 'socket-connect)) (let (socket) (ecase protocol (:stream (setf socket (rt::socket-connect host port)) (let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character))))) (make-stream-socket :socket socket :stream stream))) (:datagram (error 'unsupported :feature '(protocol :datagram) :context 'socket-connect))))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (unimplemented 'socket-listen 'mocl)) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (unimplemented 'socket-accept 'mocl)) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the socket stream ;; when closing stream-sockets; it makes sure buffers ;; are flushed and the socket is closed correctly afterwards. (defmethod socket-close ((usocket usocket)) "Close socket." (rt::socket-shutdown usocket) (rt::c-fclose usocket)) (defmethod socket-close ((usocket stream-usocket)) "Close socket." (close (socket-stream usocket))) ;; (defmethod socket-close :after ((socket datagram-usocket)) ;; (setf (%open-p socket) nil)) (defmethod socket-shutdown ((usocket stream-usocket) direction) (declare (ignore usocket direction)) ;; sure would be nice if there was some documentation for mocl... (unimplemented "shutdown" 'socket-shutdown)) ;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port) ;; (let ((s (socket usocket)) ;; (host (if host (host-to-hbo host))) ;; (real-buffer (if (zerop offset) ;; buffer ;; (subseq buffer offset (+ offset size))))) ;; (multiple-value-bind (result errno) ;; (ext:inet-socket-send-to s real-buffer size ;; :remote-host host :remote-port port) ;; (or result ;; (mocl-map-socket-error errno :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 ;; (let ((s (socket socket))) ;; (let ((real-buffer (or buffer ;; (make-array length :element-type '(unsigned-byte 8)))) ;; (real-length (or length ;; (length buffer)))) ;; (multiple-value-bind (result errno remote-host remote-port) ;; (ext:inet-socket-receive-from s real-buffer real-length) ;; (if result ;; (values real-buffer result remote-host remote-port) ;; (mocl-map-socket-error errno :socket socket)))))) ;; (defmethod get-local-name ((usocket usocket)) ;; (multiple-value-bind (address port) ;; (with-mapped-conditions (usocket) ;; (ext:get-socket-host-and-port (socket usocket))) ;; (values (hbo-to-vector-quad address) port))) ;; (defmethod get-peer-name ((usocket stream-usocket)) ;; (multiple-value-bind (address port) ;; (with-mapped-conditions (usocket) ;; (ext:get-peer-host-and-port (socket usocket))) ;; (values (hbo-to-vector-quad address) port))) ;; (defmethod get-local-address ((usocket usocket)) ;; (nth-value 0 (get-local-name usocket))) ;; (defmethod get-peer-address ((usocket stream-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)) ;; (nth-value 1 (get-peer-name usocket))) ;; (defun get-host-by-address (address) ;; (multiple-value-bind (host errno) ;; (ext:lookup-host-entry (host-byte-order address)) ;; (cond (host ;; (ext:host-entry-name host)) ;; (t ;; (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) ;; (cond (condition ;; (error condition :host-or-ip address)) ;; (t ;; (error 'ns-unknown-error :host-or-ip address ;; :real-error errno)))))))) (defun get-hosts-by-name (name) (rt::lookup-host name)) ;; (defun get-host-name () ;; (unix:unix-gethostname)) ;; ;; ;; WAIT-LIST part ;; (defun %add-waiter (wl waiter) (declare (ignore wl waiter))) (defun %remove-waiter (wl waiter) (declare (ignore wl waiter))) (defun %setup-wait-list (wl) (declare (ignore wl))) (defun wait-for-input-internal (wait-list &key timeout) (unimplemented 'wait-for-input-internal 'mocl)) usocket-0.8.3/backend/openmcl.lisp000066400000000000000000000243731360013566400171310ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (defun get-host-name () (ccl::%stack-block ((resultbuf 256)) (when (zerop (#_gethostname resultbuf 256)) (ccl::%get-cstring resultbuf)))) (defparameter +openmcl-error-map+ '((:address-in-use . address-in-use-error) (:connection-aborted . connection-aborted-error) (:no-buffer-space . no-buffers-error) (:connection-timed-out . timeout-error) (:connection-refused . connection-refused-error) (:host-unreachable . host-unreachable-error) (:host-down . host-down-error) (:network-down . network-down-error) (:address-not-available . address-not-available-error) (:network-reset . network-reset-error) (:connection-reset . connection-reset-error) (:shutdown . shutdown-error) (:access-denied . operation-not-permitted-error))) (defparameter +openmcl-nameserver-error-map+ '((:no-recovery . ns-no-recovery-error) (:try-again . ns-try-again-condition) (:host-not-found . ns-host-not-found-error))) ;; we need something which the openmcl implementors 'forgot' to do: ;; wait for more than one socket-or-fd (defun input-available-p (sockets &optional ticks-to-wait) (ccl::rletz ((tv :timeval)) (ccl::ticks-to-timeval ticks-to-wait tv) ;;### The trickery below can be moved to the wait-list now... (ccl::%stack-block ((infds ccl::*fd-set-size*)) (ccl::fd-zero infds) (let ((max-fd -1)) (dolist (sock sockets) (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) (when fd ;; may be NIL if closed (setf max-fd (max max-fd fd)) (ccl::fd-set fd infds)))) (let ((res (#_select (1+ max-fd) infds (ccl::%null-ptr) (ccl::%null-ptr) (if ticks-to-wait tv (ccl::%null-ptr))))) (when (> res 0) (dolist (sock sockets) (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) (when (and fd (ccl::fd-is-set fd infds)) (setf (state sock) :READ))))) sockets))))) (defun raise-error-from-id (condition-id socket real-condition) (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) (if usock-err (error usock-err :socket socket) (error 'unknown-error :socket socket :real-error real-condition)))) (defun handle-condition (condition &optional socket (host-or-ip nil)) (typecase condition (openmcl-socket:socket-error (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) (ccl:input-timeout (error 'timeout-error :socket socket)) (ccl:communication-deadline-expired (error 'deadline-timeout-error :socket socket)) (ccl::socket-creation-error #| ugh! |# (let* ((condition-id (ccl::socket-creation-error-identifier condition)) (nameserver-error (cdr (assoc condition-id +openmcl-nameserver-error-map+)))) (if nameserver-error (if (typep nameserver-error 'serious-condition) (error nameserver-error :host-or-ip host-or-ip) (signal nameserver-error :host-or-ip host-or-ip)) (raise-error-from-id condition-id socket condition)))))) (defun to-format (element-type protocol) (cond ((null element-type) (ecase protocol ; default value of different protocol (:stream :text) (:datagram :binary))) ((subtypep element-type 'character) :text) (t :binary))) #-ipv6 (defun socket-connect (host port &key (protocol :stream) element-type timeout deadline nodelay local-host local-port) (when (eq nodelay :if-supported) (setf nodelay t)) (with-mapped-conditions (nil host) (ecase protocol (:stream (let ((mcl-sock (openmcl-socket:make-socket :remote-host (host-to-hostname host) :remote-port port :local-host local-host :local-port local-port :format (to-format element-type protocol) :external-format ccl:*default-external-format* :deadline deadline :nodelay nodelay :connect-timeout timeout))) (make-stream-socket :stream mcl-sock :socket mcl-sock))) (:datagram (let* ((mcl-sock (openmcl-socket:make-socket :address-family :internet :type :datagram :local-host local-host :local-port local-port :input-timeout timeout :format (to-format element-type protocol) :external-format ccl:*default-external-format*)) (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) usocket))))) #-ipv6 (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (real-host (host-to-hostname host)) (sock (with-mapped-conditions (nil host) (apply #'openmcl-socket:make-socket (append (list :connect :passive :reuse-address reuseaddress :local-port port :backlog backlog :format (to-format element-type :stream)) (unless (eq host *wildcard-host*) (list :local-host real-host))))))) (make-stream-server-socket sock :element-type element-type))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (declare (ignore element-type)) ;; openmcl streams are bi/multivalent (let ((sock (with-mapped-conditions (usocket) (openmcl-socket:accept-connection (socket usocket))))) (make-stream-socket :socket sock :stream sock))) ;; One close method is sufficient because sockets ;; and their associated objects are represented ;; by the same object. (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) (close (socket usocket)))) (defmethod socket-shutdown ((usocket usocket) direction) (with-mapped-conditions (usocket) (openmcl-socket:shutdown (socket usocket) :direction direction))) #-ipv6 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (with-mapped-conditions (usocket host) (if (and host port) (openmcl-socket:send-to (socket usocket) buffer size :remote-host (host-to-hbo host) :remote-port port :offset offset) ;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets, ;; so we have to define our own. (let* ((socket (socket usocket)) (fd (ccl::socket-device socket))) (multiple-value-setq (buffer offset) (ccl::verify-socket-buffer buffer offset size)) (ccl::%stack-block ((bufptr size)) (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size) (ccl::socket-call socket "send" (ccl::with-eagain fd :output (ccl::ignoring-eintr (ccl::check-socket-error (#_send fd bufptr size 0)))))))))) (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) (with-mapped-conditions (usocket) (openmcl-socket:receive-from (socket usocket) length :buffer buffer))) (defun usocket-host-address (address) (cond ((integerp address) (hbo-to-vector-quad address)) ((and (arrayp address) (= (length address) 16) (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff))) (make-array 4 :displaced-to address :displaced-index-offset 12)) (t address))) (defmethod get-local-address ((usocket usocket)) (usocket-host-address (openmcl-socket:local-host (socket usocket)))) (defmethod get-peer-address ((usocket stream-usocket)) (usocket-host-address (openmcl-socket:remote-host (socket usocket)))) (defmethod get-local-port ((usocket usocket)) (openmcl-socket:local-port (socket usocket))) (defmethod get-peer-port ((usocket stream-usocket)) (openmcl-socket:remote-port (socket 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))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) (defun get-hosts-by-name (name) (with-mapped-conditions (nil name) (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname (host-to-hostname name)))))) (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun %remove-waiter (wait-list waiter) (declare (ignore wait-list waiter))) (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))) (input-available-p (wait-list-waiters wait-list) (when timeout ticks-timeout)) wait-list))) ;;; Helper functions for option.lisp (defun get-socket-option-reuseaddr (socket) (ccl::int-getsockopt (ccl::socket-device socket) #$SOL_SOCKET #$SO_REUSEADDR)) (defun set-socket-option-reuseaddr (socket value) (ccl::int-setsockopt (ccl::socket-device socket) #$SOL_SOCKET #$SO_REUSEADDR value)) (defun get-socket-option-broadcast (socket) (ccl::int-getsockopt (ccl::socket-device socket) #$SOL_SOCKET #$SO_BROADCAST)) (defun set-socket-option-broadcast (socket value) (ccl::int-setsockopt (ccl::socket-device socket) #$SOL_SOCKET #$SO_BROADCAST value)) (defun get-socket-option-tcp-nodelay (socket) (ccl::int-getsockopt (ccl::socket-device socket) #$IPPROTO_TCP #$TCP_NODELAY)) (defun set-socket-option-tcp-nodelay (socket value) (ccl::int-setsockopt (ccl::socket-device socket) #$IPPROTO_TCP #$TCP_NODELAY value)) usocket-0.8.3/backend/sbcl.lisp000066400000000000000000001105011360013566400164040ustar00rootroot00000000000000;;;; -*- Mode: Common-Lisp -*- ;;;; See LICENSE for licensing information. (in-package :usocket) #+sbcl (progn #-win32 (defun get-host-name () (sb-unix:unix-gethostname)) ;; we assume winsock has already been loaded, after all, ;; we already loaded sb-bsd-sockets and sb-alien #+win32 (defun get-host-name () (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) (let ((result (sb-alien:alien-funcall (sb-alien:extern-alien "gethostname" (sb-alien:function sb-alien:int (* sb-alien:char) sb-alien:int)) (sb-alien:cast buf (* sb-alien:char)) 256))) (when (= result 0) (sb-alien:cast buf sb-alien:c-string)))))) #+(and ecl (not ecl-bytecmp)) (progn #-:wsock (ffi:clines "#include " "#include " "#include ") #+:wsock (ffi:clines "#ifndef FD_SETSIZE" "#define FD_SETSIZE 1024" "#endif" "#include ") (ffi:clines #+:msvc "#include " #-:msvc "#include " "#include ") #| #+:prefixed-api (ffi:clines "#define CONS(x, y) ecl_cons((x), (y))" "#define MAKE_INTEGER(x) ecl_make_integer((x))") #-:prefixed-api (ffi:clines "#define CONS(x, y) make_cons((x), (y))" "#define MAKE_INTEGER(x) make_integer((x))") |# (defun cerrno () (ffi:c-inline () () :int "errno" :one-liner t)) (defun fd-setsize () (ffi:c-inline () () :fixnum "FD_SETSIZE" :one-liner t)) (defun fdset-alloc () (ffi:c-inline () () :pointer-void "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t)) (defun fdset-zero (fdset) (ffi:c-inline (fdset) (:pointer-void) :void "FD_ZERO((fd_set*)#0)" :one-liner t)) (defun fdset-set (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void "FD_SET(#1,(fd_set*)#0)" :one-liner t)) (defun fdset-clr (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void "FD_CLR(#1,(fd_set*)#0)" :one-liner t)) (defun fdset-fd-isset (fdset fd) (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool "FD_ISSET(#1,(fd_set*)#0)" :one-liner t)) (declaim (inline cerrno fd-setsize fdset-alloc fdset-zero fdset-set fdset-clr fdset-fd-isset)) (defun get-host-name () (ffi:c-inline () () :object "{ char *buf = (char *) ecl_alloc_atomic(257); if (gethostname(buf,256) == 0) @(return) = make_simple_base_string(buf); else @(return) = Cnil; }" :one-liner nil :side-effects nil)) (defun read-select (wl to-secs &optional (to-musecs 0)) (let* ((sockets (wait-list-waiters wl)) (rfds (wait-list-%wait wl)) (max-fd (reduce #'(lambda (x y) (let ((sy (sb-bsd-sockets:socket-file-descriptor (socket y)))) (if (< x sy) sy x))) (cdr sockets) :initial-value (sb-bsd-sockets:socket-file-descriptor (socket (car sockets)))))) (fdset-zero rfds) (dolist (sock sockets) (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor (socket sock)))) (let ((count (ffi:c-inline (to-secs to-musecs rfds max-fd) (t :unsigned-int :pointer-void :int) :int " int count; struct timeval tv; struct timeval tvs; struct timeval tve; unsigned long elapsed; unsigned long remaining; int retval = -1; if (#0 != Cnil) { tv.tv_sec = fixnnint(#0); tv.tv_usec = #1; } remaining = ((tv.tv_sec*1000000) + tv.tv_usec); do { (void)gettimeofday(&tvs, NULL); // start time retval = select(#3 + 1, (fd_set*)#2, NULL, NULL, (#0 != Cnil) ? &tv : NULL); if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) { (void)gettimeofday(&tve, NULL); // end time elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec); remaining = remaining - elapsed; if ( remaining < 0 ) { // already past timeout, just exit retval = 0; break; } tv.tv_sec = remaining / 1000000; tv.tv_usec = remaining - (tv.tv_sec * 1000000); } } while ((retval < 0) && (errno == EINTR)); @(return) = retval; " :one-liner nil))) (cond ((= 0 count) (values nil nil)) ((< count 0) ;; check for EAGAIN; these should not err (values nil (cerrno))) (t (dolist (sock sockets) (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor (socket sock))) (setf (state sock) :READ)))))))) ) ; progn (defun map-socket-error (sock-err) (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) (defparameter +sbcl-condition-map+ '((interrupted-error . interrupted-condition))) (defparameter +sbcl-error-map+ `((sb-bsd-sockets:address-in-use-error . address-in-use-error) (sb-bsd-sockets::no-address-error . address-not-available-error) (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error) (sb-bsd-sockets:connection-refused-error . connection-refused-error) (sb-bsd-sockets:invalid-argument-error . invalid-argument-error) (sb-bsd-sockets:no-buffers-error . no-buffers-error) (sb-bsd-sockets:operation-not-supported-error . operation-not-supported-error) (sb-bsd-sockets:operation-not-permitted-error . operation-not-permitted-error) (sb-bsd-sockets:protocol-not-supported-error . protocol-not-supported-error) #-(or ecl clasp) (sb-bsd-sockets:unknown-protocol . protocol-not-supported-error) (sb-bsd-sockets:socket-type-not-supported-error . socket-type-not-supported-error) (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) (sb-bsd-sockets:operation-timeout-error . timeout-error) #-(or ecl clasp) (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 #-(or ecl clasp) (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) #-(or ecl clasp) (sb-bsd-sockets:try-again-error . ns-try-again-condition) #-(or ecl clasp) (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) ;; this function servers as a general template for other backends (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (typecase condition (serious-condition (let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+))) (usock-error (if (functionp usock-error) (funcall usock-error condition) usock-error))) (declare (type symbol usock-error)) (if usock-error (cond ((subtypep usock-error 'ns-error) (error usock-error :socket socket :host-or-ip host-or-ip)) (t (error usock-error :socket socket))) (error 'unknown-error :real-error condition :socket socket)))) (condition (let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+))) (usock-cond (if (functionp usock-cond) (funcall usock-cond condition) usock-cond))) (if usock-cond (cond ((subtypep usock-cond 'ns-condition) (signal usock-cond :socket socket :host-or-ip host-or-ip)) (t (signal usock-cond :socket socket))) (signal 'unknown-condition :real-condition condition :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 #+(and sbcl (not win32)) (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 () ,@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 get-hosts-by-name (name) (with-mapped-conditions (nil name) (multiple-value-bind (host4 host6) (sb-bsd-sockets:get-host-by-name name) (let ((addr4 (when host4 (sb-bsd-sockets::host-ent-addresses host4))) (addr6 (when host6 (sb-bsd-sockets::host-ent-addresses host6)))) (append addr4 addr6))))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port &aux (sockopt-tcp-nodelay-p (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))) (when deadline (unsupported 'deadline 'socket-connect)) #+(or ecl clasp) (when timeout (unsupported 'timeout 'socket-connect)) (when (and nodelay-specified ;; 20080802: ECL added this function to its sockets ;; package today. There's no guarantee the functions ;; we need are available, but we can make sure not to ;; call them if they aren't (not (eq nodelay :if-supported)) (not sockopt-tcp-nodelay-p)) (unsupported 'nodelay 'socket-connect)) (when (eq nodelay :if-supported) (setf nodelay t)) (let* ((remote (when host (car (get-hosts-by-name (host-to-hostname host))))) (local (when local-host (car (get-hosts-by-name (host-to-hostname local-host))))) (ipv6 (or (and remote (= 16 (length remote))) (and local (= 16 (length local))))) (socket (make-instance #+sbcl (if ipv6 'sb-bsd-sockets::inet6-socket 'sb-bsd-sockets:inet-socket) #+(or ecl clasp) 'sb-bsd-sockets:inet-socket :type protocol :protocol (case protocol (:stream :tcp) (:datagram :udp)))) 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 (if ipv6 (or local (ipv6-host-to-vector "::0")) (or local (host-to-vector-quad *wildcard-host*))) (or local-port *auto-port*))) (with-mapped-conditions (usocket host) #+(and sbcl (not win32)) (labels ((connect () (sb-bsd-sockets:socket-connect socket remote port))) (if timeout (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) (connect))) #+(or ecl clasp (and sbcl win32)) (sb-bsd-sockets:socket-connect socket remote 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 :element-type element-type ;; Robert Brown said on Aug 4, 2011: ;; ... This means that SBCL streams created by usocket have a true ;; serve-events property. When writing large amounts of data to several ;; streams, the kernel will eventually stop accepting data from SBCL. ;; When this happens, SBCL either waits for I/O to be possible on ;; the file descriptor it's writing to or queues the data to be flushed later. ;; Because usocket streams specify serve-events as true, SBCL ;; always queues. Instead, it should wait for I/O to be available and ;; write the remaining data to the socket. That's what serve-events ;; equal to NIL gets you. ;; ;; Nikodemus Siivola said on Aug 8, 2011: ;; It's set to T for purely historical reasons, and will soon change to ;; NIL in SBCL. (The docstring has warned of T being a temporary default ;; for as long as the :SERVE-EVENTS keyword argument has existed.) :serve-events nil)))) (:datagram (when (or local-host local-port) (sb-bsd-sockets:socket-bind socket (if ipv6 (or local (ipv6-host-to-vector "::0")) (or local (host-to-vector-quad *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 remote 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 (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (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*))) local (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any)) #+(or ecl clasp) (host-to-vector-quad host)) (sock (make-instance #+sbcl (if ipv6 'sb-bsd-sockets::inet6-socket 'sb-bsd-sockets:inet-socket) #+(or ecl clasp) 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (handler-case (with-mapped-conditions (nil host) (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress) (sb-bsd-sockets:socket-bind sock ip port) (sb-bsd-sockets:socket-listen sock backlog) (make-stream-server-socket sock :element-type element-type)) (t (c) ;; Make sure we don't leak filedescriptors (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 ((usocket stream-server-usocket) &key element-type) (with-mapped-conditions (usocket) (let ((socket (sb-bsd-sockets:socket-accept (socket usocket)))) (when socket (prog1 (make-stream-socket :socket socket :stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :full :element-type (or element-type (element-type usocket)))) ;; 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 usocket) nil)))))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the stream (which ;; closes the socket too) when closing a stream-socket. (defmethod socket-close ((usocket usocket)) (with-mapped-conditions (usocket) (sb-bsd-sockets:socket-close (socket usocket)))) (defmethod socket-close ((usocket stream-usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket)))) #+sbcl (defmethod socket-shutdown ((usocket stream-usocket) direction) (with-mapped-conditions (usocket) (sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction))) #+ecl (defmethod socket-shutdown ((usocket stream-usocket) direction) (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket))) (direction-flag (ecase direction (:input 0) (:output 1)))) (unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int "shutdown(#0, #1)" :one-liner t)) (error (map-errno-error (cerrno)))))) #+clasp (defmethod socket-shutdown ((usocket stream-usocket) direction) (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket))) (direction-flag (ecase direction (:input 0) (:output 1)))) (unless (zerop (sockets-internal:shutdown sock-fd direction-flag)) (error (map-errno-error (cerrno)))))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (let ((remote (when host (car (get-hosts-by-name (host-to-hostname host)))))) (with-mapped-conditions (usocket host) (let* ((s (socket usocket)) (dest (if (and host port) (list remote port) nil)) (real-buffer (if (zerop offset) buffer (subseq buffer offset (+ offset size))))) (sb-bsd-sockets:socket-send s real-buffer size :address dest))))) (defmethod socket-receive ((usocket 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 (unsigned-byte 16))) ; port (with-mapped-conditions (usocket) (let ((s (socket usocket))) (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) (defmethod get-local-name ((usocket usocket)) (sb-bsd-sockets:socket-name (socket usocket))) (defmethod get-peer-name ((usocket stream-usocket)) (sb-bsd-sockets:socket-peername (socket usocket))) (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) (defmethod get-peer-address ((usocket stream-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)) (nth-value 1 (get-peer-name usocket))) (defun get-host-by-address (address) (with-mapped-conditions (nil address) (sb-bsd-sockets::host-ent-name (sb-bsd-sockets:get-host-by-address address)))) #+(and sbcl (not win32)) (progn (defun %setup-wait-list (wait-list) (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) (push (socket waiter) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) (setf (wait-list-%wait wait-list) (remove (socket waiter) (wait-list-%wait wait-list)))) (defun wait-for-input-internal (sockets &key timeout) (with-mapped-conditions () (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) (sb-unix:fd-zero rfds) (dolist (socket (wait-list-%wait sockets)) (sb-unix:fd-set (sb-bsd-sockets:socket-file-descriptor socket) rfds)) (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) (let* ((wait-list (wait-list-%wait sockets)) count err) (if (null wait-list) (setq count 0) ;; no need to call (multiple-value-setq (count err) (sb-unix:unix-fast-select ;; "invalid number of arguments: 0" if wait-list is null. (1+ (reduce #'max wait-list :key #'sb-bsd-sockets:socket-file-descriptor)) (sb-alien:addr rfds) nil nil (when timeout secs) (when timeout musecs)))) (if (null count) ; something wrong in #'sb-unix:unix-fast-select (unless (= err sb-unix:eintr) (error (map-errno-error err))) (when (< 0 count) ; do nothing if count = 0 ;; process the result... (dolist (x (wait-list-waiters sockets)) (when (sb-unix:fd-isset (sb-bsd-sockets:socket-file-descriptor (socket x)) rfds) (setf (state x) :READ)))))))))) ) ; progn ;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe)) ;;; Based on LispWorks version written by Erik Huelsmann. #+win32 ; shared by ECL and SBCL (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +wsa-wait-failed+ #xffffffff) (defconstant +wsa-infinite+ #xffffffff) (defconstant +wsa-wait-event-0+ 0) (defconstant +wsa-wait-timeout+ 258)) #+win32 ; shared by ECL and SBCL (progn (defconstant fd-read 1) (defconstant fd-read-bit 0) (defconstant fd-write 2) (defconstant fd-write-bit 1) (defconstant fd-oob 4) (defconstant fd-oob-bit 2) (defconstant fd-accept 8) (defconstant fd-accept-bit 3) (defconstant fd-connect 16) (defconstant fd-connect-bit 4) (defconstant fd-close 32) (defconstant fd-close-bit 5) (defconstant fd-qos 64) (defconstant fd-qos-bit 6) (defconstant fd-group-qos 128) (defconstant fd-group-qos-bit 7) (defconstant fd-routing-interface 256) (defconstant fd-routing-interface-bit 8) (defconstant fd-address-list-change 512) (defconstant fd-address-list-change-bit 9) (defconstant fd-max-events 10) (defconstant fionread 1074030207) ;; Note: for ECL, socket-handle will return raw Windows Handle, ;; while SBCL returns OSF Handle instead. (defun socket-handle (usocket) (sb-bsd-sockets:socket-file-descriptor (socket usocket))) (defun socket-ready-p (socket) (if (typep socket 'stream-usocket) (plusp (bytes-available-for-read socket)) (%ready-p socket))) (defun waiting-required (sockets) (notany #'socket-ready-p sockets)) (defun raise-usock-err (errno &optional socket) (error 'unknown-error :socket socket :real-error errno)) (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) nil (if timeout (truncate (* 1000 timeout)) +wsa-infinite+) nil))) (ecase rv ((#.+wsa-wait-event-0+) (update-ready-and-state-slots wait-list)) ((#.+wsa-wait-timeout+)) ; do nothing here ((#.+wsa-wait-failed+) (maybe-wsa-error rv)))))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter (stream-server-usocket (logior fd-connect fd-accept fd-close)) (stream-usocket (logior fd-read)) (datagram-usocket (logior fd-read))))) (maybe-wsa-error (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events) waiter))) (defun %remove-waiter (wait-list waiter) (maybe-wsa-error (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0) waiter)) ) ; progn #+(and sbcl win32) (progn ;; "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) (sb-alien:define-alien-type nil (sb-alien:struct wsa-network-events (network-events sb-alien:long) (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create) ws-event) ; return type only (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close) (boolean #.sb-vm::n-machine-word-bits) (event-object ws-event)) ;; not used (sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event) (boolean #.sb-vm::n-machine-word-bits) (event-object ws-event)) (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events) sb-alien:int (socket ws-socket) (event-object ws-event) (network-events (* (sb-alien:struct wsa-network-events)))) (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) sb-alien:int (socket ws-socket) (event-object ws-event) (network-events sb-alien:long)) (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events) ws-dword (number-of-events ws-dword) (events (* ws-event)) (wait-all-p (boolean #.sb-vm::n-machine-word-bits)) (timeout ws-dword) (alertable-p (boolean #.sb-vm::n-machine-word-bits))) (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket) sb-alien:int (socket ws-socket) (cmd sb-alien:long) (argp (* sb-alien:unsigned-long))) (defun maybe-wsa-error (rv &optional socket) (unless (zerop rv) (raise-usock-err (sockint::wsa-get-last-error) socket))) (defun os-socket-handle (usocket) (sb-bsd-sockets:socket-file-descriptor (socket usocket))) (defun bytes-available-for-read (socket) (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long)) (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr)) socket) (prog1 int-ptr (when (plusp int-ptr) (setf (state socket) :read))))) (defun map-network-events (func network-events) (let ((event-map (sb-alien:slot network-events 'network-events)) (error-array (sb-alien:slot network-events 'error-code))) (unless (zerop event-map) (dotimes (i fd-max-events) (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? (funcall func (sb-alien:deref error-array i))))))) (defun update-ready-and-state-slots (wait-list) (loop with sockets = (wait-list-waiters wait-list) for socket in sockets do (if (%ready-p socket) (progn (setf (state socket) :READ)) (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events))) (let ((rv (wsa-enum-network-events (os-socket-handle socket) (os-wait-list-%wait wait-list) (sb-alien:addr network-events)))) (if (zerop rv) (map-network-events #'(lambda (err-code) (if (zerop err-code) (progn (setf (state socket) :READ) (when (stream-server-usocket-p socket) (setf (%ready-p socket) t))) (raise-usock-err err-code socket))) network-events) (maybe-wsa-error rv socket))))))) (defun os-wait-list-%wait (wait-list) (sb-alien:deref (wait-list-%wait wait-list))) (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 (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)))))) ) ; progn #+(and (or ecl clasp) (not win32)) (progn (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () (multiple-value-bind (secs usecs) (split-timeout (or timeout 1)) (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))))))) (defun %setup-wait-list (wl) (setf (wait-list-%wait wl) (fdset-alloc))) (defun %add-waiter (wl w) (declare (ignore wl w))) (defun %remove-waiter (wl w) (declare (ignore wl w))) ) ; progn #+(and (or ecl clasp) win32 (not ecl-bytecmp)) (progn (defun maybe-wsa-error (rv &optional syscall) (unless (zerop rv) (sb-bsd-sockets::socket-error syscall))) (defun %setup-wait-list (wl) (setf (wait-list-%wait wl) (ffi:c-inline () () :int "WSAEVENT event; event = WSACreateEvent(); @(return) = event;"))) (defun %add-waiter (wait-list waiter) (let ((events (etypecase waiter (stream-server-usocket (logior fd-connect fd-accept fd-close)) (stream-usocket (logior fd-read)) (datagram-usocket (logior fd-read))))) (maybe-wsa-error (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events) (:fixnum :fixnum :fixnum) :fixnum "int result; result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2); @(return) = result;") '%add-waiter))) (defun %remove-waiter (wait-list waiter) (maybe-wsa-error (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list)) (:fixnum :fixnum) :fixnum "int result; result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L); @(return) = result;") '%remove-waiter)) ;; TODO: how to handle error (result) in this call? (declaim (inline %bytes-available-for-read)) (defun %bytes-available-for-read (socket) (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum "u_long nbytes; int result; nbytes = 0L; result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes); @(return) = nbytes;")) (defun bytes-available-for-read (socket) (let ((nbytes (%bytes-available-for-read socket))) (when (plusp nbytes) (setf (state socket) :read)) nbytes)) (defun update-ready-and-state-slots (wait-list) (loop with sockets = (wait-list-waiters wait-list) for socket in sockets do (if (%ready-p socket) (setf (state socket) :READ) (let ((events (etypecase socket (stream-server-usocket (logior fd-connect fd-accept fd-close)) (stream-usocket (logior fd-read)) (datagram-usocket (logior fd-read))))) ;; TODO: check the iErrorCode array (multiple-value-bind (valid-p ready-p) (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) (values :bool :bool) ;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list) "WSANETWORKEVENTS network_events; int i, result; result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events); if (!result) { @(return 0) = Ct; @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil; } else { @(return 0) = Cnil; @(return 1) = Cnil; }") (if valid-p (when ready-p (setf (state socket) :READ) (when (stream-server-usocket-p socket) (setf (%ready-p socket) t))) (sb-bsd-sockets::socket-error 'update-ready-and-state-slots))))))) (defun wait-for-input-internal (wait-list &key timeout) (when (waiting-required (wait-list-waiters wait-list)) (let ((rv (ffi:c-inline ((wait-list-%wait wait-list) (if timeout (truncate (* 1000 timeout)) +wsa-infinite+)) (:fixnum :fixnum) :fixnum "DWORD result; WSAEVENT events[1]; events[0] = (WSAEVENT)#0; result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL); @(return) = result;"))) (ecase rv ((#.+wsa-wait-event-0+) (update-ready-and-state-slots (wait-list-waiters wait-list))) ((#.+wsa-wait-timeout+)) ; do nothing here ((#.+wsa-wait-failed+) (sb-bsd-sockets::socket-error 'wait-for-input-internal)))))) ) ; progn usocket-0.8.3/backend/scl.lisp000066400000000000000000000234511360013566400162510ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (defparameter +scl-error-map+ (append +unix-errno-condition-map+ +unix-errno-error-map+)) (defun scl-map-socket-error (err &key condition socket) (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) (cond (usock-err (if (subtypep usock-err 'error) (error usock-err :socket socket) (signal usock-err :socket socket))) (t (error 'unknown-error :socket socket :real-error condition))))) (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) "Dispatch correct usocket condition." (typecase condition (ext::socket-error (scl-map-socket-error (ext::socket-errno condition) :socket socket :condition condition)))) (defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) (local-host nil local-host-p) (local-port nil local-port-p) &aux (patch-udp-p (fboundp 'ext::inet-socket-send-to))) (when (and nodelay-specified (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect)) (when deadline (unsupported 'deadline 'socket-connect)) (when timeout (unsupported 'timeout 'socket-connect)) (when (and local-host-p (not patch-udp-p)) (unsupported 'local-host 'socket-connect :minimum "1.3.9")) (when (and local-port-p (not patch-udp-p)) (unsupported 'local-port 'socket-connect :minimum "1.3.9")) (let ((socket)) (ecase protocol (:stream (setf socket (let ((args (list (host-to-hbo host) port :kind protocol))) (when (and patch-udp-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) (with-mapped-conditions (socket) (apply #'ext:connect-to-inet-socket args)))) (let ((stream (sys:make-fd-stream socket :input t :output t :element-type element-type :buffering :full))) (make-stream-socket :socket socket :stream stream))) (:datagram (when (not patch-udp-p) (error 'unsupported :feature '(protocol :datagram) :context 'socket-connect :minumum "1.3.9")) (setf socket (if (and host port) (let ((args (list (host-to-hbo host) port :kind protocol))) (when (and patch-udp-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) (with-mapped-conditions (socket) (apply #'ext:connect-to-inet-socket args))) (if (or local-host-p local-port-p) (with-mapped-conditions () (ext:create-inet-listener (or local-port 0) protocol :host (when local-host (if (ip= local-host *wildcard-host*) 0 (host-to-hbo local-host))))) (with-mapped-conditions () (ext:create-inet-socket protocol))))) (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) (ext:finalize usocket #'(lambda () (when (%open-p usocket) (ext:close-socket socket)))) usocket))))) (defun socket-listen (host port &key reuseaddress (reuse-address nil reuse-address-supplied-p) (backlog 5) (element-type 'character)) (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (host (if (ip= host *wildcard-host*) 0 (host-to-hbo host))) (server-sock (with-mapped-conditions () (ext:create-inet-listener port :stream :host host :reuse-address reuseaddress :backlog backlog)))) (make-stream-server-socket server-sock :element-type element-type))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (with-mapped-conditions (usocket) (let* ((sock (ext:accept-tcp-connection (socket usocket))) (stream (sys:make-fd-stream sock :input t :output t :element-type (or element-type (element-type usocket)) :buffering :full))) (make-stream-socket :socket sock :stream stream)))) ;; Sockets and their associated streams are modelled as ;; different objects. Be sure to close the socket stream ;; when closing stream-sockets; it makes sure buffers ;; are flushed and the socket is closed correctly afterwards. (defmethod socket-close ((usocket usocket)) "Close socket." (with-mapped-conditions (usocket) (ext:close-socket (socket usocket)))) (defmethod socket-close ((usocket stream-usocket)) "Close socket." (with-mapped-conditions (usocket) (close (socket-stream usocket)))) (defmethod socket-close :after ((socket datagram-usocket)) (setf (%open-p socket) nil)) (defmethod socket-shutdown ((usocket usocket) direction) (declare (ignore usocket direction)) (unsupported "shutdown" 'socket-shutdown)) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port) (let ((s (socket usocket)) (host (if host (host-to-hbo host))) (real-buffer (if (zerop offset) buffer (subseq buffer offset (+ offset size))))) (multiple-value-bind (result errno) (ext:inet-socket-send-to s real-buffer size :remote-host host :remote-port port) (or result (scl-map-socket-error errno :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 (let ((s (socket socket))) (let ((real-buffer (or buffer (make-array length :element-type '(unsigned-byte 8)))) (real-length (or length (length buffer)))) (multiple-value-bind (result errno remote-host remote-port) (ext:inet-socket-receive-from s real-buffer real-length) (if result (values real-buffer result remote-host remote-port) (scl-map-socket-error errno :socket socket)))))) (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) (with-mapped-conditions (usocket) (ext:get-socket-host-and-port (socket usocket))) (values (hbo-to-vector-quad address) port))) (defmethod get-peer-name ((usocket stream-usocket)) (multiple-value-bind (address port) (with-mapped-conditions (usocket) (ext:get-peer-host-and-port (socket usocket))) (values (hbo-to-vector-quad address) port))) (defmethod get-local-address ((usocket usocket)) (nth-value 0 (get-local-name usocket))) (defmethod get-peer-address ((usocket stream-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)) (nth-value 1 (get-peer-name usocket))) (defun get-host-by-address (address) (multiple-value-bind (host errno) (ext:lookup-host-entry (host-byte-order address)) (cond (host (ext:host-entry-name host)) (t (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) (cond (condition (error condition :host-or-ip address)) (t (error 'ns-unknown-error :host-or-ip address :real-error errno)))))))) (defun get-hosts-by-name (name) (multiple-value-bind (host errno) (ext:lookup-host-entry name) (cond (host (mapcar #'hbo-to-vector-quad (ext:host-entry-addr-list host))) (t (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) (cond (condition (error condition :host-or-ip name)) (t (error 'ns-unknown-error :host-or-ip name :real-error errno)))))))) (defun get-host-name () (unix:unix-gethostname)) ;; ;; ;; WAIT-LIST part ;; (defun %add-waiter (wl waiter) (declare (ignore wl waiter))) (defun %remove-waiter (wl waiter) (declare (ignore wl waiter))) (defun %setup-wait-list (wl) (declare (ignore wl))) (defun wait-for-input-internal (wait-list &key timeout) (let* ((sockets (wait-list-waiters wait-list)) (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes)) (nfds (length sockets)) (bytes (* nfds pollfd-size))) (alien:with-bytes (fds-sap bytes) (do ((sockets sockets (rest sockets)) (base 0 (+ base 8))) ((endp sockets)) (let ((fd (socket (first sockets)))) (setf (sys:sap-ref-32 fds-sap base) fd) (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin))) (multiple-value-bind (result errno) (let ((thread:*thread-whostate* "Poll wait") (timeout (if timeout (truncate (* timeout 1000)) -1))) (declare (inline unix:unix-poll)) (unix:unix-poll (alien:sap-alien fds-sap (* (alien:struct unix::pollfd))) nfds timeout)) (cond ((not result) (error "~@" (unix:get-unix-error-msg errno))) (t (do ((sockets sockets (rest sockets)) (base 0 (+ base 8))) ((endp sockets)) (let ((flags (sys:sap-ref-16 fds-sap (+ base 6)))) (unless (zerop (logand flags unix::pollin)) (setf (state (first sockets)) :READ)))))))))) usocket-0.8.3/condition.lisp000066400000000000000000000206331360013566400160660ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- ;;;; See LICENSE for licensing information. (in-package :usocket) ;; Condition signalled by operations with unsupported arguments ;; For trivial-sockets compatibility. (define-condition insufficient-implementation (error) ((feature :initarg :feature :reader feature) (context :initarg :context :reader context :documentation "String designator of the public API function which the feature belongs to.")) (:documentation "The ancestor of all errors usocket may generate because of insufficient support from the underlying implementation with respect to the arguments given to `function'. One call may signal several errors, if the caller allows processing to continue. ")) (define-condition unsupported (insufficient-implementation) ((minimum :initarg :minimum :reader minimum :documentation "Indicates the minimal version of the implementation required to support the requested feature.")) (:report (lambda (c stream) (format stream "~A in ~A is unsupported." (feature c) (context c)) (when (minimum c) (format stream " Minimum version (~A) is required." (minimum c))))) (:documentation "Signalled when the underlying implementation doesn't allow supporting the requested feature. When you see this error, go bug your vendor/implementation developer!")) (define-condition unimplemented (insufficient-implementation) () (:report (lambda (c stream) (format stream "~A in ~A is unimplemented." (feature c) (context c)))) (:documentation "Signalled if a certain feature might be implemented, based on the features of the underlying implementation, but hasn't been implemented yet.")) ;; Conditions raised by sockets operations (define-condition socket-condition (condition) ((socket :initarg :socket :accessor usocket-socket)) ;;###FIXME: no slots (yet); should at least be the affected usocket... (:documentation "Parent condition for all socket related conditions.")) (define-condition socket-error (socket-condition error) () ;; no slots (yet) (:documentation "Parent error for all socket related errors")) (define-condition ns-condition (condition) ((host-or-ip :initarg :host-or-ip :accessor host-or-ip)) (:documentation "Parent condition for all name resolution conditions.")) (define-condition ns-error (ns-condition error) () (:documentation "Parent error for all name resolution errors.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defun define-usocket-condition-class (class &rest parents) `(progn (define-condition ,class ,parents ()) (eval-when (:load-toplevel :execute) (export ',class))))) (defmacro define-usocket-condition-classes (class-list parents) `(progn ,@(mapcar #'(lambda (x) (apply #'define-usocket-condition-class x parents)) class-list))) ;; Mass define and export our conditions (define-usocket-condition-classes (interrupted-condition) (socket-condition)) (define-condition unknown-condition (socket-condition) ((real-condition :initarg :real-condition :accessor usocket-real-condition)) (:documentation "Condition raised when there's no other - more applicable - condition available.")) ;; Mass define and export our errors (define-usocket-condition-classes (address-in-use-error address-not-available-error bad-file-descriptor-error connection-refused-error connection-aborted-error connection-reset-error invalid-argument-error no-buffers-error operation-not-supported-error operation-not-permitted-error protocol-not-supported-error socket-type-not-supported-error network-unreachable-error network-down-error network-reset-error host-down-error host-unreachable-error shutdown-error timeout-error deadline-timeout-error invalid-socket-error invalid-socket-stream-error) (socket-error)) (define-condition unknown-error (socket-error) ((real-error :initarg :real-error :accessor usocket-real-error :initform nil) (errno :initarg :errno :reader usocket-errno :initform 0)) (:report (lambda (c stream) (typecase c (simple-condition (format stream (simple-condition-format-control (usocket-real-error c)) (simple-condition-format-arguments (usocket-real-error c)))) (otherwise (format stream "The condition ~A occurred with errno: ~D." (usocket-real-error c) (usocket-errno c)))))) (:documentation "Error raised when there's no other - more applicable - error available.")) (define-usocket-condition-classes (ns-try-again-condition) (ns-condition)) (define-condition ns-unknown-condition (ns-condition) ((real-condition :initarg :real-condition :accessor ns-real-condition :initform nil)) (:documentation "Condition raised when there's no other - more applicable - condition available.")) (define-usocket-condition-classes ;; the no-data error code in the Unix 98 api ;; isn't really an error: there's just no data to return. ;; with lisp, we just return NIL (indicating no data) instead of ;; raising an exception... (ns-host-not-found-error ns-no-recovery-error) (ns-error)) (define-condition ns-unknown-error (ns-error) ((real-error :initarg :real-error :accessor ns-real-error :initform nil)) (:report (lambda (c stream) (typecase c (simple-condition (format stream (simple-condition-format-control (usocket-real-error c)) (simple-condition-format-arguments (usocket-real-error c)))) (otherwise (format stream "The condition ~A occurred." (usocket-real-error c)))))) (:documentation "Error raised when there's no other - more applicable - error available.")) (defmacro with-mapped-conditions ((&optional socket host-or-ip) &body body) `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket ,host-or-ip)))) ,@body)) (defparameter +unix-errno-condition-map+ `(((11) . ns-try-again-condition) ;; EAGAIN ((35) . ns-try-again-condition) ;; EDEADLCK ((4) . interrupted-condition))) ;; EINTR (defparameter +unix-errno-error-map+ ;;### the first column is for non-(linux or srv4) systems ;; the second for linux ;; the third for srv4 ;;###FIXME: How do I determine on which Unix we're running ;; (at least in clisp and sbcl; I know about cmucl...) ;; The table below works under the assumption we'll *only* see ;; socket associated errors... `(((48 98) . address-in-use-error) ((49 99) . address-not-available-error) ((9) . bad-file-descriptor-error) ((61 111) . connection-refused-error) ((54 104) . connection-reset-error) ((53 103) . connection-aborted-error) ((22) . invalid-argument-error) ((55 105) . no-buffers-error) ((12) . out-of-memory-error) ((45 95) . operation-not-supported-error) ((1) . operation-not-permitted-error) ((43 92) . protocol-not-supported-error) ((44 93) . socket-type-not-supported-error) ((51 101) . network-unreachable-error) ((50 100) . network-down-error) ((52 102) . network-reset-error) ((58 108) . already-shutdown-error) ((60 110) . timeout-error) ((64 112) . host-down-error) ((65 113) . host-unreachable-error))) (defun map-errno-condition (errno) (cdr (assoc errno +unix-errno-error-map+ :test #'member))) (defun map-errno-error (errno) (cdr (assoc errno +unix-errno-error-map+ :test #'member))) (defparameter +unix-ns-error-map+ `((1 . ns-host-not-found-error) (2 . ns-try-again-condition) (3 . ns-no-recovery-error))) (defmacro unsupported (feature context &key minimum) `(cerror "Ignore it and continue" 'unsupported :feature ,feature :context ,context :minimum ,minimum)) (defmacro unimplemented (feature context) `(signal 'unimplemented :feature ,feature :context ,context)) ;;; People may want to ignore all unsupported warnings, here it is. (defmacro ignore-unsupported-warnings (&body body) `(handler-bind ((unsupported #'(lambda (c) (declare (ignore c)) (continue)))) (progn ,@body))) usocket-0.8.3/doc/000077500000000000000000000000001360013566400137505ustar00rootroot00000000000000usocket-0.8.3/doc/intro.dita000066400000000000000000000004631360013566400157510ustar00rootroot00000000000000 Introduction Chun Tian

usocket-0.8.3/doc/reference.dita000066400000000000000000000006001360013566400165450ustar00rootroot00000000000000 API References Chun Tian

usocket-0.8.3/doc/usocket.ditamap000066400000000000000000000007351360013566400167730ustar00rootroot00000000000000 USOCKET Manual API References usocket-0.8.3/notes/000077500000000000000000000000001360013566400143335ustar00rootroot00000000000000usocket-0.8.3/notes/abcl-socket.txt000066400000000000000000000006221360013566400172630ustar00rootroot00000000000000 ABCL provides a callback interface to java objects, next to these calls: - ext:make-socket - ext:socket-close - ext:make-server-socket - ext:socket-accept - ext:get-socket-stream (returning an io-stream) abcl-swank (see SLIME) shows how to call directly into java. See for the sockets implementation: - src/org/armedbear/lisp * socket.lisp * socket_stream.java * SocketStream.java usocket-0.8.3/notes/active-sockets-apis.txt000066400000000000000000000022661360013566400207600ustar00rootroot00000000000000 -*- text -*- A document to summarizing which API's of the different implementations are associated with 'Step 1'. Interface to be implemented in step 1: - socket-connect - socket-close - get-host-by-address - get-hosts-by-name (and something to do with errors; maybe move this to step 1a?) SBCL ==== sockets: - socket-bind - make-instance 'inet-socket - socket-make-stream - socket-connect (ip vector-quad) port - socket-close DNS name resolution: - get-host-by-name - get-host-by-address - ::host-ent-addresses - host-ent-name CMUCL ===== sockets: - ext:connect-to-inet-socket (ip integer) port - sys:make-fd-stream - ext:close-socket DNS name resolution: - ext:host-entry-name - ext::lookup-host-entry - ext:host-entry-addr-list - ext:lookup-host-entry ABCL ==== sockets - ext:socket-connect (hostname string) port - ext:get-socket-stream - ext:socket-close clisp ===== sockets - socket-connect port (hostname string) - close (socket) Allegro ======= sockets - make-socket - socket-connect - close DNS resolution - lookup-hostname - ipaddr-to-hostname usocket-0.8.3/notes/address-apis.txt000066400000000000000000000032301360013566400174510ustar00rootroot00000000000000 -*- text -*- Step 2 of the master plan: Implementing (get-local-address sock) and (get-peer-address sock). Step 2 is about implementing: (get-local-address sock) -> ip (get-peer-address sock) -> ip (get-local-port sock) -> port (get-peer-port sock) -> port (get-local-name sock) -> ip, port (get-peer-name sock) -> ip, port ABCL ==== FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local) FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer) (see SLIME / swank-abcl.lisp for an example on how to do that) Allegro ======= (values (socket:remote-host sock) (socket:remote-port)) -> 32bit ip, port (values (socket:local-host sock) (socket:local-port sock)) -> 32bit ip, port CLISP ===== (socket:socket-stream-local sock nil) -> address (as dotted quad), port (socket:socket-stream-peer sock nil) -> address (as dotted quad), port CMUCL ===== (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer) (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local) LispWorks ========= (comm:socket-stream-address sock-stream) -> 32-bit-addr, port or: (comm:get-socket-address sock) -> 32-bit-addr, port (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port OpenMCL ======= (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port SBCL ==== (sb-bsd-sockets:socket-name sock) -> vector-quad, port (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port usocket-0.8.3/notes/allegro-socket.txt000066400000000000000000000026361360013566400200160ustar00rootroot00000000000000 (require :sock) accept-connection (sock passive-socket) &key wait Generic function. dotted-to-ipaddr dotted &key errorp Function. ipaddr-to-dotted ipaddr &key values Function. ipaddr-to-hostname ipaddr Function. lookup-hostname hostname lookup-port portname protocol Function. make-socket &key type format address-family connect &allow-other-keys Function. with-pending-connect &body body Macro. receive-from (sock datagram-socket) size &key buffer extract Generic function. send-to sock &key shutdown sock &key direction socket-control stream &key output-chunking output-chunking-eof input-chunking socket-os-fd sock Generic function. remote-host socket Generic function. local-host socket Generic function. local-port socket remote-filename socket local-filename socket remote-port socket socket-address-family socket socket-connect socket socket-format socket socket-type socket errors :address-in-use Local socket address already in use :address-not-available Local socket address not available :network-down Network is down :network-reset Network has been reset :connection-aborted Connection aborted :connection-reset Connection reset by peer :no-buffer-space No buffer space :shutdown Connection shut down :connection-timed-out Connection timed out :connection-refused Connection refused :host-down Host is down :host-unreachable Host is unreachable :unknown Unknown error usocket-0.8.3/notes/backends.txt000066400000000000000000000022361360013566400166510ustar00rootroot00000000000000 -*- text -*- $Id$ A document to describe which APIs a backend should implement. Each backend should implement: Functions: - handle-condition - socket-connect - socket-listen - get-hosts-by-name [ optional ] - get-host-by-address [ optional ] - wait-for-input-internal (new in 0.4.x) Methods: - socket-close - socket-accept - get-local-name - get-peer-name and - for ip sockets - these methods: - get-local-address - get-local-port - get-peer-address - get-peer-port An error-handling function, resolving implementation specific errors to this list of errors: - address-in-use-error - address-not-available-error - bad-file-descriptor-error - connection-refused-error - invalid-argument-error - no-buffers-error - operation-not-supported-error - operation-not-permitted-error - protocol-not-supported-error - socket-type-not-supported-error - network-unreachable-error - network-down-error - network-reset-error - host-down-error - host-unreachable-error - shutdown-error - timeout-error - unkown-error and these conditions: - interrupted-condition - unkown-condition usocket-0.8.3/notes/clisp-sockets.txt000066400000000000000000000027101360013566400176570ustar00rootroot00000000000000http://clisp.cons.org/impnotes.html#socket (SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket]) (SOCKET:SOCKET-SERVER-HOST socket-server) (SOCKET:SOCKET-SERVER-PORT socket-server) (SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]]) (SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) (SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) (SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]]) (SOCKET:SOCKET-STREAM-HOST socket-stream) (SOCKET:SOCKET-STREAM-PORT socket-stream) (SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp")) (SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) (SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) (SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction) (SOCKET:SOCKET-OPTIONS socket-server &REST {option}*) (posix:resolve-host-ipaddr &optional host) with the host-ent structure: name - host name aliases - LIST of aliases addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6) addrtype - INTEGER address type IPv4 or IPv6 Errors are of type SYSTEM::SIMPLE-OS-ERROR with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list This integer stores the OS error reported; meaning WSA* codes on Win32 and E* codes on *nix, only: unix.lisp in CMUCL shows BSD, Linux and SRV4 have different number assignments for the same E* constant names :-( usocket-0.8.3/notes/cmucl-sockets.txt000066400000000000000000000023541360013566400176540ustar00rootroot00000000000000http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html $Id$ extensions:lookup-host-entry host [structure] host-entry name aliases addr-type addr-list [Function] extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface => socket fd [Function] extensions:accept-tcp-connection unconnected => socket fd, address [Function] extensions:connect-to-inet-socket host port &optional kind => socket fd [Function] extensions:close-socket socket [Private function] extensions::get-peer-host-and-port socket-fd [Private function] extentsions::get-socket-host-and-port socket-fd There's currently only 1 condition to be raised: SOCKET-ERROR (derived from SIMPLE-ERROR) which has a SOCKET-ERRNO slot containing the unix error number. [Function] extensions:add-oob-handler fd char handler [Function] extensions:remove-oob-handler fd char [Function] extensions:remove-all-oob-handlers fd [Function] extensions:send-character-out-of-band fd char [Function] extensions:create-inet-socket &optional type => socket fd [Function] extensions:get-socket-option socket level optname [Function] extensions:set-socket-option socket level optname optval [Function] extensions:ip-string addr usocket-0.8.3/notes/design.txt000066400000000000000000000073661360013566400163610ustar00rootroot00000000000000 -*- text -*- $Id$ usocket: Universal sockets library ================================== Contents ======== * Motivation * Design goal * Functional requirements * Class structure Motivation ========== There are 2 other portability sockets packages [that I know of] out there: 1) trivial-sockets 2) acl-compat (which is a *lot* broader, but contains sockets too) The first misses some functionality which is fundamental when the requirements stop being 'trivial', such as finding out the addresses of either side connected to the tcp/ip stream. The second, being a complete compatibility library for Allegro, contains much more than only sockets. Next to that, as the docs say, is it mainly directed at providing the functionality required to port portable-allegroserve - meaning it may be (very) incomplete on some platforms. So, that's why I decided to inherit Erik Enge's project to build a library with the intention to provide portability code in only 1 area of programming, targeted at 'not so trivial' programming. Also, I need this library to extend cl-irc with full DCC functionality. Design goal =========== To provide a portable TCP/IP socket interface for as many implementations as possible, while keeping the portability layer as thin as possible. Functional requirements ======================= The interface provided should allow: - 'client'/active sockets - 'server'/listening sockets - provide the usual stream methods to operate on the connection stream (not necessarily the socket itself; maybe a socket slot too) For now, as long as there are no possibilities to have UDP sockets to write a DNS client library: (which in the end may work better, because in this respect all implementations are different...) - retrieve IP addresses/ports for both sides of the connection Several relevant support functionalities will have to be provided too: - long <-> quad-vector operators - quad-vector <-> string operators - hostname <-> quad-vector operators (hostname resolution) Minimally, I'd like to support: - SBCL - CMUCL - ABCL (ArmedBear) - clisp - Allegro - LispWorks - OpenMCL Comments on the design above ============================ I don't think it's a good idea to implement name lookup in the very first of steps: we'll see if this is required to get the package accepted; not all implementations support it. Name resolution errors ... Since there is no name resolution library (yet), nor standardized hooks into the standard C library to do it the same way on all platforms, name resolution errors can manifest themselves in a lot of different ways. How to marshall these to the library users? Several solutions come to mind: 1) Map them to 'unknown-error 2) Give them their own errors and map to those ... which implies that they are actually supported atm. 3) ... Given that the library doesn't now, but may in the future, include name resolution officially, I tend to think (1) is the right answer: it leaves it all undecided. These errors can be raised by the nameresolution service (netdb.h) as values for 'int h_errno': - HOST_NOT_FOUND (1) - TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */ - NO_RECOVERY (3) /* Failed permanently */ - NO_DATA (4) /* Valid address, no data for requested record */ int *__h_errno_location(void) points to thread local h_errno on threaded glibc2 systems. Class structure =============== usocket | +- datagram-usocket +- stream-usocket \- stream-server-usocket The usocket class will have methods to query local properties, such as: - get-local-name: to query to which interface the socket is bound - usocket-0.8.3/notes/errors.txt000066400000000000000000000014041360013566400164070ustar00rootroot00000000000000EADDRINUSE 48 address-in-use-error EADDRNOTAVAIL 49 address-not-available-error EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35 EBADF 9 bad-file-descriptor-error ECONNREFUSED 61 connection-refused-error EINTR 4 interrupted-error EINVAL 22 invalid-argument-error ENOBUFS 55 no-buffers-error ENOMEM 12 out-of-memory-error EOPNOTSUPP 45 operation-not-supported-error EPERM 1 operation-not-permitted-error EPROTONOSUPPORT 43 protocol-not-supported-error ESOCKTNOSUPPORT 44 socket-type-not-supported-error ENETUNREACH 51 network-unreachable-error ENETDOWN 50 network-down-error ENETRESET 52 network-reset-error ESHUTDOWN 58 already-shutdown-error ETIMEDOUT 60 connection-timeout-error EHOSTDOWN 64 host-down-error EHOSTUNREACH 65 host-unreachable-error usocket-0.8.3/notes/lw-sockets.txt000066400000000000000000000015261360013566400171730ustar00rootroot00000000000000 $Id$ http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM Package: COMM ip-address-string socket-stream-address socket-stream-peer-address start-up-server start-up-server-and-mp string-ip-address with-noticed-socket-stream Needed components for usocket: comm::get-fd-from-socket socket-fd => socket-fd comm::accept-connection-to-socket socket-fd => socket-fd comm::close-socket comm::create-tcp-socket-for-service => socket-fd open-tcp-stream peer-host peer-port &key direction element-type => socket-stream get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-897837) get-socket-address get-socket-peer-address => address, port socket-stream socket-fd => stream socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm) => socket-fd usocket-0.8.3/notes/openmcl-sockets.txt000066400000000000000000000013261360013566400202040ustar00rootroot00000000000000http://openmcl.clozure.com/Doc/sockets.html make-socket [Function] accept-connection [Function] dotted-to-ipaddr [Function] ipaddr-to-dotted [Function] ipaddr-to-hostname [Function] lookup-hostname [Function] lookup-port [Function] receive-from [Function] send-to [Function] shutdown [Function] socket-os-fd [Function] remote-port [Function] local-host [Function] local-port [Function] socket-address-family [Function] socket-connect [Function] socket-format [Function] socket-type [Function] socket-error [Class] socket-error-code [Function] socket-error-identifier [Function] socket-error-situation [Function] close [method] usocket-0.8.3/notes/sb-bsd-sockets.txt000066400000000000000000000066661360013566400177350ustar00rootroot00000000000000http://www.xach.com/sbcl/sb-bsd-sockets.html $Id$ package: sb-bsd-sockets class: socket slots: * file-descriptor : * family : * protocol : * type : * stream : operators: (socket-bind (s socket) &rest address) Generic Function (socket-accept (socket socket)) Method (socket-connect (s socket) &rest address) Generic Function (socket-peername (socket socket)) Method (socket-name (socket socket)) Method (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method (socket-listen (socket socket) backlog) Method (socket-close (socket socket)) Method (socket-make-stream (socket socket) &rest args) Method (sockopt-reuse-address (socket socket) argument) Accessor (sockopt-keep-alive (socket socket) argument) Accessor (sockopt-oob-inline (socket socket) argument) Accessor (sockopt-bsd-compatible (socket socket) argument) Accessor (sockopt-pass-credentials (socket socket) argument) Accessor (sockopt-debug (socket socket) argument) Accessor (sockopt-dont-route (socket socket) argument) Accessor (sockopt-broadcast (socket socket) argument) Accessor (sockopt-tcp-nodelay (socket socket) argument) Accessor inet-domain sockets class: inet-socket slots: * family : operators: (make-inet-address dotted-quads) Function (get-protocol-by-name name) Function (make-inet-socket type protocol) Function file-domain sockets class: unix-socket slots: * family : class: host-ent Slots: * name : * aliases : * address-type : * addresses : (host-ent-address (host-ent host-ent)) Method (get-host-by-name host-name) Function (get-host-by-address address) Function (name-service-error where) Function (non-blocking-mode (socket socket)) Method (define-socket-condition sockint::EADDRINUSE address-in-use-error) (define-socket-condition sockint::EAGAIN interrupted-error) (define-socket-condition sockint::EBADF bad-file-descriptor-error) (define-socket-condition sockint::ECONNREFUSED connection-refused-error) (define-socket-condition sockint::EINTR interrupted-error) (define-socket-condition sockint::EINVAL invalid-argument-error) (define-socket-condition sockint::ENOBUFS no-buffers-error) (define-socket-condition sockint::ENOMEM out-of-memory-error) (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) (define-socket-condition sockint::EPERM operation-not-permitted-error) (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) (define-socket-condition sockint::ENETUNREACH network-unreachable-error) Exported errors: * (apropos "ERROR" :sb-bsd-sockets) SB-BSD-SOCKETS:INTERRUPTED-ERROR SB-BSD-SOCKETS:TRY-AGAIN-ERROR * SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?) SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR * SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR SB-BSD-SOCKETS:NO-BUFFERS-ERROR SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR And 1 non-exported error: SB-BSD-SOCKETS::NO-ADDRESS-ERROR *-ed errors aren't yet addressed in the errorlist supported by usocket usocket-0.8.3/notes/usock-sockets.txt000066400000000000000000000015161360013566400176740ustar00rootroot00000000000000Package: clisp : socket cmucl : extensions sbcl : sb-bsd-sockets lw : comm openmcl: openmcl-socket allegro: sock Connecting (TCP/inet only) clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream cmucl : connect-to-inet-socket host port &optional kind => file descriptor sbcl : sb-socket-connect socket &rest address => socket lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object openmcl: socket-connect socket => :active, :passive or nil allegro: make-socket (&rest args &key type format connect address-family eol) => socket Closing clisp : close socket cmucl : close-socket socket sbcl : socket-close socket lw : close socket openmcl: close socket allegro: close socket Errorsusocket-0.8.3/option.lisp000066400000000000000000000234111360013566400154050ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- ;;;; SOCKET-OPTION, a high-level socket option get/set framework ;;;; See LICENSE for licensing information. (in-package :usocket) ;; put here because option.lisp is for native backend only (defparameter *backend* :native) ;;; 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)) ;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO) (defmethod socket-option ((usocket stream-usocket) (option (eql :receive-timeout)) &key) (declare (ignorable option)) (let ((socket (socket usocket))) (declare (ignorable socket)) #+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)) #+(or ecl clasp) (sb-bsd-sockets:sockopt-receive-timeout socket) #+lispworks (get-socket-receive-timeout socket) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (sb-impl::fd-stream-timeout (socket-stream usocket)) #+scl ())) ; TODO (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)) (declare (ignorable socket timeout)) #+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)) #+(or ecl clasp) (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout) #+lispworks (set-socket-receive-timeout socket timeout) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) (coerce timeout 'single-float)) #+scl () ; TODO new-value)) ;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO) (defmethod socket-option ((usocket stream-usocket) (option (eql :send-timeout)) &key) (declare (ignorable option)) (let ((socket (socket usocket))) (declare (ignorable socket)) #+abcl () ; TODO #+allegro () ; TODO #+clisp (socket:socket-options socket :so-sndtimeo) #+clozure (ccl:stream-output-timeout socket) #+cmu (lisp::fd-stream-timeout (socket-stream usocket)) #+(or ecl clasp) (sb-bsd-sockets:sockopt-send-timeout socket) #+lispworks (get-socket-send-timeout socket) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (sb-impl::fd-stream-timeout (socket-stream usocket)) #+scl ())) ; TODO (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)) (declare (ignorable socket timeout)) #+abcl () ; TODO #+allegro () ; TODO #+clisp (socket:socket-options socket :so-sndtimeo timeout) #+clozure (setf (ccl:stream-output-timeout socket) timeout) #+cmu (setf (lisp::fd-stream-timeout (socket-stream usocket)) (coerce timeout 'integer)) #+(or ecl clasp) (setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout) #+lispworks (set-socket-send-timeout socket timeout) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) (coerce timeout 'single-float)) #+scl () ; TODO new-value)) ;;; 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))) (declare (ignorable socket)) #+abcl () ; TODO #+allegro () ; TODO #+clisp (int->bool (socket:socket-options socket :so-reuseaddr)) #+clozure (int->bool (get-socket-option-reuseaddr socket)) #+cmu () ; TODO #+lispworks (get-socket-reuse-address socket) #+mcl () ; TODO #+mocl () ; unknown #+(or ecl sbcl clasp) (sb-bsd-sockets:sockopt-reuse-address socket) #+scl ())) ; TODO (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))) (declare (ignorable socket)) #+abcl () ; TODO #+allegro (socket:set-socket-options socket option new-value) #+clisp (socket:socket-options socket :so-reuseaddr (bool->int new-value)) #+clozure (set-socket-option-reuseaddr socket (bool->int new-value)) #+cmu () ; TODO #+lispworks (set-socket-reuse-address socket new-value) #+mcl () ; TODO #+mocl () ; unknown #+(or ecl sbcl clasp) (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value) #+scl () ; TODO 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))) (declare (ignorable socket)) #+abcl () ; TODO #+allegro () ; TODO #+clisp (int->bool (socket:socket-options socket :so-broadcast)) #+clozure (int->bool (get-socket-option-broadcast socket)) #+cmu () ; TODO #+(or ecl clasp) () ; TODO #+lispworks () ; TODO #+mcl () ; TODO #+mocl () ; unknown #+sbcl (sb-bsd-sockets:sockopt-broadcast socket) #+scl ())) ; TODO (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))) (declare (ignorable socket)) #+abcl () ; TODO #+allegro (socket:set-socket-options socket option new-value) #+clisp (socket:socket-options socket :so-broadcast (bool->int new-value)) #+clozure (set-socket-option-broadcast socket (bool->int new-value)) #+cmu () ; TODO #+(or ecl clasp) () ; TODO #+lispworks () ; TODO #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) #+scl () ; TODO new-value)) ;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client (defmethod socket-option ((usocket stream-usocket) (option (eql :tcp-no-delay)) &key) (declare (ignorable 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)) #+abcl () ; TODO #+allegro () ; TODO #+clisp (int->bool (socket:socket-options socket :tcp-nodelay)) #+clozure (int->bool (get-socket-option-tcp-nodelay socket)) #+cmu () #+(or ecl clasp) (sb-bsd-sockets::sockopt-tcp-nodelay socket) #+lispworks (int->bool (get-socket-tcp-nodelay socket)) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (sb-bsd-sockets::sockopt-tcp-nodelay socket) #+scl ())) ; TODO (defmethod (setf socket-option) (new-value (usocket stream-usocket) (option (eql :tcp-no-delay)) &key) (declare (ignorable 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)) #+abcl () ; TODO #+allegro (socket:set-socket-options socket :no-delay new-value) #+clisp (socket:socket-options socket :tcp-nodelay (bool->int new-value)) #+clozure (set-socket-option-tcp-nodelay socket (bool->int new-value)) #+cmu () #+(or ecl clasp) (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) #+lispworks (progn #-(or lispworks4 lispworks5.0) (comm::set-socket-tcp-nodelay socket new-value) #+(or lispworks4 lispworks5.0) (set-socket-tcp-nodelay socket (bool->int new-value))) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) #+scl () ; TODO new-value)) (eval-when (:load-toplevel :execute) (export 'socket-option)) usocket-0.8.3/package.lisp000066400000000000000000000102101360013566400154610ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*- ;;;; See the LICENSE file for licensing information. (defpackage :usocket (:use #-genera :common-lisp #+genera :future-common-lisp #+abcl :java :split-sequence) (:export #:*version* #:*wildcard-host* #:*auto-port* #:+max-datagram-packet-size+ #:socket-connect ; socket constructors and methods #:socket-listen #:socket-accept #:socket-close #:socket-shutdown #:get-local-address #:get-peer-address #:get-local-port #:get-peer-port #:get-local-name #:get-peer-name #:socket-send ; udp function (send) #:socket-receive ; udp function (receive) #:wait-for-input ; waiting for input-ready state (select() like) #:make-wait-list #:add-waiter #:remove-waiter #:remove-all-waiters #:with-connected-socket ; convenience macros #:with-server-socket #:with-client-socket #:with-socket-listener #:usocket ; socket object and accessors #:stream-usocket #:stream-server-usocket #:socket #:socket-stream #:datagram-usocket #:socket-state ; 0.6.4 ;; predicates (for version 0.6 or 1.0 ?) #:usocket-p #:stream-usocket-p #:stream-server-usocket-p #:datagram-usocket-p #:host-byte-order ; IPv4 utility functions #:hbo-to-dotted-quad #:hbo-to-vector-quad #:vector-quad-to-dotted-quad #:dotted-quad-to-vector-quad #:vector-to-ipv6-host ; IPv6 utility functions #:ipv6-host-to-vector #:ip= ; IPv4+IPv6 utility function #:ip/= #:integer-to-octet-buffer ; Network utility functions #:octet-buffer-to-integer #:port-to-octet-buffer #:port-from-octet-buffer #:ip-to-octet-buffer #:ip-from-octet-buffer #:with-mapped-conditions #:socket-condition ; conditions #:ns-condition #:socket-error ; errors #:ns-error #:unknown-condition #:ns-unknown-condition #:unknown-error #:ns-unknown-error #:socket-warning ; warnings (udp) #:insufficient-implementation ; conditions regarding usocket support level #:unsupported #:unimplemented #:socket-server #:*remote-host* #:*remote-port* ;; added in 0.7.1 #:get-host-by-name #:get-hosts-by-name #:get-random-host-by-name #:ns-host-not-found-error #:ns-no-recovery-error #:ns-try-again-condition #:default-udp-handler #:default-tcp-handler #:echo-tcp-handler ;; server handlers ;; added in 0.8.0 #:*backend* #:*default-event-base* #:host-to-hostname ;; these're socket-related conditions from IOlib #:ADDRESS-NOT-AVAILABLE-ERROR #:HOST-DOWN-ERROR #:OPERATION-NOT-SUPPORTED-ERROR #:SOCKET-OPTION #:NETWORK-DOWN-ERROR #:INVALID-SOCKET-ERROR #:SOCKET-TYPE-NOT-SUPPORTED-ERROR #:DEADLINE-TIMEOUT-ERROR #:SHUTDOWN-ERROR #:HOST-UNREACHABLE-ERROR #:NETWORK-UNREACHABLE-ERROR #:CONNECTION-ABORTED-ERROR #:BAD-FILE-DESCRIPTOR-ERROR #:PROTOCOL-NOT-SUPPORTED-ERROR #:CONNECTION-RESET-ERROR #:TIMEOUT-ERROR #:ADDRESS-IN-USE-ERROR #:NO-BUFFERS-ERROR #:INVALID-SOCKET-STREAM-ERROR #:INTERRUPTED-CONDITION #:INVALID-ARGUMENT-ERROR #:OPERATION-NOT-PERMITTED-ERROR #:NETWORK-RESET-ERROR #:CONNECTION-REFUSED-ERROR ;; added in 0.8.2 #:host-or-ip )) usocket-0.8.3/server.lisp000066400000000000000000000114441360013566400154060ustar00rootroot00000000000000;;;; See LICENSE for licensing information. (in-package :usocket) (defvar *server*) (defun socket-server (host port function &optional arguments &key in-new-thread (protocol :stream) ;; for udp (timeout 1) (max-buffer-size +max-datagram-packet-size+) ;; for tcp element-type (reuse-address t) multi-threading name) (let* ((real-host (or host *wildcard-host*)) (socket (ecase protocol (:stream (apply #'socket-listen `(,real-host ,port ,@(when element-type `(:element-type ,element-type)) ,@(when reuse-address `(:reuse-address ,reuse-address))))) (:datagram (socket-connect nil nil :protocol :datagram :local-host real-host :local-port port))))) (labels ((real-call () (ecase protocol (:stream (tcp-event-loop socket function arguments :element-type element-type :multi-threading multi-threading)) (:datagram (udp-event-loop socket function arguments :timeout timeout :max-buffer-size max-buffer-size))))) (if in-new-thread (values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket) (progn (setq *server* socket) (real-call)))))) (defvar *remote-host*) (defvar *remote-port*) (defun default-udp-handler (buffer) ; echo (declare (type (simple-array (unsigned-byte 8) *) buffer)) buffer) (defun udp-event-loop (socket function &optional arguments &key timeout max-buffer-size) (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0)) (sockets (list socket))) (unwind-protect (loop do (multiple-value-bind (return-sockets real-time) (wait-for-input sockets :timeout timeout) (declare (ignore return-sockets)) (when real-time (multiple-value-bind (recv n *remote-host* *remote-port*) (socket-receive socket buffer max-buffer-size) (declare (ignore recv)) (if (plusp n) (progn (let ((reply (apply function (subseq buffer 0 n) arguments))) (when reply (replace buffer reply) (let ((n (socket-send socket buffer (length reply) :host *remote-host* :port *remote-port*))) (when (minusp n) (error "send error: ~A~%" n)))))) (error "receive error: ~A" n)))) #+scl (when thread:*quitting-lisp* (return)) #+(and cmu mp) (mp:process-yield))) (socket-close socket) (values)))) (defun default-tcp-handler (stream) ; null (declare (type stream stream)) (format stream "Hello world!~%")) (defun echo-tcp-handler (stream) (loop (when (listen stream) (let ((line (read-line stream nil))) (write-line line stream) (force-output stream))))) (defun tcp-event-loop (socket function &optional arguments &key element-type multi-threading) (let ((real-function #'(lambda (client-socket &rest arguments) (unwind-protect (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket) (apply function (socket-stream client-socket) arguments)) (close (socket-stream client-socket)) (socket-close client-socket) nil)))) (unwind-protect (loop do (let* ((client-socket (apply #'socket-accept `(,socket ,@(when element-type `(:element-type ,element-type))))) (client-stream (socket-stream client-socket))) (if multi-threading (bt:make-thread (lambda () (apply real-function client-socket arguments)) :name "USOCKET Client") (prog1 (apply real-function client-socket arguments) (close client-stream) (socket-close client-socket))) #+scl (when thread:*quitting-lisp* (return)) #+(and cmu mp) (mp:process-yield))) (socket-close socket) (values)))) usocket-0.8.3/test/000077500000000000000000000000001360013566400141625ustar00rootroot00000000000000usocket-0.8.3/test/package.lisp000066400000000000000000000004271360013566400164510ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*- ;;;; See the LICENSE file for licensing information. (in-package :cl-user) (defpackage :usocket-test (:use :common-lisp :usocket :regression-test) (:export #:do-tests #:run-usocket-tests)) usocket-0.8.3/test/test-condition.lisp000066400000000000000000000014341360013566400200200ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- ;;;; See LICENSE for licensing information. (in-package :usocket-test) (deftest ns-host-not-found-error.1 (with-caught-conditions (usocket:ns-host-not-found-error nil) (usocket:socket-connect "xxx" 123) t) nil) (deftest timeout-error.1 (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect "common-lisp.net" 81 :timeout 0) t) nil) (deftest connection-refused-error.1 (with-caught-conditions (usocket:connection-refused-error nil) (usocket:socket-connect "common-lisp.net" 81) t) nil) (deftest operation-not-permitted-error.1 (with-caught-conditions (usocket:operation-not-permitted-error nil) (usocket:socket-listen "0.0.0.0" 81) t) nil) usocket-0.8.3/test/test-datagram.lisp000066400000000000000000000113121360013566400176060ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- ;;;; See LICENSE for licensing information. (in-package :usocket-test) (defvar *echo-server*) (defvar *echo-server-port*) (defun start-server () (multiple-value-bind (thread socket) (socket-server "127.0.0.1" 0 #'identity nil :in-new-thread t :protocol :datagram) (setq *echo-server* thread *echo-server-port* (get-local-port socket)))) (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 (progn (unless (and *echo-server* *echo-server-port*) (start-server)) (let ((s (socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) (socket-send s *send-buffer* 5) (wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) ;;; UDP Send Test #2: unconnected socket (deftest udp-send.2 (progn (unless (and *echo-server* *echo-server-port*) (start-server)) (let ((s (socket-connect nil nil :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) (socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*) (wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) (deftest mark-h-david ; Mark H. David's remarkable UDP test code (let* ((host "localhost") (port 1111) (server-sock (socket-connect nil nil :protocol ':datagram :local-host host :local-port port)) (client-sock (socket-connect host port :protocol ':datagram)) (octet-vector (make-array 2 :element-type '(unsigned-byte 8) :initial-contents `(,(char-code #\O) ,(char-code #\K)))) (recv-octet-vector (make-array 2 :element-type '(unsigned-byte 8)))) (socket-send client-sock octet-vector 2) (socket-receive server-sock recv-octet-vector 2) (prog1 (and (equalp octet-vector recv-octet-vector) recv-octet-vector) (socket-close server-sock) (socket-close client-sock))) #(79 75)) (deftest frank-james ; Frank James' test code for LispWorks/UDP (with-caught-conditions (#+win32 CONNECTION-RESET-ERROR #-win32 CONNECTION-REFUSED-ERROR nil) (let ((sock (socket-connect "localhost" 1234 :protocol ':datagram :element-type '(unsigned-byte 8)))) (unwind-protect (progn (socket-send sock (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0) 16) (let ((buffer (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))) (socket-receive sock buffer 16))) (socket-close sock)))) nil) (defun frank-wfi-test () (let ((s (socket-connect nil nil :protocol :datagram :element-type '(unsigned-byte 8) :local-port 8001))) (unwind-protect (do ((i 0 (1+ i)) (buffer (make-array 1024 :element-type '(unsigned-byte 8) :initial-element 0)) (now (get-universal-time)) (done nil)) ((or done (= i 4)) nil) (format t "~Ds ~D Waiting state ~S~%" (- (get-universal-time) now) i (usocket::state s)) (when (wait-for-input s :ready-only t :timeout 5) (format t "~D state ~S~%" i (usocket::state s)) (handler-bind ((error (lambda (c) (format t "socket-receive error: ~A~%" c) (break) nil))) (multiple-value-bind (buffer count remote-host remote-port) (socket-receive s buffer 1024) (handler-bind ((error (lambda (c) (format t "socket-send error: ~A~%" c) (break)))) (when buffer (socket-send s (subseq buffer 0 count) count :host remote-host :port remote-port))))))) (socket-close s)))) usocket-0.8.3/test/test-usocket.lisp000066400000000000000000000131241360013566400175060ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- ;;;; See LICENSE for licensing information. ;;;; Usage: (usoct:run-usocket-tests) or (usoct:do-tests) (in-package :usocket-test) (defparameter +non-existing-host+ "1.2.3.4") (defparameter +unused-local-port+ 15213) (defparameter *fake-usocket* (usocket::make-stream-socket :socket :my-socket :stream :my-stream)) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *common-lisp-net* (get-host-by-name "common-lisp.net"))) (defvar *local-ip*) (defmacro with-caught-conditions ((expect throw) &body body) `(catch 'caught-error (handler-case (handler-bind ((unsupported #'(lambda (c) (declare (ignore c)) (continue)))) (progn ,@body)) (unknown-error (c) (if (typep c ',expect) (throw 'caught-error ,throw) (progn (describe c) (describe (usocket::usocket-real-error c)) c))) (error (c) (if (typep c ',expect) (throw 'caught-error ,throw) (progn (describe c) c))) (unknown-condition (c) (if (typep c ',expect) (throw 'caught-error ,throw) (progn (describe c) (describe (usocket::usocket-real-condition c)) c))) (condition (c) (if (typep c ',expect) (throw 'caught-error ,throw) (progn (describe c) c)))))) (deftest make-socket.1 (socket *fake-usocket*) :my-socket) (deftest make-socket.2 (socket-stream *fake-usocket*) :my-stream) (deftest socket-no-connect.1 (with-caught-conditions (socket-error nil) (socket-connect "127.0.0.1" +unused-local-port+ :timeout 1) t) nil) (deftest socket-no-connect.2 (with-caught-conditions (socket-error nil) (socket-connect #(127 0 0 1) +unused-local-port+ :timeout 1) t) nil) (deftest socket-no-connect.3 (with-caught-conditions (socket-error nil) (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1) t) nil) (deftest socket-failure.1 (with-caught-conditions (timeout-error nil) (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1) :unreach) nil) (deftest socket-failure.2 (with-caught-conditions (timeout-error nil) (socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port :unreach) nil) ;; let's hope c-l.net doesn't move soon, or that people start to ;; test usocket like crazy.. (deftest socket-connect.1 (with-caught-conditions (nil nil) (let ((sock (socket-connect "common-lisp.net" 80))) (unwind-protect (when (typep sock 'usocket) t) (socket-close sock)))) t) (deftest socket-connect.2 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (when (typep sock 'usocket) t) (socket-close sock)))) t) (deftest socket-connect.3 (with-caught-conditions (nil nil) (let ((sock (socket-connect (usocket::host-byte-order *common-lisp-net*) 80))) (unwind-protect (when (typep sock 'usocket) t) (socket-close sock)))) t) ;; let's hope c-l.net doesn't change its software any time soon (deftest socket-stream.1 (with-caught-conditions (nil nil) (let ((sock (socket-connect "common-lisp.net" 80))) (unwind-protect (progn (format (socket-stream sock) "GET / HTTP/1.0~2%") (force-output (socket-stream sock)) (subseq (read-line (socket-stream sock)) 0 4)) (socket-close sock)))) "HTTP") (deftest socket-name.1 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (get-peer-address sock) (socket-close sock)))) #.*common-lisp-net*) (deftest socket-name.2 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (get-peer-port sock) (socket-close sock)))) 80) (deftest socket-name.3 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (get-peer-name sock) (socket-close sock)))) #.*common-lisp-net* 80) #+ignore (deftest socket-name.4 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (equal (get-local-address sock) *local-ip*) (socket-close sock)))) t) (deftest socket-shutdown.1 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (usocket::ignore-unsupported-warnings (socket-shutdown sock :input)) (socket-close sock)) t)) t) (deftest socket-shutdown.2 (with-caught-conditions (nil nil) (let ((sock (socket-connect *common-lisp-net* 80))) (unwind-protect (usocket::ignore-unsupported-warnings (socket-shutdown sock :output)) (socket-close sock)) t)) t) (defun run-usocket-tests () (do-tests)) usocket-0.8.3/test/udp-one-shot.lisp000066400000000000000000000102431360013566400173750ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- (in-package :usocket-test) ;; Test code from "INVALID-ARGUMENT-ERROR on socket-receive (#48)" ;; Author: @4lph4-Ph4un ;; Environment: SBCL 1.4.16, WSL on Windows 10 (defun UDP-one-shot-V1 (&optional (port 1232)) (let ((socket (usocket:socket-connect nil nil :protocol :datagram :element-type '(unsigned-byte 8) :local-host "127.0.0.1" :local-port port)) (buffer (make-array 8 :element-type '(unsigned-byte 8)))) (unwind-protect (multiple-value-bind (received size remote-host remote-port) ;; NOTE: An explicit buffer can be given. If the length ;; is nil buffer's length will be used. (usocket:socket-receive socket buffer 8) (format t "~A~%" received) (usocket:socket-send socket (reverse received) size :host remote-host :port remote-port)) (usocket:socket-close socket)))) #| Backtrace: 0: (USOCKET::HANDLE-CONDITION # #) Locals: CONDITION = # SOCKET = # 1: (SB-KERNEL::%SIGNAL #) Locals: CONDITION = # HANDLER-CLUSTERS = (((# . #)) ((# . #)) ..) 2: (ERROR SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR :ERRNO 22 :SYSCALL "recvfrom") Locals: CONDITION = # #:G8039 = SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR SB-DEBUG::MORE = (:ERRNO 22 :SYSCALL "recvfrom") 3: (SB-BSD-SOCKETS:SOCKET-ERROR "recvfrom" 22) Locals: ERRNO = 22 WHERE = "recvfrom" 4: ((FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) # SB-BSD-SOCKETS::SIZE = 16 SB-BSD-SOCKETS::SOCKADDR = # 5: (SB-BSD-SOCKETS::CALL-WITH-SOCKET-ADDR # NIL # SOCKADDR-ARGS = NIL SOCKET = # THUNK = # 6: ((:METHOD SB-BSD-SOCKETS:SOCKET-RECEIVE (SB-BSD-SOCKETS:SOCKET T T)) # #(0 0 0 0 0 0 ...) 8 :OOB NIL :PEEK NIL :WAITALL NIL :DONTWAIT NIL.. Locals: #:.DEFAULTING-TEMP. = (UNSIGNED-BYTE 8) SB-BSD-SOCKETS::BUFFER = #(0 0 0 0 0 0 ...) SB-BSD-SOCKETS::BUFFER#1 = #(0 0 0 0 0 0 ...) SB-BSD-SOCKETS::DONTWAIT = NIL SB-BSD-SOCKETS::ELEMENT-TYPE = (UNSIGNED-BYTE 8) LENGTH = 8 LENGTH#1 = 8 SB-BSD-SOCKETS::OOB = NIL SB-BSD-SOCKETS::PEEK = NIL SB-BSD-SOCKETS:SOCKET = # SB-BSD-SOCKETS::WAITALL = NIL 7: ((:METHOD USOCKET:SOCKET-RECEIVE (USOCKET:DATAGRAM-USOCKET T T)) # #(0 0 0 0 0 0 ...) 8 :ELEMENT-TYPE (UNSIGNED-BYTE 8)) [fast-method] Locals: USOCKET::BUFFER = #(0 0 0 0 0 0 ...) USOCKET::ELEMENT-TYPE = (UNSIGNED-BYTE 8) LENGTH = 8 USOCKET:SOCKET = # 8: (MASTER-CLASS/SRC/SERVER-03:UDP-ONE-SHOT-V1 1232) Locals: PORT = 1232 SOCKET = # |# usocket-0.8.3/test/wait-for-input.lisp000066400000000000000000000116661360013566400177520ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- ;;;; See LICENSE for licensing information. (in-package :usocket-test) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *wait-for-input-timeout* 2)) (deftest wait-for-input.1 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80)) (time (get-universal-time))) (unwind-protect (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) (- (get-universal-time) time)) (usocket:socket-close sock)))) #.*wait-for-input-timeout*) (deftest wait-for-input.2 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80)) (time (get-universal-time))) (unwind-protect (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t) (- (get-universal-time) time)) (usocket:socket-close sock)))) #.*wait-for-input-timeout*) (deftest wait-for-input.3 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (progn (format (usocket:socket-stream sock) "GET / HTTP/1.0~2%") (force-output (usocket:socket-stream sock)) (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) (subseq (read-line (usocket:socket-stream sock)) 0 4)) (usocket:socket-close sock)))) "HTTP") ;;; Advanced W-F-I tests by Elliott Slaughter (defvar *socket-server-port* 0) (defvar *socket-server-listen* nil) (defvar *socket-server-connection*) (defvar *socket-client-connection*) (defvar *output-p* t) (defun stage-1 () (unless *socket-server-listen* (setf *socket-server-listen* (socket-listen *wildcard-host* 0 :element-type '(unsigned-byte 8))) (setf *socket-server-port* (get-local-port *socket-server-listen*))) (setf *socket-server-connection* (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) (socket-accept *socket-server-listen*))) (when *output-p* ; should be NIL (format t "First time (before client connects) is ~s.~%" *socket-server-connection*)) *socket-server-connection*) ;; TODO: original test code have addition (:TIMEOUT 0) when doing the SOCKET-CONNECT, ;; it seems cannot work on SBCL/Windows, need to investigate, but here we ignore it. (defun stage-2 () (setf *socket-client-connection* (socket-connect "localhost" *socket-server-port* :protocol :stream :element-type '(unsigned-byte 8))) (setf *socket-server-connection* (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) #+(and win32 (or lispworks ecl sbcl)) (when *output-p* (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*))) (socket-accept *socket-server-listen*))) (when *output-p* ; should be a usocket object (format t "Second time (after client connects) is ~s.~%" *socket-server-connection*)) *socket-server-connection*) (defun stage-3 () (setf *socket-server-connection* (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) #+(and win32 (or lispworks ecl sbcl)) (when *output-p* (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*))) (socket-accept *socket-server-listen*))) (when *output-p* ; should be NIL again (format t "Third time (before second client) is ~s.~%" *socket-server-connection*)) *socket-server-connection*) (deftest elliott-slaughter.1 (let ((*output-p* nil)) (let* ((s-1 (stage-1)) (s-2 (stage-2)) (s-3 (stage-3))) (prog1 (and (null s-1) (usocket::usocket-p s-2) (null s-3)) (socket-close *socket-server-listen*) (setf *socket-server-listen* nil)))) t) #| Issue elliott-slaughter.2 (WAIT-FOR-INPUT/win32 on TCP socket) W-F-I correctly found the inputs, but :READY-ONLY didn't work. |# (defun receive-each (connections) (let ((ready (usocket:wait-for-input connections :timeout 0 :ready-only t))) (loop for connection in ready collect (read-line (usocket:socket-stream connection))))) (defun receive-all (connections) (loop for messages = (receive-each connections) then (receive-each connections) while messages append messages)) (defun send (connection message) (format (usocket:socket-stream connection) "~a~%" message) (force-output (usocket:socket-stream connection))) (defun server () (let* ((listen (usocket:socket-listen usocket:*wildcard-host* 12345)) (connection (usocket:socket-accept listen))) (loop for messages = (receive-all connection) then (receive-all connection) do (format t "Got messages:~%~s~%" messages) do (sleep 1/50)))) (defun client () (let ((connection (usocket:socket-connect "localhost" 12345))) (loop for i from 0 do (send connection (format nil "This is message ~a." i)) do (sleep 1/100)))) usocket-0.8.3/usocket-server.asd000066400000000000000000000006331360013566400166570ustar00rootroot00000000000000;;;; -*- Mode: Lisp -*- ;;;; ;;;; See the LICENSE file for licensing information. (in-package :asdf) (defsystem usocket-server :name "usocket (server)" :author "Chun Tian (binghe)" :version (:read-file-form "version.sexp") :licence "MIT" :description "Universal socket library for Common Lisp (server side)" :depends-on (:usocket :bordeaux-threads) :components ((:file "server"))) usocket-0.8.3/usocket-test.asd000066400000000000000000000012441360013566400163270ustar00rootroot00000000000000;;;; -*- Mode: Lisp -*- ;;;; See the LICENSE file for licensing information. (defsystem usocket-test :name "usocket test" :author "Erik Enge" :maintainer "Chun Tian (binghe)" :version (:read-file-form "version.sexp") :licence "MIT" :description "Tests for usocket" :depends-on (:usocket-server :rt) :components ((:module "test" :serial t :components ((:file "package") (:file "test-usocket") (:file "test-condition") (:file "test-datagram") (:file "wait-for-input"))))) (defmethod perform ((op test-op) (c (eql (find-system :usocket-test)))) (funcall (intern "DO-TESTS" "USOCKET-TEST"))) usocket-0.8.3/usocket.asd000066400000000000000000000040311360013566400153470ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; -*- ;;;; ;;;; See the LICENSE file for licensing information. (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, with server symbols)" :author "Erik Enge & Erik Huelsmann" :maintainer "Chun Tian (binghe) & Hans Huebner" :version (:read-file-form "version.sexp") :licence "MIT" :description "Universal socket library for Common Lisp" :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 "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 clasp) (:file "sbcl") #+ecl (:file "ecl" :depends-on ("sbcl")) #+clasp (:file "clasp" :depends-on ("sbcl")) #+lispworks (:file "lispworks") #+mcl (:file "mcl") #+mocl (:file "mocl") #+scl (:file "scl") #+genera (:file "genera") #+mezzano (:file "mezzano"))) #-usocket-iolib (:file "option" :depends-on ("backend")) #+usocket-iolib (:module "backend" :depends-on ("condition") :components ((:file "iolib"))))) (defmethod perform ((op test-op) (c (eql (find-system :usocket)))) (oos 'load-op ':usocket-test) (oos 'test-op ':usocket-test)) usocket-0.8.3/usocket.lisp000066400000000000000000000654051360013566400155630ustar00rootroot00000000000000;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- ;;;; See LICENSE for licensing information. (in-package :usocket) (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 systems will also listen for IPv6 connections.") (defparameter *auto-port* 0 "Port number to pass when an auto-assigned port number is wanted.") (defparameter *version* #.(asdf:component-version (asdf:find-system :usocket)) "usocket version string") (defconstant +max-datagram-packet-size+ 65507 "The theoretical maximum amount of data in a UDP datagram. The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header has 28-byte. IP_MAXPACKET = 65535, /* netinet/ip.h */ sizeof(struct ip) = 20, /* netinet/ip.h */ sizeof(struct udphdr) = 8, /* netinet/udp.h */ 65535 - 20 - 8 = 65507 (But for UDP broadcast, the maximum message size is limited by the MTU size of the underlying link)") (defclass usocket () ((socket :initarg :socket :accessor socket :documentation "Implementation specific socket object instance.'") (wait-list :initform nil :accessor wait-list :documentation "WAIT-LIST the object is associated with.") (state :initform nil :accessor state :documentation "Per-socket return value for the `wait-for-input' function. The value stored in this slot can be any of NIL - not ready :READ - ready to read :READ-WRITE - ready to read and write :WRITE - ready to write The last two remain unused in the current version. ") #+(and win32 (or sbcl ecl lispworks)) (%ready-p :initform nil :accessor %ready-p :documentation "Indicates whether the socket has been signalled as ready for reading a new connection. The value will be set to T by `wait-for-input-internal' (given the right conditions) and reset to NIL by `socket-accept'. Don't modify this slot or depend on it as it is really intended to be internal only. Note: Accessed, but not used for 'stream-usocket'. " )) (:documentation "The main socket class. Sockets should be closed using the `socket-close' method.")) (defgeneric socket-state (socket) (:documentation "NIL - not ready :READ - ready to read :READ-WRITE - ready to read and write :WRITE - ready to write")) (defmethod socket-state ((socket usocket)) (state socket)) (defclass stream-usocket (usocket) ((stream :initarg :stream :accessor socket-stream :documentation "Stream instance associated with the socket." ;; ;;Iff an external-format was passed to `socket-connect' or `socket-listen' ;;the stream is a flexi-stream. Otherwise the stream is implementation ;;specific." )) (:documentation "Stream socket class. ' Contrary to other sockets, these sockets may be closed either with the `socket-close' method or by closing the associated stream (which can be retrieved with the `socket-stream' accessor).")) (defclass stream-server-usocket (usocket) ((element-type :initarg :element-type :initform #-lispworks 'character #+lispworks 'base-char :reader element-type :documentation "Default element type for streams created by `socket-accept'.")) (:documentation "Socket which listens for stream connections to be initiated from remote sockets.")) (defclass datagram-usocket (usocket) ((connected-p :type boolean :accessor connected-p :initarg :connected-p) #+(or cmu scl lispworks mcl (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.") #+(or lispworks mcl (and clisp ffi (not rawsock))) (recv-buffer :documentation "Private RECV buffer.") #+(or lispworks mcl) (send-buffer :documentation "Private SEND buffer.")) (:documentation "UDP (inet-datagram) socket")) (defun usocket-p (socket) (typep socket 'usocket)) (defun stream-usocket-p (socket) (typep socket 'stream-usocket)) (defun stream-server-usocket-p (socket) (typep socket 'stream-server-usocket)) (defun datagram-usocket-p (socket) (typep socket 'datagram-usocket)) (defun make-socket (&key socket) "Create a usocket socket type from implementation specific socket." (unless socket (error 'invalid-socket-error)) (make-stream-socket :socket socket)) (defun make-stream-socket (&key socket stream) "Create a usocket socket type from implementation specific socket and stream objects. Sockets returned should be closed using the `socket-close' method or by closing the stream associated with the socket. " (unless socket (error 'invalid-socket-error)) (unless stream (error 'invalid-socket-stream-error)) (make-instance 'stream-usocket :socket socket :stream stream)) (defun make-stream-server-socket (socket &key (element-type #-lispworks 'character #+lispworks 'base-char)) "Create a usocket-server socket type from an implementation-specific socket object. The returned value is a subtype of `stream-server-usocket'. " (unless socket (error 'invalid-socket-error)) (make-instance 'stream-server-usocket :socket socket :element-type element-type)) (defun make-datagram-socket (socket &key connected-p) (unless socket (error 'invalid-socket-error)) (make-instance 'datagram-usocket :socket socket :connected-p connected-p)) (defgeneric socket-accept (socket &key element-type) (:documentation "Accepts a connection from `socket', returning a `stream-socket'. The stream associated with the socket returned has `element-type' when explicitly specified, or the element-type passed to `socket-listen' otherwise.")) (defgeneric socket-close (usocket) (:documentation "Close a previously opened `usocket'.")) (defmethod socket-close :before ((usocket usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket))) ;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown-socket (defgeneric socket-shutdown (usocket direction) (:documentation "Shutdown communication on the socket in DIRECTION. After a shutdown no input and/or output of the indicated DIRECTION can be performed on the `usocket'. DIRECTION should be either :INPUT or :OUTPUT or :IO")) (defgeneric socket-send (usocket buffer length &key host port) (:documentation "Send packets through a previously opend `usocket'.")) (defgeneric socket-receive (usocket buffer length &key) (:documentation "Receive packets from a previously opend `usocket'. Returns 4 values: (values buffer size host port)")) (defgeneric get-local-address (socket) (:documentation "Returns the IP address of the socket.")) (defgeneric get-peer-address (socket) (:documentation "Returns the IP address of the peer the socket is connected to.")) (defgeneric get-local-port (socket) (:documentation "Returns the IP port of the socket. This function applies to both `stream-usocket' and `server-stream-usocket' type objects.")) (defgeneric get-peer-port (socket) (:documentation "Returns the IP port of the peer the socket to.")) (defgeneric get-local-name (socket) (:documentation "Returns the IP address and port of the socket as values. This function applies to both `stream-usocket' and `server-stream-usocket' type objects.")) (defgeneric get-peer-name (socket) (:documentation "Returns the IP address and port of the peer the socket is connected to as values.")) (defmacro with-connected-socket ((var socket) &body body) "Bind `socket' to `var', ensuring socket destruction on exit. `body' is only evaluated when `var' is bound to a non-null value. The `body' is an implied progn form." `(let ((,var ,socket)) (unwind-protect (when ,var (with-mapped-conditions (,var) ,@body)) (when ,var (socket-close ,var))))) (defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) &body body) "Bind the socket resulting from a call to `socket-connect' with the arguments `socket-connect-args' to `socket-var' and if `stream-var' is non-nil, bind the associated socket stream to it." `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) ,(if (null stream-var) `(progn ,@body) `(let ((,stream-var (socket-stream ,socket-var))) ,@body)))) (defmacro with-server-socket ((var server-socket) &body body) "Bind `server-socket' to `var', ensuring socket destruction on exit. `body' is only evaluated when `var' is bound to a non-null value. The `body' is an implied progn form." `(with-connected-socket (,var ,server-socket) ,@body)) (defmacro with-socket-listener ((socket-var &rest socket-listen-args) &body body) "Bind the socket resulting from a call to `socket-listen' with arguments `socket-listen-args' to `socket-var'." `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) ,@body)) (defstruct (wait-list (:constructor %make-wait-list)) %wait ;; implementation specific waiters ;; the list of all usockets map) ;; maps implementation sockets to usockets ;; Implementation specific: ;; ;; %setup-wait-list ;; %add-waiter ;; %remove-waiter (defun make-wait-list (waiters) (let ((wl (%make-wait-list))) (setf (wait-list-map wl) (make-hash-table)) (%setup-wait-list wl) (dolist (x waiters wl) ; wl is returned (add-waiter wl x)))) (defun add-waiter (wait-list input) (setf (gethash (socket input) (wait-list-map wait-list)) input (wait-list input) wait-list) (pushnew input (wait-list-waiters wait-list)) (%add-waiter wait-list input)) (defun remove-waiter (wait-list input) (%remove-waiter wait-list input) (setf (wait-list-waiters wait-list) (remove input (wait-list-waiters wait-list)) (wait-list input) nil) (remhash (socket input) (wait-list-map wait-list))) (defun remove-all-waiters (wait-list) (dolist (waiter (wait-list-waiters wait-list)) (%remove-waiter wait-list waiter)) (setf (wait-list-waiters wait-list) nil) (clrhash (wait-list-map wait-list))) (defun wait-for-input (socket-or-sockets &key timeout ready-only &aux (single-socket-p (usocket-p socket-or-sockets))) "Waits for one or more streams to become ready for reading from the socket. When `timeout' (a non-negative real number) is specified, wait `timeout' seconds, or wait indefinitely when it isn't specified. A `timeout' value of 0 (zero) means polling. Returns two values: the first value is the list of streams which are readable (or in case of server streams acceptable). NIL may be returned for this value either when waiting timed out or when it was interrupted (EINTR). The second value is a real number indicating the time remaining within the timeout period or NIL if none. Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in the original list you passed it. This prevents a new list from being consed up. Some users of USOCKET were reluctant to use it if it wouldn't behave that way, expecting it to cost significant performance to do the associated garbage collection. Without the READY-ONLY arg, you need to check the socket STATE slot for the values documented in usocket.lisp in the usocket class." ;; for NULL sockets, return NIL with respect of TIMEOUT. (when (null socket-or-sockets) (when timeout (sleep timeout)) (return-from wait-for-input nil)) ;; create a new wait-list if it's not created by the caller. (unless (wait-list-p socket-or-sockets) ;; OPTIMIZATION: in case socket-or-sockets is an atom, create the wait-list ;; only once and store it into the usocket itself. (let ((wl (if (and single-socket-p (wait-list socket-or-sockets)) (wait-list socket-or-sockets) ; reuse the per-usocket wait-list (make-wait-list (if (listp socket-or-sockets) socket-or-sockets (list socket-or-sockets)))))) (multiple-value-bind (sockets to-result) (wait-for-input wl :timeout timeout :ready-only ready-only) ;; in case of single socket, keep the wait-list (unless single-socket-p (remove-all-waiters wl)) (return-from wait-for-input (values (if ready-only sockets socket-or-sockets) to-result))))) (let* ((start (get-internal-real-time)) (sockets-ready 0)) (dolist (x (wait-list-waiters socket-or-sockets)) (when (setf (state x) #+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN #-(and win32 (or sbcl ecl)) (if (and (stream-usocket-p x) (listen (socket-stream x))) :read nil)) (incf sockets-ready))) ;; the internal routine is responsibe for ;; making sure the wait doesn't block on socket-streams of ;; which theready- socket isn't ready, but there's space left in the ;; buffer. socket-or-sockets is not destructed. (wait-for-input-internal socket-or-sockets :timeout (if (zerop sockets-ready) timeout 0)) (let ((to-result (when timeout (let ((elapsed (/ (- (get-internal-real-time) start) internal-time-units-per-second))) (when (< elapsed timeout) (- timeout elapsed)))))) ;; two return values: ;; 1) the original wait-list, or available sockets (ready-only) ;; 2) remaining timeout (values (cond (ready-only (cond (single-socket-p (if (null (state (car (wait-list-waiters socket-or-sockets)))) nil ; nothing left if the only socket is not waiting (wait-list-waiters socket-or-sockets))) (t (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)))) (t socket-or-sockets)) to-result)))) ;; ;; Data utility functions ;; (defun integer-to-octet-buffer (integer buffer octets &key (start 0)) (do ((b start (1+ b)) (i (ash (1- octets) 3) ;; * 8 (- i 8))) ((> 0 i) buffer) (setf (aref buffer b) (ldb (byte 8 i) integer)))) (defun octet-buffer-to-integer (buffer octets &key (start 0)) (let ((integer 0)) (do ((b start (1+ b)) (i (ash (1- octets) 3) ;; * 8 (- i 8))) ((> 0 i) integer) (setf (ldb (byte 8 i) integer) (aref buffer b))))) (defmacro port-to-octet-buffer (port buffer &key (start 0)) `(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 ,start)) (defmacro port-from-octet-buffer (buffer &key (start 0)) `(octet-buffer-to-integer ,buffer 2 :start ,start)) (defmacro ip-from-octet-buffer (buffer &key (start 0)) `(octet-buffer-to-integer ,buffer 4 :start ,start)) ;; ;; IPv4 utility functions ;; (defun list-of-strings-to-integers (list) "Take a list of strings and return a new list of integers (from parse-integer) on each of the string elements." (let ((new-list nil)) (dolist (element (reverse list)) (push (parse-integer element) new-list)) new-list)) (defun ip-address-string-p (string) "Return a true value if the given string could be an IP address." (every (lambda (char) (or (digit-char-p char) (eql char #\.))) string)) (defun hbo-to-dotted-quad (integer) ; exported "Host-byte-order integer to dotted-quad string conversion utility." (let ((first (ldb (byte 8 24) integer)) (second (ldb (byte 8 16) integer)) (third (ldb (byte 8 8) integer)) (fourth (ldb (byte 8 0) integer))) (format nil "~A.~A.~A.~A" first second third fourth))) (defun hbo-to-vector-quad (integer) ; exported "Host-byte-order integer to dotted-quad string conversion utility." (let ((first (ldb (byte 8 24) integer)) (second (ldb (byte 8 16) integer)) (third (ldb (byte 8 8) integer)) (fourth (ldb (byte 8 0) integer))) (vector first second third fourth))) (defun vector-quad-to-dotted-quad (vector) ; exported (format nil "~A.~A.~A.~A" (aref vector 0) (aref vector 1) (aref vector 2) (aref vector 3))) (defun dotted-quad-to-vector-quad (string) ; exported (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) (vector (first list) (second list) (third list) (fourth list)))) (defgeneric host-byte-order (address)) ; exported (defmethod host-byte-order ((string string)) "Convert a string, such as 192.168.1.1, to host-byte-order, such as 3232235777." (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) (+ (* (first list) 256 256 256) (* (second list) 256 256) (* (third list) 256) (fourth list)))) (defmethod host-byte-order ((vector vector)) ; IPv4 only "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as 3232235777." (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) (* (aref vector 2) 256) (aref vector 3))) (defmethod host-byte-order ((int integer)) int) ; this assume input integer is already host-byte-order ;; ;; IPv6 utility functions ;; (defun vector-to-ipv6-host (vector) ; exported (with-output-to-string (*standard-output*) (loop with zeros-collapsed-p with collapsing-zeros-p for i below 16 by 2 for word = (+ (ash (aref vector i) 8) (aref vector (1+ i))) do (cond ((and (zerop word) (not collapsing-zeros-p) (not zeros-collapsed-p)) (setf collapsing-zeros-p t)) ((or (not (zerop word)) zeros-collapsed-p) (when collapsing-zeros-p (write-string ":") (setf collapsing-zeros-p nil zeros-collapsed-p t)) (format t "~:[~;:~]~X" (plusp i) word))) finally (when collapsing-zeros-p (write-string "::"))))) (defun split-ipv6-address (string) (let ((pos 0) word double-colon-seen-p words-before-double-colon words-after-double-colon) (loop (multiple-value-setq (word pos) (parse-integer string :radix 16 :junk-allowed t :start pos)) (labels ((at-end-p () (= pos (length string))) (looking-at-colon-p () (char= (char string pos) #\:)) (ensure-colon () (unless (looking-at-colon-p) (error "unsyntactic IPv6 address string ~S, expected a colon at position ~D" string pos)) (incf pos))) (cond ((null word) (when double-colon-seen-p (error "unsyntactic IPv6 address string ~S, can only have one double-colon filler mark" string)) (setf double-colon-seen-p t)) (double-colon-seen-p (push word words-after-double-colon)) (t (push word words-before-double-colon))) (if (at-end-p) (return (list (nreverse words-before-double-colon) (nreverse words-after-double-colon))) (ensure-colon)))))) (defun ipv6-host-to-vector (string) ; exported (assert (> (length string) 2) () "Unsyntactic IPv6 address literal ~S, expected at least three characters" string) (destructuring-bind (words-before-double-colon words-after-double-colon) (split-ipv6-address (concatenate 'string (when (eql (char string 0) #\:) "0") string (when (eql (char string (1- (length string))) #\:) "0"))) (let ((number-of-words-specified (+ (length words-before-double-colon) (length words-after-double-colon)))) (assert (<= number-of-words-specified 8) () "Unsyntactic IPv6 address literal ~S, too many colon separated address components" string) (assert (or (= number-of-words-specified 8) words-after-double-colon) () "Unsyntactic IPv6 address literal ~S, too few address components and no double-colon filler found" string) (loop with vector = (make-array 16 :element-type '(unsigned-byte 8)) for i below 16 by 2 for word in (append words-before-double-colon (make-list (- 8 number-of-words-specified) :initial-element 0) words-after-double-colon) do (setf (aref vector i) (ldb (byte 8 8) word) (aref vector (1+ i)) (ldb (byte 8 0) word)) finally (return vector))))) ;; exported since 0.8.0 (defun host-to-hostname (host) ; host -> string "Translate a string, vector quad or 16 byte IPv6 address to a stringified hostname." (etypecase host (string host) ; IPv4 or IPv6 ((or (vector t 4) ; IPv4 (array (unsigned-byte 8) (4))) (vector-quad-to-dotted-quad host)) ((or (vector t 16) ; IPv6 (array (unsigned-byte 8) (16))) (vector-to-ipv6-host host)) (integer (hbo-to-dotted-quad host)) ; integer input is IPv4 only (null "0.0.0.0"))) ; null is IPv4 (defun ip= (ip1 ip2) ; exported (etypecase ip1 (string (string= ip1 ; IPv4 or IPv6 (host-to-hostname ip2))) ((or (vector t 4) ; IPv4 (array (unsigned-byte 8) (4)) ; IPv4 (vector t 16) ; IPv6 (array (unsigned-byte 8) (16))) ; IPv6 (equalp ip1 ip2)) (integer (= ip1 ; IPv4 only (host-byte-order ip2))))) ; convert ip2 to integer (hbo) (defun ip/= (ip1 ip2) ; exported (not (ip= ip1 ip2))) ;; ;; DNS helper functions ;; (defun get-host-by-name (name) "0.7.1+: if there're IPv4 addresses, return the first IPv4 address." (let* ((hosts (get-hosts-by-name name)) (pos (position-if #'(lambda (ip) (= 4 (length ip))) hosts))) (if pos (elt hosts pos) (car hosts)))) (defun get-random-host-by-name (name) "0.7.1+: if there're IPv4 addresses, only return a random IPv4 address." (let* ((hosts (get-hosts-by-name name)) (ipv4-hosts (remove-if-not #'(lambda (ip) (= 4 (length ip))) hosts))) (cond (ipv4-hosts (elt ipv4-hosts (random (length ipv4-hosts)))) (hosts (elt hosts (random (length hosts))))))) (defun host-to-vector-quad (host) ; internal "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? not sure 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) ; internal (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 ;; (defun split-timeout (timeout &optional (fractional 1000000)) "Split real value timeout into seconds and microseconds. Optionally, a different fractional part can be specified." (multiple-value-bind (secs sec-frac) (truncate timeout 1) (values secs (truncate (* fractional sec-frac) 1)))) ;; ;; Setting of documentation for backend defined functions ;; ;; Documentation for the function ;; ;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other-keys...) ..) ;; (setf (documentation 'socket-connect 'function) "Connect to `host' on `port'. `host' is assumed to be a string or an IP address represented in vector notation, such as #(192 168 1 1). `port' is assumed to be an integer. `element-type' specifies the element type to use when constructing the stream associated with the socket. The default is 'character. `nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedia.org/wiki/Nagle%27s_algorithm). If this parameter is omitted, the behaviour is inherited from the CL implementation (in most cases, Nagle's algorithm is enabled by default, but for example in ACL it is disabled). If the parameter is specified, one of these three values is possible: T - Disable Nagle's algorithm; signals an UNSUPPORTED condition if the implementation does not support explicit manipulation with that option. NIL - Leave Nagle's algorithm enabled on the socket; signals an UNSUPPORTED condition if the implementation does not support explicit manipulation with that option. :IF-SUPPORTED - Disables Nagle's algorithm if the implementation allows this, otherwises just ignore this option. Returns a usocket object.") ;; Documentation for the function ;; ;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) ;;###FIXME: extend with default-element-type (setf (documentation 'socket-listen 'function) "Bind to interface `host' on `port'. `host' should be the representation of an ready-interface address. The implementation is not required to do an address lookup, making no guarantees that hostnames will be correctly resolved. If `*wildcard-host*' or NIL is passed for `host', the socket will be bound to all available interfaces for the system. `port' can be selected by the IP stack by passing `*auto-port*'. Returns an object of type `stream-server-usocket'. `reuse-address' and `backlog' are advisory parameters for setting socket options at creation time. `element-type' is the element type of the 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)) usocket-0.8.3/vendor/000077500000000000000000000000001360013566400145005ustar00rootroot00000000000000usocket-0.8.3/vendor/OpenTransportUDP.lisp000066400000000000000000000143761360013566400205730ustar00rootroot00000000000000;;;-*-Mode: LISP; Package: CCL -*- ;; ;;; OpenTransportUDP.lisp ;;; Copyright 2012 Chun Tian (binghe) ;;; UDP extension to OpenTransport.lisp (with some TCP patches) (in-package "CCL") (eval-when (:compile-toplevel :load-toplevel :execute) (require :opentransport)) ;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface ;; see http://code.google.com/p/mcl/issues/detail?id=28 for details (defparameter *passive-interface-address* NIL "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream") (advise local-interface-ip-address (or *passive-interface-address* (:do-it)) :when :around :name 'override-local-interface-ip-address) ;; MCL Issue 29: Passive TCP connections on OS assigned ports ;; see http://code.google.com/p/mcl/issues/detail?id=29 for details (advise ot-conn-tcp-passive-connect (destructuring-bind (conn port &optional (allow-reuse t)) arglist (declare (ignore allow-reuse)) (if (eql port #$kOTAnyInetAddress) ;; Avoids registering a proxy for port 0 but instead registers one for the true port: (multiple-value-bind (proxy result) (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL (result (:do-it)) ;; pushes onto *opentransport-class-proxies* (proxy (prog1 (pop *opentransport-class-proxies*) (assert (not *opentransport-class-proxies*)))) (context (cdr proxy)) (tmpconn (make-ot-conn :context context :endpoint (pref context :ot-context.ref))) (localaddress (ot-conn-tcp-get-addresses tmpconn))) (declare (dynamic-extent tmpconn)) ;; replace original set in body of function (setf (ot-conn-local-address conn) localaddress) (values (cons localaddress context) result)) ;; need to be outside local binding of *opentransport-class-proxies* (without-interrupts (push proxy *opentransport-class-proxies*)) result) (:do-it))) :when :around :name 'ot-conn-tcp-passive-connect-any-address) (defun open-udp-socket (&key local-address local-port) (init-opentransport) (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist (err #$kOTNoError) (configptr (ot-cloned-configuration traps::$kUDPName))) (rlet ((errP :osstatus)) (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configptr 0 (%null-ptr) errP *null-ptr*) #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP) err (pref errP :osstatus)) (if (eql err #$kOTNoError) (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal (conn (make-ot-conn :context context :endpoint endpoint))) (macrolet ((check-ot-error-return (error-context) `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError) (values (ot-error err ,error-context))))) (setf (ot-conn-bindreq conn) #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) ) (check-ot-error-return :alloc) (setf (ot-conn-bindret conn) #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) ) (check-ot-error-return :alloc) (setf (ot-conn-options conn) #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP) #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*) ) (check-ot-error-return :alloc)) ;; BIND to local address (for UDP server) (when local-port ; local-address (let* ((host (or local-address (local-interface-ip-address))) (port (tcp-service-port-number local-port)) (localaddress `(:tcp ,host ,port)) (bindreq (ot-conn-bindreq conn)) (bindret (ot-conn-bindret conn))) (let* ((netbuf (pref bindreq :tbind.addr))) (declare (dynamic-extent netbuf)) (setf (pref netbuf :tnetbuf.len) (record-length :inetaddress) (pref bindreq :tbind.qlen) 5) ; arbitrary qlen (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host) (setf (pref context :ot-context.completed) nil) (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError) (ot-error err :bind))) (setf (ot-conn-local-address conn) localaddress))) conn) (ot-error err :create))))) (defun make-TUnitData (endpoint) "create the send/recv buffer for UDP sockets" (let ((err #$kOTNoError)) (rlet ((errP :osstatus)) (macrolet ((check-ot-error-return (error-context) `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError) (values (ot-error err ,error-context))))) (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$T_ALL errP) #+carbon-compat (#_OTAllocInContext endpoint #$T_UNITDATA #$T_ALL errP *null-ptr*))) (check-ot-error-return :alloc) udata))))) (defun send-message (conn data buffer size host port &optional (offset 0)) ;; prepare dest address (let ((addr (pref data :tunitdata.addr))) (declare (dynamic-extent addr)) (setf (pref addr :tnetbuf.len) (record-length :inetaddress)) (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host)) ;; prepare data buffer (let* ((udata (pref data :tunitdata.udata)) (outptr (pref udata :tnetbuf.buf))) (declare (dynamic-extent udata)) (%copy-ivector-to-ptr buffer offset outptr 0 size) (setf (pref udata :tnetbuf.len) size)) ;; send the packet (let* ((endpoint (ot-conn-endpoint conn)) (result (#_OTSndUData endpoint data))) (the fixnum result))) (defun receive-message (conn data buffer length) (let* ((endpoint (ot-conn-endpoint conn)) (err (#_OTRcvUData endpoint data *null-ptr*))) (if (eql err #$kOTNoError) (let* (;(addr (pref data :tunitdata.addr)) (udata (pref data :tunitdata.udata)) (inptr (pref udata :tnetbuf.buf)) (read-bytes (pref udata :tnetbuf.len)) (buffer (or buffer (make-array read-bytes :element-type '(unsigned-byte 8)))) (length (or length (length buffer))) (actual-size (min read-bytes length))) (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size) (values buffer actual-size 0 0)) ; TODO: retrieve address and port (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead usocket-0.8.3/vendor/kqueue.lisp000066400000000000000000000470241360013566400166770ustar00rootroot00000000000000;;;-*-Mode: LISP; Package: CCL -*- ;; ;; KQUEUE.LISP ;; ;; KQUEUE - BSD kernel event notification mechanism support for Common LISP. ;; Copyright (C) 2007 Terje Norderhaug ;; Released under LGPL - see . ;; Alternative licensing available upon request. ;; ;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous ;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code. ;; As a condition of your use of the module, you assume all risk of personal injury, death, or property ;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity. ;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change. ;; ;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned. ;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future. ;; ;; Email feedback and improvements to . ;; Updated versions will be available from . ;; ;; RELATED IMPLEMENTATIONS ;; There is another kevent.lisp for other platforms by Risto Laakso (merge?). ;; Also a Scheme kevent.ss by Jose Antonio Ortega. ;; ;; SEE ALSO: ;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf ;; http://developer.apple.com/samplecode/FileNotification/index.html ;; The Man page for kqueue() or kevent(). ;; PyKQueue - Python OO interface to KQueue. ;; LibEvent - an event notification library in C by Niels Provos. ;; Liboop - another abstract library in C on top of kevent or other kernel notification. #| HISTORY: 2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list. 2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2 2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2) 2009-Jul-19 terje uses kevent-error condition and strerror. 2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle. 2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility. 2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out. 2009-Jul-25 terje make-kevent function. |# #| IMPLEMENTATION NOTES: kevents are copied into and from the kernel, so the records don't have to be kept in the app! kevents does not work in OSX before 10.3. *kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs. Consider using sysctlbyname() to test for 64bit, combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops |# (in-package :ccl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #-ccl-5.2 ; has been added to MCL 5.2 (defmethod load-framework-bundle ((framework-name string) &key (load-executable t)) ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP ;; (C) 2003 Brendan Burns ;; Released under LGPL. (with-cfstrs ((framework framework-name)) (let ((err 0) (baseURL nil) (bundleURL nil) (result nil)) (rlet ((folder :fsref)) ;; Find the folder holding the bundle (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType t folder)) ;; if everything's cool, make a URL for it (when (zerop err) (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder)) (if (%null-ptr-p baseURL) (setf err #$coreFoundationUnknownErr))) ;; if everything's cool, make a URL for the bundle (when (zerop err) (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr) baseURL framework nil)) (if (%null-ptr-p bundleURL) (setf err #$coreFoundationUnknownErr))) ;; if everything's cool, load it (when (zerop err) (setf result (#_CFBundleCreate (%null-ptr) bundleURL)) (if (%null-ptr-p result) (setf err #$coreFoundationUnknownErr))) ;; if everything's cool, and the user wants it loaded, load it (when (and load-executable (zerop err)) (if (not (#_CFBundleLoadExecutable result)) (setf err #$coreFoundationUnknownErr))) ;; if there's an error, but we've got a pointer, free it and clear result (when (and (not (zerop err)) (not (%null-ptr-p result))) (#_CFRelease result) (setf result nil)) ;; free the URLs if there non-null (when (not (%null-ptr-p bundleURL)) (#_CFRelease bundleURL)) (when (not (%null-ptr-p baseURL)) (#_CFRelease baseURL)) ;; return pointer + error value (values result err))))) #+ignore (defun get-addr (bundle name) (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name))) (rlet ((buf :long)) (setf (%get-ptr buf) addr) (ash (%get-signed-long buf) -2)))) #-ccl-5.2 (defun lookup-function-in-bundle (name bundle &optional nil-if-not-found) (with-cfstrs ((str name)) (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str))) (if (%null-ptr-p addr) (unless nil-if-not-found (error "Couldn't resolve address of foreign function ~s" name)) (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here (setf (%get-ptr buf) addr) (ash (%get-signed-long buf) -2)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Convenient way to declare BSD system calls #+ignore (defparameter *system-bundle* #+ccl-5.2 (get-bundle-for-framework-name "System.framework") #-ccl-5.2 (let ((bundle (load-framework-bundle "System.framework"))) (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b))) bundle)) (defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name))))) ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles? `(progn (defloadvar ,fn (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework") #-ccl-5.2 (let ((bundle (load-framework-bundle "System.framework"))) (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b))) bundle))) (lookup-function-in-bundle ,name-string bundle))) ,(let ((args (do ((arglist arglist (cddr arglist)) (result)) ((not (cdr arglist)) (nreverse result)) (push (second arglist) result)))) `(defun ,name ,args (ppc-ff-call ,fn ,@arglist))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare-bundle-ff %system-kqueue "kqueue" :signed-fullword) ;; returns a file descriptor no! (defun system-kqueue () (let ((kq (%system-kqueue))) (if (= kq -1) (ecase (%system-errno) (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM (24 (error "The per-process descriptor table is full")) ; EMFILE (23 (error "The system file table is full"))) ; ENFILE kq))) (declare-bundle-ff %system-kevent "kevent" :unsigned-fullword kq :address ke :unsigned-fullword nke :address ko :unsigned-fullword nko :address timeout :signed-fullword) (declare-bundle-ff %system-open "open" :address name :unsigned-fullword mode :unsigned-fullword arg :signed-fullword) (declare-bundle-ff %system-close "close" :unsigned-fullword fd :signed-fullword) (declare-bundle-ff %system-errno* "__error" :signed-fullword) (declare-bundle-ff %system-strerror "strerror" :signed-fullword errno :address) (defun %system-errno () (%get-fixnum (%int-to-ptr (%system-errno*)))) ; (%system-errno) (defconstant $O-EVTONLY #x8000) ; (defconstant $O-NONBLOCK #x800 "Non blocking mode") (defun system-open (posix-namestring) "Low level open function, as in C, returns an fd number" (with-cstrs ((name posix-namestring)) (%system-open name $O-EVTONLY 0))) (defun system-close (fd) (%system-close fd)) (defrecord timespec (sec :unsigned-long) (usec :unsigned-long)) (defVar *kevent-record* nil) (def-ccl-pointers determine-64bit-kevents () (setf *kevent-record* (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6) :kevent32 :kevent64))) (defrecord :kevent32 (ident :unsigned-long) ; uintptr_t (filter :short) (flags :unsigned-short) (fflags :unsigned-long) (data :long) ; intptr_t (udata :pointer)) (defrecord :kevent64 (:variant ; uintptr_t ((ident64 :uint64)) ((ident :unsigned-long))) (filter :short) (flags :unsigned-short) (fflags :unsigned-long) (:variant ; intptr_t ((data64 :sint64)) ((data :long))) (:variant ; RMCL :pointer is 32bit ((udata64 :uint64)) ((udata :pointer)))) (defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*)) (ecase *kevent-record* (:kevent64 (make-record kevent64 :ident ident :filter filter :flags flags :fflags fflags :data data :udata udata)) (:kevent32 (make-record kevent32 :ident ident :filter filter :flags flags :fflags fflags :data data :udata udata)))) (defun kevent-rref (ke field) (ecase *kevent-record* (:kevent32 (ecase field (:ident (rref ke :kevent32.ident)) (:filter (rref ke :kevent32.filter)) (:flags (rref ke :kevent32.flags)) (:fflags (rref ke :kevent32.fflags)) (:data (rref ke :kevent32.data)) (:udata (rref ke :kevent32.udata)))) (:kevent64 (ecase field (:ident (rref ke :kevent64.ident)) (:filter (rref ke :kevent64.filter)) (:flags (rref ke :kevent64.flags)) (:fflags (rref ke :kevent64.fflags)) (:data (rref ke :kevent64.data)) (:udata (rref ke :kevent64.udata)))))) (defun kevent-filter (ke) (kevent-rref ke :filter)) (defun kevent-flags (ke) (kevent-rref ke :flags)) (defun kevent-data (ke) (kevent-rref ke :data)) ;; FILTER TYPES: (eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe (defconstant $kevent-read-filter -1 "Data available to read") (defconstant $kevent-write-filter -2 "Writing is possible") (defconstant $kevent-aio-filter -3 "AIO system call has been made") (defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor") (defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events") (defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process") (defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer") (defconstant $kevent-netdev-filter -8 "Event occured on a network device") (defconstant $kevent-filesystem-filter -9) ) ; eval-when ; FLAGS: (defconstant $kevent-add #x01) (defconstant $kevent-delete #x02) (defconstant $kevent-enable #x04) (defconstant $kevent-disable #x08) (defconstant $kevent-oneshot #x10) (defconstant $kevent-clear #x20) (defconstant $kevent-error #x4000) (defconstant $kevent-eof #x8000 "EV_EOF") ;; FFLAGS: (defconstant $kevent-file-delete #x01 "The file was unlinked from the file system") (defconstant $kevent-file-write #x02 "A write occurred on the file") (defconstant $kevent-file-extend #x04 "The file was extended") (defconstant $kevent-file-attrib #x08 "The file had its attributes changed") (defconstant $kevent-file-link #x10 "The link count on the file changed") (defconstant $kevent-file-rename #x20 "The file was renamed") (defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted") (defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke)) (defconstant $kevent-net-linkup #x01 "Link is up") (defconstant $kevent-net-linkdown #x02 "Link is down") (defconstant $kevent-net-linkinvalid #x04 "Link state is invalid") (defconstant $kevent-net-added #x08 "IP adress added") (defconstant $kevent-net-deleted #x10 "IP adress deleted") (define-condition kevent-error (simple-error) ((errno :initform NIL :initarg :errno) (ko :initform nil :type (or null kevent) :initarg :ko) (syserr :initform (%system-errno))) (:report (lambda (c s) (with-slots (errno ko syserr) c (format s "kevent system call error ~A [~A]" errno syserr) (when errno (format s "(~A)" (%get-cstring (%system-strerror errno)))) (when ko (format s " for ") (let ((*standard-output* s)) (print-record ko *kevent-record*))))))) (defun %kevent (kq &optional ke ko (timeout 0)) (check-type kq integer) (rlet ((&timeout :timespec :sec timeout :usec 1)) (let ((num (with-timer ;; does not seem to make a difference... (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout)))) ; "If an error occurs while processing an element of the changelist and there ; is enough room in the eventlist, then the event will be placed in the eventlist with ; EV_ERROR set in flags and the system error in data." (when (and ko (plusp (logand $kevent-error (kevent-flags ko)))) (error 'kevent-error :errno (kevent-data ko) :ko ko)) ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition." (when (= num -1) ;; hack - opentransport provides the constants for the errors documented for the call (case (%system-errno) (0 (error "kevent system call failed with an unspecified error")) ;; should not happen! (13 (error "The process does not have permission to register a filter")) (14 (error "There was an error reading or writing the kevent structure")) ; EFAULT (9 (error "The specified descriptor is invalid")) ; EBADF (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR (22 (error "The specified time limit or filter is invalid")) ; EINVAL (2 (error "The event could not be found to be modified or deleted")) ; ENOENT (12 (error "No memory was available to register the event")) ; ENOMEM (78 (error "The specified process to attach to does not exist"))) ; ESRCH ;; shouldn't get here... (errchk (%system-errno)) (error "error ~A" (%system-errno))) (unless (zerop num) (values ko num))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CLOS INTERFACE (defclass kqueue () ((kq :initform (system-kqueue) :documentation "file descriptor referencing the kqueue") (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table... (:documentation "A kernal event notification channel")) (defmethod initialize-instance :after ((q kqueue) &rest rest) (declare (ignore rest)) (terminate-when-unreachable q 'kqueue-close)) (defmethod kqueue-close ((q kqueue)) (with-slots (kq fds) q (when (or kq fds) ;; allow repeated close (system-close kq) (setf fds NIL) (setf kq NIL)))) (defmethod kqueue-poll ((q kqueue)) "Polls a kqueue for kevents" ;; may not have to be cleared, but just in case: (flet ((kqueue-poll2 (ko) (let ((result (with-slots (kq) q (without-interrupts (%kevent kq NIL ko))))) (when result (let ((type (kevent-filter result))) (ecase type (0 (values)) (#.$kevent-read-filter (values :read (kevent-rref result :ident) (kevent-rref result :flags) (kevent-rref result :fflags) (kevent-rref result :data) (kevent-rref result :udata))) (#.$kevent-write-filter :write) (#.$kevent-aio-filter :aio) (#.$kevent-vnode-filter (values :vnode (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds))) (kevent-rref result :flags) (kevent-rref result :fflags) (kevent-rref result :data) (kevent-rref result :udata))) (#.$kevent-filesystem-filter :filesystem))))))) (ecase *kevent-record* (:kevent64 (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr))) (kqueue-poll2 ko))) (:kevent32 (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr))) (kqueue-poll2 ko)))))) (defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr))) (let ((ke (make-kevent :ident ident :filter filter :flags flags :fflags fflags :data data :udata udata))) (with-slots (kq) q (without-interrupts (%kevent kq ke))))) (defmethod kqueue-vnode-subscribe ((q kqueue) pathname) "Makes the queue report an event when there is a change to a directory or file" (let* ((namestring (posix-namestring (full-pathname pathname))) (fd (system-open namestring))) (with-slots (fds) q (push (cons fd pathname) fds)) (kqueue-subscribe q :ident fd :filter $kevent-vnode-filter :flags (logior $kevent-add $kevent-clear) :fflags $kevent-file-all) namestring)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+test (defun kevent-d (pathname &optional (*standard-output* (fred))) "Report changes to a file or directory" (loop with kqueue = (make-instance 'kqueue) with sub = (kqueue-vnode-subscribe kqueue pathname) for i from 1 to 60 for result = (multiple-value-list (kqueue-poll kqueue)) unless (equal result '(NIL)) do (progn (format T "~A~%" result) (force-output)) ; do (process-allow-schedule) do (sleep 1) finally (write-line "Done") )) #| ; Report changes to this file in a fred window (save this document to see what happens): (process-run-function "kevent-d" #'kevent-d *loading-file-source-file* (fred)) ; Reports files added or removed from the directory of this file: (process-run-function "kevent-d" #'kevent-d (make-pathname :directory (pathname-directory *loading-file-source-file*)) (fred)) |# usocket-0.8.3/version.sexp000066400000000000000000000000101360013566400155600ustar00rootroot00000000000000"0.8.3"