usocket-0.6.3.2/0000755000076500000240000000000012530215367012460 5ustar binghestaffusocket-0.6.3.2/backend/0000755000076500000240000000000012530215354014043 5ustar binghestaffusocket-0.6.3.2/backend/abcl.lisp0000644000076500000240000004642012530215354015643 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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 $@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)) (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 :host-or-ip nil) (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))) (t nil)))))) ; neither a IPv4 nor IPv6 address?! (defun get-hosts-by-name (name) (with-mapped-conditions () (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 () (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 () (jcall $@bind/Socket/1 socket local-address)))) ;; connect to dest address (with-mapped-conditions () (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 () (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 () (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) (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 :before ((usocket usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket))) (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)))) ;;; 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) (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.6.3.2/backend/allegro.lisp0000644000076500000240000001775512530215354016400 0ustar binghestaff;;;; 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))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (typecase condition #+allegro (excl:socket-error (let ((usock-err (cdr (assoc (excl:stream-error-identifier condition) +allegro-identifier-error-map+)))) (if usock-err (error usock-err :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) (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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket)))) (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 () (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) (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 ((socket datagram-usocket) buffer length &key) (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (unsigned-byte 32) ; host (unsigned-byte 16))) ; port (with-mapped-conditions (socket) (let ((s (socket socket))) (socket:receive-from s length :buffer buffer :extract t)))) (defun get-host-by-address (address) (with-mapped-conditions () (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 () (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.6.3.2/backend/clisp.lisp0000644000076500000240000006174112530215354016057 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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 () (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) (posix:hostent-name hostent)))) (defun get-hosts-by-name (name) (with-mapped-conditions () (let ((hostent (posix:resolve-host-ipaddr name))) (mapcar #'host-to-vector-quad (posix:hostent-addr-list hostent))))) ;; 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)) #+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 handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." (let (error-keyword error-string) (typecase condition (ext:os-error (let ((errno (car (simple-condition-format-arguments condition)))) #+ffi (setq error-keyword (os:errno errno) error-string (os:strerror errno)))) (simple-error (let ((keyword (car (simple-condition-format-arguments condition)))) (setq error-keyword keyword) #+ffi (setq error-string (os:strerror keyword)))) (error (error 'unknown-error :real-error condition)) (condition (signal 'unknown-condition :real-condition condition))) (when error-keyword (let ((usocket-error (cdr (assoc error-keyword +clisp-error-map+ :test #'eq)))) (if usocket-error (if (subtypep usocket-error 'error) (error usocket-error :socket socket) (signal usocket-error :socket socket)) (error "Unknown OS error: ~A (~A)" error-string error-keyword)))))) (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) (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) (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 () (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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket)))) (defmethod socket-close ((usocket stream-server-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (socket:socket-server-close (socket usocket))) (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) (push (cons (socket waiter) 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)) (setf (cdr 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 (pop status-list)) (cdr (pop status-list)))) ((null x)) (when (member y '(T :INPUT)) (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)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket))) (declaim (inline get-socket-name)) (defun get-socket-name (socket function) (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in)))) (funcall function socket sockaddr) (let ((data (rawsock:sockaddr-data sockaddr))) (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2)) (port-from-octet-buffer data :start 0))))) (defmethod get-local-name ((usocket datagram-usocket)) (get-socket-name (socket usocket) 'rawsock:getsockname)) (defmethod get-peer-name ((usocket datagram-usocket)) (get-socket-name (socket usocket) 'rawsock:getpeername)) ) ; progn ;;; ;;; 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)) (when (wait-list usocket) (remove-waiter (wait-list usocket) 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.6.3.2/backend/clozure.lisp0000644000076500000240000000545212530215354016425 0ustar binghestaff;;;; 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 () (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 () (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) (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.6.3.2/backend/cmucl.lisp0000644000076500000240000002524212530215354016044 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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) (let ((usock-err (cdr (assoc err +cmucl-error-map+ :test #'member)))) (if usock-err (if (subtypep usock-err 'error) (error usock-err :socket socket) (signal usock-err :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)) "Dispatch correct usocket condition." (typecase condition (ext::socket-error (cmucl-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 (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) (apply #'ext:connect-to-inet-socket args)))) (if socket (let* ((stream (sys:make-fd-stream socket :input t :output t :element-type element-type :buffering :full)) ;;###FIXME the above line probably needs an :external-format (usocket (make-stream-socket :socket socket :stream stream))) usocket) (let ((err (unix:unix-errno))) (when err (cmucl-map-socket-error err))))) (:datagram (setf socket (if (and host port) (let ((args (list (host-to-hbo host) port protocol))) (when (and local-bind-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) (with-mapped-conditions (socket) (apply #'ext:connect-to-inet-socket args))) (if (or local-host-p local-port-p) (with-mapped-conditions (socket) (apply #'ext:create-inet-listener (nconc (list (or local-port 0) protocol) (when (and local-host-p (ip/= local-host *wildcard-host*)) (list :host (host-to-hbo local-host)))))) (with-mapped-conditions (socket) (ext:create-inet-socket protocol))))) (if socket (let ((usocket (make-datagram-socket socket :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 () (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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket)))) (defmethod socket-close ((usocket usocket)) "Close socket." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (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-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) (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)))) (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)))) (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.6.3.2/backend/ecl.lisp0000644000076500000240000001205212530215354015477 0ustar binghestaff;;;; -*- Mode: Lisp -*- ;;;; $Id$ ;;;; $URL$ ;;;; 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.6.3.2/backend/lispworks.lisp0000644000076500000240000010241712530215354016776 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; See LICENSE for licensing information. (in-package :usocket) (eval-when (:compile-toplevel :load-toplevel :execute) (require "comm") #+lispworks3 (error "LispWorks 3 is not supported by USOCKET any more.")) ;;; --------------------------------------------------------------------------- ;;; 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) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) (if usock-err (if (subtypep usock-err 'error) (error usock-err :socket socket) (signal usock-err :socket socket)) (error 'unknown-error :socket socket :real-error condition :errno errno)))) (defun handle-condition (condition &optional (socket 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)))))) (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") (fli:define-c-struct timeval (tv-sec :long) (tv-usec :long)) ;;; ssize_t ;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags, ;;; struct sockaddr *restrict address, socklen_t *restrict address_len); (fli:define-foreign-function (%recvfrom "recvfrom" :source) ((socket :int) (buffer (:pointer (:unsigned :byte))) (length :int) (flags :int) (address (:pointer (:struct comm::sockaddr))) (address-len (:pointer :int))) :result-type :int #+win32 :module #+win32 "ws2_32") ;;; ssize_t ;;; sendto(int socket, const void *buffer, size_t length, int flags, ;;; const struct sockaddr *dest_addr, socklen_t dest_len); (fli:define-foreign-function (%sendto "sendto" :source) ((socket :int) (buffer (:pointer (:unsigned :byte))) (length :int) (flags :int) (address (:pointer (:struct comm::sockaddr))) (address-len :int)) :result-type :int #+win32 :module #+win32 "ws2_32") #-win32 (defun set-socket-receive-timeout (socket-fd seconds) "Set socket option: RCVTIMEO, argument seconds can be a float number" (declare (type integer socket-fd) (type number seconds)) (multiple-value-bind (sec usec) (truncate seconds) (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) (fli:with-foreign-slots (tv-sec tv-usec) timeout (setf tv-sec sec tv-usec (truncate (* 1000000 usec))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) (fli:size-of '(:struct timeval)))) seconds))))) #+win32 (defun set-socket-receive-timeout (socket-fd seconds) "Set socket option: RCVTIMEO, argument seconds can be a float number. On win32, you must bind the socket before use this function." (declare (type integer socket-fd) (type number seconds)) (fli:with-dynamic-foreign-objects ((timeout :int)) (setf (fli:dereference timeout) (truncate (* 1000 seconds))) (if (zerop (comm::setsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :char)) (fli:size-of :int))) seconds))) #-win32 (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-receive-timeout (socket-fd) "Get socket option: RCVTIMEO, return value is a float number" (declare (type integer socket-fd)) (fli:with-dynamic-foreign-objects ((timeout :int) (len :int)) (comm::getsockopt socket-fd comm::*sockopt_sol_socket* *sockopt_so_rcvtimeo* (fli:copy-pointer timeout :type '(:pointer :void)) len) (float (/ (fli:dereference timeout) 1000)))) (defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname)) (declare (ignorable original-hostname)) #+(or lispworks4 lispworks5 lispworks6.0) (let ((server-addr (fli:allocate-dynamic-foreign-object :type '(:struct comm::sockaddr_in)))) (values (comm::initialize-sockaddr_in server-addr comm::*socket_af_inet* hostname service protocol) comm::*socket_af_inet* server-addr (fli:pointer-element-size server-addr))) #-(or lispworks4 lispworks5 lispworks6.0) (progn (when (stringp hostname) (setq hostname (comm:string-ip-address hostname)) (unless hostname (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address)))) (unless resolved-hostname (return-from initialize-dynamic-sockaddr :unknown-host)) (setq hostname resolved-hostname)))) (if (or (null hostname) (integerp hostname) (comm:ipv6-address-p hostname)) (let ((server-addr (fli:allocate-dynamic-foreign-object :type '(:struct comm::lw-sockaddr)))) (multiple-value-bind (error family) (comm::initialize-sockaddr_in server-addr hostname service protocol) (values error family server-addr (if (eql family comm::*socket_af_inet*) (fli:size-of '(:struct comm::sockaddr_in)) (fli:size-of '(:struct comm::sockaddr_in6)))))) :bad-host))) (defun open-udp-socket (&key local-address local-port read-timeout (address-family comm::*socket_af_inet*)) "Open a unconnected UDP socket. For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), for binding on random free unused port, set LOCAL-PORT to 0." ;; 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 nodelay-specified) 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")) #+(or lispworks4 lispworks5.0) ; < 5.1 (when (and nodelay-specified (not (eq nodelay :if-supported))) (unsupported 'nodelay 'socket-connect :minimum "LispWorks 5.1")) #+lispworks4 (when local-host (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) #+lispworks4 (when local-port (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) (ecase protocol (:stream (let ((hostname (host-to-hostname host)) (stream)) (setf stream (with-mapped-conditions () (comm:open-tcp-stream hostname port :element-type element-type #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 #-(and lispworks4 (not lispworks4.4)) :timeout timeout #-lispworks4 #-lispworks4 #-lispworks4 #-lispworks4 :local-address (when local-host (host-to-hostname local-host)) :local-port local-port #-(or lispworks4 lispworks5.0) ; >= 5.1 #-(or lispworks4 lispworks5.0) :nodelay nodelay))) (if stream (make-stream-socket :socket (comm:socket-stream-socket stream) :stream stream) ;; 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 () (connect-to-udp-server (host-to-hostname host) port :local-address (and local-host (host-to-hostname local-host)) :local-port local-port :read-timeout timeout)) (with-mapped-conditions () (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) :local-port local-port :read-timeout timeout))) :connected-p (and host port t)))) 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 () (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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (close (socket-stream usocket))) (defmethod socket-close ((usocket usocket)) (when (wait-list usocket) (remove-waiter (wait-list 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)) (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))) "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))))))) (defun receive-message (socket-fd message &optional buffer (length (length buffer)) &key read-timeout (max-buffer-size +max-datagram-packet-size+)) "Receive message from socket, read-timeout is a float number in seconds. This function will return 4 values: 1. receive buffer 2. number of receive bytes 3. remote address 4. remote port" (declare (type integer socket-fd) (type sequence buffer)) (let (old-timeout) (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)) (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 socket-receive ((socket datagram-usocket) buffer length &key timeout) (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (unsigned-byte 32) ; host (unsigned-byte 16))) ; port (multiple-value-bind (buffer size host port) (receive-message (socket socket) (slot-value socket 'recv-buffer) buffer length :read-timeout timeout) (values buffer size host port))) (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))) (defun lw-hbo-to-vector-quad (hbo) (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 () (mapcar #'lw-hbo-to-vector-quad (comm:get-host-entry name :fields '(:addresses))))) (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") (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-waiters 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 (sockets) (dolist (socket sockets) (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) 0 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.6.3.2/backend/mcl.lisp0000644000076500000240000002574512530215354015524 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;; MCL backend for USOCKET 0.4.1 ;; Terje Norderhaug , January 1, 2009 (in-package :usocket) (defun handle-condition (condition &optional socket) ; incomplete, needs to handle additional conditions (flet ((raise-error (&optional socket-condition) (if socket-condition (error socket-condition :socket socket) (error 'unknown-error :socket socket :real-error condition)))) (typecase condition (ccl:host-stopped-responding (raise-error 'host-down-error)) (ccl:host-not-responding (raise-error 'host-unreachable-error)) (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))))) (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 () (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 () (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 ccl::stream-close ((usocket usocket)) (socket-close usocket)) (defun get-hosts-by-name (name) (with-mapped-conditions () (list (hbo-to-vector-quad (ccl::get-host-address (host-to-hostname name)))))) (defun get-host-by-address (address) (with-mapped-conditions () (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) (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.6.3.2/backend/mocl.lisp0000644000076500000240000001250312530215354015667 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; See LICENSE for licensing information. (in-package :usocket) (defun handle-condition (condition &optional (socket 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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (rt::socket-shutdown usocket) (rt::c-fclose usocket)) (defmethod socket-close ((usocket stream-usocket)) "Close socket." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (close (socket-stream usocket))) ;; (defmethod socket-close :after ((socket datagram-usocket)) ;; (setf (%open-p socket) nil)) ;; (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.6.3.2/backend/openmcl.lisp0000644000076500000240000002411312530215354016372 0ustar binghestaff;;;; 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) (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 nil) (signal nameserver-error :host-or-ip nil)) (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 () (ecase protocol (:stream (let ((mcl-sock (openmcl-socket:make-socket :remote-host 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 () (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)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket)))) #-ipv6 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (with-mapped-conditions (usocket) (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 () (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) (defun get-hosts-by-name (name) (with-mapped-conditions () (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.6.3.2/backend/sbcl.lisp0000644000076500000240000007616512530215354015676 0ustar binghestaff;;;; -*- Mode: Lisp -*- ;;;; $Id$ ;;;; $URL$ ;;;; 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 ") #+: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 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 fd-setsize fdset-alloc fdset-zero fdset-set fdset-clr fdset-fd-isset)) (defun get-host-name () (ffi:c-inline () () :object "{ char *buf = 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; 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 (ffi:c-inline () () :int "errno" :one-liner t))) (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) #-ecl (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) #-ecl (sb-sys:io-timeout . timeout-error) #+sbcl (sb-ext:timeout . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error #-ecl #-ecl #-ecl (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) (sb-bsd-sockets:try-again-error . ns-try-again-condition) (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) (defun handle-condition (condition &optional (socket 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))) (when usock-error (error usock-error :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 (signal usock-cond :socket socket)))))) ;;; "The socket stream ends up with a bogus name as it is created before ;;; the socket is connected, making things harder to debug than they need ;;; to be." -- Nikodemus Siivola (defvar *dummy-stream* (let ((stream (make-broadcast-stream))) (close stream) stream)) ;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch ;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS ;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than ;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola #+(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 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)) #+ecl (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 ((socket (make-instance '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 (host-to-vector-quad (or local-host *wildcard-host*)) (or local-port *auto-port*))) (with-mapped-conditions (usocket) #+(and sbcl (not win32)) (labels ((connect () (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port))) (if timeout (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) (connect))) #+(or ecl (and sbcl win32)) (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port) ;; Now that we're connected make the stream. (setf (socket-stream usocket) (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering :full :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 (host-to-vector-quad (or local-host *wildcard-host*)) (or local-port *auto-port*))) (setf usocket (make-datagram-socket socket)) (when (and host port) (with-mapped-conditions (usocket) (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) 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* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) (ip #+sbcl (if (and host (not (eq host *wildcard-host*))) (host-to-vector-quad host) (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any)) #-sbcl (host-to-vector-quad host)) (sock (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (handler-case (with-mapped-conditions () (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)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (sb-bsd-sockets:socket-close (socket usocket)))) (defmethod socket-close ((usocket stream-usocket)) (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket)))) (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) (with-mapped-conditions (usocket) (let* ((s (socket usocket)) (dest (if (and host port) (list (host-to-vector-quad host) 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 ((socket datagram-usocket) buffer length &key (element-type '(unsigned-byte 8))) (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer (integer 0) ; size (unsigned-byte 32) ; host (unsigned-byte 16))) ; port (with-mapped-conditions (socket) (let ((s (socket socket))) (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) (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 () (sb-bsd-sockets::host-ent-name (sb-bsd-sockets:get-host-by-address address)))) (defun get-hosts-by-name (name) (with-mapped-conditions () (sb-bsd-sockets::host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) #+(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)) (multiple-value-bind (count err) (sb-unix:unix-fast-select (1+ (reduce #'max (wait-list-%wait sockets) :key #'sb-bsd-sockets:socket-file-descriptor)) (sb-alien:addr rfds) nil nil (when timeout secs) (when timeout musecs)) (if (null count) (unless (= err sb-unix:EINTR) (error (map-errno-error err))) (when (< 0 count) ;; 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-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 (truncate (* 1000 timeout)) nil))) (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+) (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)) (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 (sockets) (dolist (socket sockets) (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) 0 (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 ecl (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) (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 ecl 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 (sockets) (dolist (socket sockets) (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) "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) (truncate (* 1000 timeout))) (: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.6.3.2/backend/scl.lisp0000644000076500000240000002347412530215354015527 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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)) "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." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (ext:close-socket (socket usocket)))) (defmethod socket-close ((usocket stream-usocket)) "Close socket." (when (wait-list usocket) (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket)))) (defmethod socket-close :after ((socket datagram-usocket)) (setf (%open-p socket) nil)) (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.6.3.2/CHANGES0000644000076500000240000001315512530215354013454 0ustar binghestaff0.6.3: * 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: * 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: * 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: * 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: * 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: * 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: * 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: * 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 IP6 addresses. * Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added. 0.5.1: * 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: * 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 [TODO] * New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide * New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. usocket-0.6.3.2/condition.lisp0000644000076500000240000002041212530215354015332 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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 ()) (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) &body body) `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket)))) ,@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.6.3.2/doc/0000755000076500000240000000000012530215354013221 5ustar binghestaffusocket-0.6.3.2/doc/backends.txt0000644000076500000240000000223612530215354015537 0ustar binghestaff -*- 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.6.3.2/doc/design.txt0000644000076500000240000000736612530215354015247 0ustar binghestaff -*- 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.6.3.2/LICENSE0000644000076500000240000000226212530215354013463 0ustar binghestaff(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 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.6.3.2/notes/0000755000076500000240000000000012530215354013604 5ustar binghestaffusocket-0.6.3.2/notes/abcl-socket.txt0000644000076500000240000000062212530215354016534 0ustar binghestaff 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.6.3.2/notes/active-sockets-apis.txt0000644000076500000240000000226612530215354020231 0ustar binghestaff -*- 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.6.3.2/notes/address-apis.txt0000644000076500000240000000323012530215354016722 0ustar binghestaff -*- 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.6.3.2/notes/allegro-socket.txt0000644000076500000240000000263612530215354017267 0ustar binghestaff (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.6.3.2/notes/clisp-sockets.txt0000644000076500000240000000271012530215354017130 0ustar binghestaffhttp://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.6.3.2/notes/cmucl-sockets.txt0000644000076500000240000000235412530215354017125 0ustar binghestaffhttp://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.6.3.2/notes/errors.txt0000644000076500000240000000140412530215354015660 0ustar binghestaffEADDRINUSE 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.6.3.2/notes/lw-sockets.txt0000644000076500000240000000152612530215354016444 0ustar binghestaff $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.6.3.2/notes/openmcl-sockets.txt0000644000076500000240000000132612530215354017455 0ustar binghestaffhttp://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.6.3.2/notes/sb-bsd-sockets.txt0000644000076500000240000000666612530215354017206 0ustar binghestaffhttp://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.6.3.2/notes/usock-sockets.txt0000644000076500000240000000151612530215354017145 0ustar binghestaffPackage: 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.6.3.2/option.lisp0000644000076500000240000001652312530215354014664 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; SOCKET-OPTION, a high-level socket option get/set framework ;;;; See LICENSE for licensing information. (in-package :usocket) ;;; Small utility functions (declaim (inline bool->int) (inline int->bool)) (defun bool->int (bool) (if bool 1 0)) (defun int->bool (int) (= 1 int)) ;;; Interface definition (defgeneric socket-option (socket option &key) (: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)) #+ecl (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)) #+ecl (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: 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) (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) (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 #+ecl () ; 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 #+ecl () ; TODO #+lispworks () ; TODO #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) #+scl () ; TODO new-value)) ;;; Socket option: TCP-NO-DELAY (TCP_NODELAY), for TCP client (defmethod socket-option ((usocket stream-usocket) (option (eql :tcp-no-delay)) &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 () #+ecl (sb-bsd-sockets::sockopt-tcp-nodelay socket) #+lispworks () ; TODO #+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 (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 () #+ecl (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) #+lispworks (comm::set-socket-tcp-nodelay socket new-value) #+mcl () ; TODO #+mocl () ; unknown #+sbcl (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) #+scl () ; TODO new-value)) usocket-0.6.3.2/package.lisp0000644000076500000240000000526412530215354014747 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; See the LICENSE file for licensing information. (defpackage :usocket (:use :common-lisp #+abcl :java) (:export #:*version* #:*wildcard-host* #:*auto-port* #:*remote-host* ; special variables (udp) #:*remote-port* #:+max-datagram-packet-size+ #:socket-connect ; socket constructors and methods #:socket-listen #:socket-accept #:socket-close #: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) #:socket-server ; udp server #:socket-option ; 0.6.x #: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 ;; 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)) usocket-0.6.3.2/README.md0000644000076500000240000001256312530215354013742 0ustar binghestaff# Introduction 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: - SBCL - CMUCL - ArmedBear Common Lisp - GNU CLISP - Allegro Common Lisp - LispWorks - Clozure CL - ECL - Scieneer Common Lisp - Macintosh Common Lisp - MOCL 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 ## 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 http://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.6.3.2/server.lisp0000644000076500000240000001120612530215354014653 0ustar binghestaff;;;; $Id$ ;;;; $URL$ (in-package :usocket) (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 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 (spawn-thread (or name "USOCKET Server") #'real-call) 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)) (terpri stream)) (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 (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments) (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.6.3.2/test/0000755000076500000240000000000012530215354013433 5ustar binghestaffusocket-0.6.3.2/test/package.lisp0000644000076500000240000000033712530215354015722 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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.6.3.2/test/test-condition.lisp0000644000076500000240000000126212530215354017270 0ustar binghestaff;;;; $Id$ ;;;; $URL$ (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.6.3.2/test/test-datagram.lisp0000644000076500000240000000645112530215354017067 0ustar binghestaff(in-package :usocket-test) (defvar *echo-server*) (defvar *echo-server-port*) (defun start-server () (multiple-value-bind (thread socket) (usocket:socket-server "127.0.0.1" 0 #'identity nil :in-new-thread t :protocol :datagram) (setq *echo-server* thread *echo-server-port* (usocket:get-local-port socket)))) (defparameter *max-buffer-size* 32) (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 (usocket:socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) (usocket:socket-send s *send-buffer* 5) (usocket:wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) ;;; UDP Send Test #2: unconnected socket (deftest udp-send.2 (progn (unless (and *echo-server* *echo-server-port*) (start-server)) (let ((s (usocket:socket-connect nil nil :protocol :datagram))) (clean-buffers) (replace *send-buffer* #(1 2 3 4 5)) (usocket:socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*) (usocket:wait-for-input s :timeout 3) (multiple-value-bind (buffer size host port) (usocket:socket-receive s *receive-buffer* *max-buffer-size*) (declare (ignore buffer size host port)) (reduce #'+ *receive-buffer* :start 0 :end 5)))) 15) (deftest mark-h-david ; Mark H. David's remarkable UDP test code (let* ((host "localhost") (port 1111) (server-sock (usocket:socket-connect nil nil :protocol ':datagram :local-host host :local-port port)) (client-sock (usocket: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)))) (usocket:socket-send client-sock octet-vector 2) (usocket:socket-receive server-sock recv-octet-vector 2) (prog1 (and (equalp octet-vector recv-octet-vector) recv-octet-vector) (usocket:socket-close server-sock) (usocket:socket-close client-sock))) #(79 75)) (deftest frank-james ; Frank James' test code for LispWorks/UDP (with-caught-conditions (#+win32 USOCKET:CONNECTION-RESET-ERROR #-win32 USOCKET:CONNECTION-REFUSED-ERROR nil) (let ((sock (usocket:socket-connect "localhost" 1234 :protocol ':datagram :element-type '(unsigned-byte 8)))) (unwind-protect (progn (usocket: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))) (usocket:socket-receive sock buffer 16))) (usocket:socket-close sock)))) nil) usocket-0.6.3.2/test/test-usocket.lisp0000644000076500000240000001247012530215354016762 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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* #.(first (usocket::get-hosts-by-name "common-lisp.net")))) (defvar *local-ip*) (defmacro with-caught-conditions ((expect throw) &body body) `(catch 'caught-error (handler-case (handler-bind ((usocket:unsupported #'(lambda (c) (declare (ignore c)) (continue)))) (progn ,@body)) (usocket: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))) (usocket: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 (usocket:socket *fake-usocket*) :my-socket) (deftest make-socket.2 (usocket:socket-stream *fake-usocket*) :my-stream) (deftest socket-no-connect.1 (with-caught-conditions (usocket:socket-error nil) (usocket:socket-connect "127.0.0.0" +unused-local-port+ :timeout 1) t) nil) (deftest socket-no-connect.2 (with-caught-conditions (usocket:socket-error nil) (usocket:socket-connect #(127 0 0 0) +unused-local-port+ :timeout 1) t) nil) (deftest socket-no-connect.3 (with-caught-conditions (usocket:socket-error nil) (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) t) nil) (deftest socket-failure.1 (with-caught-conditions (usocket:timeout-error nil) (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0) :unreach) nil) (deftest socket-failure.2 (with-caught-conditions (usocket:timeout-error nil) (usocket: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 (usocket:socket-connect "common-lisp.net" 80))) (unwind-protect (when (typep sock 'usocket:usocket) t) (usocket:socket-close sock)))) t) (deftest socket-connect.2 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (when (typep sock 'usocket:usocket) t) (usocket:socket-close sock)))) t) (deftest socket-connect.3 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect (usocket::host-byte-order *common-lisp-net*) 80))) (unwind-protect (when (typep sock 'usocket:usocket) t) (usocket: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 (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)) (subseq (read-line (usocket:socket-stream sock)) 0 15)) (usocket:socket-close sock)))) "HTTP/1.1 200 OK") (deftest socket-name.1 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (usocket::get-peer-address sock) (usocket:socket-close sock)))) #.*common-lisp-net*) (deftest socket-name.2 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (usocket::get-peer-port sock) (usocket:socket-close sock)))) 80) (deftest socket-name.3 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (usocket::get-peer-name sock) (usocket:socket-close sock)))) #.*common-lisp-net* 80) #+ignore (deftest socket-name.4 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect *common-lisp-net* 80))) (unwind-protect (equal (usocket::get-local-address sock) *local-ip*) (usocket:socket-close sock)))) t) (defun run-usocket-tests () (do-tests)) usocket-0.6.3.2/test/wait-for-input.lisp0000644000076500000240000001160412530215354017213 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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 15)) (usocket:socket-close sock)))) "HTTP/1.1 200 OK") ;;; 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.6.3.2/TODO0000644000076500000240000000026312530215354013145 0ustar binghestaff- 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.6.3.2/usocket-test.asd0000644000076500000240000000146112530215354015601 0ustar binghestaff;;;; -*- Mode: Lisp -*- ;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $ ;;;; $URL: svn+ssh://common-lisp.net/project/usocket/svn/usocket/trunk/test/usocket-test.asd $ ;;;; See the LICENSE file for licensing information. (defsystem usocket-test :name "usocket test" :author "Erik Enge" :maintainer "Chun Tian (binghe)" :version "0.2.0" :licence "MIT" :description "Tests for usocket" :depends-on (:usocket :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.6.3.2/usocket.asd0000644000076500000240000000267512530215354014634 0ustar binghestaff;;;; -*- Mode: Lisp -*- ;;;; ;;;; See the LICENSE file for licensing information. (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" :maintainer "Chun Tian (binghe) & Hans Huebner" :version "0.6.3.2" :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (#+(or sbcl ecl) :sb-bsd-sockets) :components ((:file "package") (:module "vendor" :depends-on ("package") :components (#+mcl (:file "kqueue") #+mcl (:file "OpenTransportUDP") (:file "spawn-thread") (:file "split-sequence"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition") :components (#+abcl (:file "abcl") #+(or allegro cormanlisp) (:file "allegro") #+clisp (:file "clisp") #+clozure (:file "clozure" :depends-on ("openmcl")) #+cmu (:file "cmucl") #+ecl (:file "ecl" :depends-on ("sbcl")) #+lispworks (:file "lispworks") #+mcl (:file "mcl") #+mocl (:file "mocl") #+openmcl (:file "openmcl") #+(or ecl sbcl) (:file "sbcl") #+scl (:file "scl"))) (:file "option" :depends-on ("backend")) (:file "server" :depends-on ("backend" "option")))) (defmethod perform ((op test-op) (c (eql (find-system :usocket)))) (oos 'load-op :usocket-test) (oos 'test-op :usocket-test)) usocket-0.6.3.2/usocket.lisp0000644000076500000240000005705712530215354015040 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; 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))) (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.")) (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'.")) (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) (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) "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." (unless (wait-list-p socket-or-sockets) (let ((wl (make-wait-list (if (listp socket-or-sockets) socket-or-sockets (list socket-or-sockets))))) (multiple-value-bind (socks to) (wait-for-input wl :timeout timeout :ready-only ready-only) (return-from wait-for-input (values (if ready-only socks socket-or-sockets) to))))) (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 (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)))))) (values (if ready-only (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state) 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) "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) "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) (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) (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) (vector (first list) (second list) (third list) (fourth list)))) (defgeneric host-byte-order (address)) (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)) "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) ;; ;; IPv6 utility functions ;; (defun vector-to-ipv6-host (vector) (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) (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))))) (defun host-to-hostname (host) "Translate a string, vector quad or 16 byte IPv6 address to a stringified hostname." (etypecase host (string host) ((or (vector t 4) (array (unsigned-byte 8) (4))) (vector-quad-to-dotted-quad host)) ((or (vector t 16) (array (unsigned-byte 8) (16))) (vector-to-ipv6-host host)) (integer (hbo-to-dotted-quad host)) (null "0.0.0.0"))) (defun ip= (ip1 ip2) (etypecase ip1 (string (string= ip1 (host-to-hostname ip2))) ((or (vector t 4) (array (unsigned-byte 8) (4)) (vector t 16) (array (unsigned-byte 8) (16))) (equalp ip1 ip2)) (integer (= ip1 (host-byte-order ip2))))) (defun ip/= (ip1 ip2) (not (ip= ip1 ip2))) ;; ;; DNS helper functions ;; (defun get-host-by-name (name) (let ((hosts (get-hosts-by-name name))) (car hosts))) (defun get-random-host-by-name (name) (let ((hosts (get-hosts-by-name name))) (when hosts (elt hosts (random (length hosts)))))) (defun host-to-vector-quad (host) "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." (etypecase host (string (let* ((ip (when (ip-address-string-p host) (dotted-quad-to-vector-quad host)))) (if (and ip (= 4 (length ip))) ;; valid IP dotted quad? ip (get-random-host-by-name host)))) ((or (vector t 4) (array (unsigned-byte 8) (4))) host) (integer (hbo-to-vector-quad host)))) (defun host-to-hbo (host) (etypecase host (string (let ((ip (when (ip-address-string-p host) (dotted-quad-to-vector-quad host)))) (if (and ip (= 4 (length ip))) (host-byte-order ip) (host-to-hbo (get-host-by-name host))))) ((or (vector t 4) (array (unsigned-byte 8) (4))) (host-byte-order host)) (integer host))) ;; ;; 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 parmeter 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. ") usocket-0.6.3.2/vendor/0000755000076500000240000000000012530215354013751 5ustar binghestaffusocket-0.6.3.2/vendor/kqueue.lisp0000644000076500000240000004702412530215354016150 0ustar binghestaff;;;-*-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.6.3.2/vendor/OpenTransportUDP.lisp0000644000076500000240000001437612530215354020044 0ustar binghestaff;;;-*-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.6.3.2/vendor/spawn-thread.lisp0000644000076500000240000000462612530215354017247 0ustar binghestaff;;;; $Id$ ;;;; $URL$ ;;;; SPWAN-THREAD from GBBopen's PortableThreads.lisp (in-package :usocket) #+(and digitool ccl-5.1) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew ':digitool-mcl *features*)) ;;; --------------------------------------------------------------------------- ;;; Add clozure feature to legacy OpenMCL: #+(and openmcl (not clozure)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew ':clozure *features*)) ;;; =========================================================================== ;;; Features & warnings #+(or (and clisp (not mt)) cormanlisp (and cmu (not mp)) (and ecl (not threads)) gcl mocl (and sbcl (not sb-thread))) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew ':threads-not-available *features*)) ;;; --------------------------------------------------------------------------- #+threads-not-available (defun threads-not-available (operation) (warn "Threads are not available in ~a running on ~a; ~s was used." (lisp-implementation-type) (machine-type) operation)) ;;; =========================================================================== ;;; Spawn-Thread (defun spawn-thread (name function &rest args) #-(or (and cmu mp) cormanlisp (and sbcl sb-thread)) (declare (dynamic-extent args)) #+abcl (threads:make-thread #'(lambda () (apply function args)) :name name) #+allegro (apply #'mp:process-run-function name function args) #+(and clisp mt) (mt:make-thread #'(lambda () (apply function args)) :name name) #+clozure (apply #'ccl:process-run-function name function args) #+(and cmu mp) (mp:make-process #'(lambda () (apply function args)) :name name) #+digitool-mcl (apply #'ccl:process-run-function name function args) #+(and ecl threads) (apply #'mp:process-run-function name function args) #+lispworks (apply #'mp:process-run-function name nil function args) #+(and sbcl sb-thread) (sb-thread:make-thread #'(lambda () (apply function args)) :name name) #+scl (mp:make-process #'(lambda () (apply function args)) :name name) #+abcl (threads:make-thread #'(lambda () (apply function args)) :name name) #+threads-not-available (declare (ignore name function args)) #+threads-not-available (threads-not-available 'spawn-thread)) usocket-0.6.3.2/vendor/split-sequence.lisp0000644000076500000240000002274712530215354017617 0ustar binghestaff;;;; SPLIT-SEQUENCE ;;; ;;; This code was based on Arthur Lemmens' in ;;; ; ;;; ;;; changes include: ;;; ;;; * altering the behaviour of the :from-end keyword argument to ;;; return the subsequences in original order, for consistency with ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only ;;; affects the answer if :count is less than the number of ;;; subsequences, by analogy with the above-referenced functions). ;;; ;;; * changing the :maximum keyword argument to :count, by analogy ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. ;;; ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather ;;; than SPLIT. ;;; ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. ;;; ;;; * The second return value is now an index rather than a copy of a ;;; portion of the sequence; this index is the `right' one to feed to ;;; CL:SUBSEQ for continued processing. ;;; There's a certain amount of code duplication here, which is kept ;;; to illustrate the relationship between the SPLIT-SEQUENCE ;;; functions and the CL:POSITION functions. ;;; Examples: ;;; ;;; * (split-sequence #\; "a;;b;c") ;;; -> ("a" "" "b" "c"), 6 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t) ;;; -> ("a" "" "b" "c"), 0 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) ;;; -> ("c"), 4 ;;; ;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) ;;; -> ("a" "b" "c"), 6 ;;; ;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 ;;; ;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("ab" "a" "a" "ab" "a"), 11 ;;; ;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) ;;; -> ("oo" "bar" "b"), 9 #+ignore ; comment by usocket (defpackage "SPLIT-SEQUENCE" (:use "CL") (:nicknames "PARTITION") (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) (in-package :usocket #+ignore "SPLIT-SEQUENCE") (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) "Return a list of subsequences in seq delimited by delimiter. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (nconc (when test-supplied (list :test test)) (when test-not-supplied (list :test-not test-not)) (when key-supplied (list :key key))))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position delimiter seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position delimiter seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying predicate. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying (CL:COMPLEMENT predicate). If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if-not predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if-not predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) ;;; clean deprecation (defun partition (&rest args) (apply #'split-sequence args)) (defun partition-if (&rest args) (apply #'split-sequence-if args)) (defun partition-if-not (&rest args) (apply #'split-sequence-if-not args)) (define-compiler-macro partition (&whole form &rest args) (declare (ignore args)) (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") form) (define-compiler-macro partition-if (&whole form &rest args) (declare (ignore args)) (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") form) (define-compiler-macro partition-if-not (&whole form &rest args) (declare (ignore args)) (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") form) #+ignore ; comment by usocket (pushnew :split-sequence *features*)