ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sbcl stuff

Browse source
This commit is contained in:
Ian Keane 2020-01-20 14:13:08 -05:00
parent 1d1dbc34df
commit 5d91dbb667
335 changed files with 119806 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

1
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
*~

436
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/abcl.lisp Normal file
View file

@ -0,0 +1,436 @@
;;;; New ABCL networking support (replacement to old armedbear.lisp)
;;;; Author: Chun Tian (binghe)
;;;; See LICENSE for licensing information.
(in-package :usocket)
;;; Java Classes ($*...)
(defvar $*boolean (jclass "boolean"))
(defvar $*byte (jclass "byte"))
(defvar $*byte[] (jclass "[B"))
(defvar $*int (jclass "int"))
(defvar $*long (jclass "long"))
(defvar $*|Byte| (jclass "java.lang.Byte"))
(defvar $*DatagramChannel (jclass "java.nio.channels.DatagramChannel"))
(defvar $*DatagramPacket (jclass "java.net.DatagramPacket"))
(defvar $*DatagramSocket (jclass "java.net.DatagramSocket"))
(defvar $*Inet4Address (jclass "java.net.Inet4Address"))
(defvar $*InetAddress (jclass "java.net.InetAddress"))
(defvar $*InetSocketAddress (jclass "java.net.InetSocketAddress"))
(defvar $*Iterator (jclass "java.util.Iterator"))
(defvar $*SelectableChannel (jclass "java.nio.channels.SelectableChannel"))
(defvar $*SelectionKey (jclass "java.nio.channels.SelectionKey"))
(defvar $*Selector (jclass "java.nio.channels.Selector"))
(defvar $*ServerSocket (jclass "java.net.ServerSocket"))
(defvar $*ServerSocketChannel (jclass "java.nio.channels.ServerSocketChannel"))
(defvar $*Set (jclass "java.util.Set"))
(defvar $*Socket (jclass "java.net.Socket"))
(defvar $*SocketAddress (jclass "java.net.SocketAddress"))
(defvar $*SocketChannel (jclass "java.nio.channels.SocketChannel"))
(defvar $*String (jclass "java.lang.String"))
;;; Java Constructor ($%.../n)
(defvar $%Byte/0 (jconstructor $*|Byte| $*byte))
(defvar $%DatagramPacket/3 (jconstructor $*DatagramPacket $*byte[] $*int $*int))
(defvar $%DatagramPacket/5 (jconstructor $*DatagramPacket $*byte[] $*int $*int $*InetAddress $*int))
(defvar $%DatagramSocket/0 (jconstructor $*DatagramSocket))
(defvar $%DatagramSocket/1 (jconstructor $*DatagramSocket $*int))
(defvar $%DatagramSocket/2 (jconstructor $*DatagramSocket $*int $*InetAddress))
(defvar $%InetSocketAddress/1 (jconstructor $*InetSocketAddress $*int))
(defvar $%InetSocketAddress/2 (jconstructor $*InetSocketAddress $*InetAddress $*int))
(defvar $%ServerSocket/0 (jconstructor $*ServerSocket))
(defvar $%ServerSocket/1 (jconstructor $*ServerSocket $*int))
(defvar $%ServerSocket/2 (jconstructor $*ServerSocket $*int $*int))
(defvar $%ServerSocket/3 (jconstructor $*ServerSocket $*int $*int $*InetAddress))
(defvar $%Socket/0 (jconstructor $*Socket))
(defvar $%Socket/2 (jconstructor $*Socket $*InetAddress $*int))
(defvar $%Socket/4 (jconstructor $*Socket $*InetAddress $*int $*InetAddress $*int))
;;; Java Methods ($@...[/Class]/n)
(defvar $@accept/0 (jmethod $*ServerSocket "accept"))
(defvar $@bind/DatagramSocket/1 (jmethod $*DatagramSocket "bind" $*SocketAddress))
(defvar $@bind/ServerSocket/1 (jmethod $*ServerSocket "bind" $*SocketAddress))
(defvar $@bind/ServerSocket/2 (jmethod $*ServerSocket "bind" $*SocketAddress $*int))
(defvar $@bind/Socket/1 (jmethod $*Socket "bind" $*SocketAddress))
(defvar $@byteValue/0 (jmethod $*|Byte| "byteValue"))
(defvar $@channel/0 (jmethod $*SelectionKey "channel"))
(defvar $@close/DatagramSocket/0 (jmethod $*DatagramSocket "close"))
(defvar $@close/Selector/0 (jmethod $*Selector "close"))
(defvar $@close/ServerSocket/0 (jmethod $*ServerSocket "close"))
(defvar $@close/Socket/0 (jmethod $*Socket "close"))
(defvar $@shutdownInput/Socket/0 (jmethod $*Socket "shutdownInput"))
(defvar $@shutdownOutput/Socket/0 (jmethod $*Socket "shutdownOutput"))
(defvar $@configureBlocking/1 (jmethod $*SelectableChannel "configureBlocking" $*boolean))
(defvar $@connect/DatagramChannel/1 (jmethod $*DatagramChannel "connect" $*SocketAddress))
(defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress))
(defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int))
(defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress))
(defvar $@getAddress/0 (jmethod $*InetAddress "getAddress"))
(defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String))
(defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String))
(defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel"))
(defvar $@getChannel/ServerSocket/0 (jmethod $*ServerSocket "getChannel"))
(defvar $@getChannel/Socket/0 (jmethod $*Socket "getChannel"))
(defvar $@getAddress/DatagramPacket/0 (jmethod $*DatagramPacket "getAddress"))
(defvar $@getHostName/0 (jmethod $*InetAddress "getHostName"))
(defvar $@getInetAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getInetAddress"))
(defvar $@getInetAddress/ServerSocket/0 (jmethod $*ServerSocket "getInetAddress"))
(defvar $@getInetAddress/Socket/0 (jmethod $*Socket "getInetAddress"))
(defvar $@getLength/DatagramPacket/0 (jmethod $*DatagramPacket "getLength"))
(defvar $@getLocalAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalAddress"))
(defvar $@getLocalAddress/Socket/0 (jmethod $*Socket "getLocalAddress"))
(defvar $@getLocalPort/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalPort"))
(defvar $@getLocalPort/ServerSocket/0 (jmethod $*ServerSocket "getLocalPort"))
(defvar $@getLocalPort/Socket/0 (jmethod $*Socket "getLocalPort"))
(defvar $@getOffset/DatagramPacket/0 (jmethod $*DatagramPacket "getOffset"))
(defvar $@getPort/DatagramPacket/0 (jmethod $*DatagramPacket "getPort"))
(defvar $@getPort/DatagramSocket/0 (jmethod $*DatagramSocket "getPort"))
(defvar $@getPort/Socket/0 (jmethod $*Socket "getPort"))
(defvar $@hasNext/0 (jmethod $*Iterator "hasNext"))
(defvar $@iterator/0 (jmethod $*Set "iterator"))
(defvar $@next/0 (jmethod $*Iterator "next"))
(defvar $@open/DatagramChannel/0 (jmethod $*DatagramChannel "open"))
(defvar $@open/Selector/0 (jmethod $*Selector "open"))
(defvar $@open/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "open"))
(defvar $@open/SocketChannel/0 (jmethod $*SocketChannel "open"))
(defvar $@receive/1 (jmethod $*DatagramSocket "receive" $*DatagramPacket))
(defvar $@register/2 (jmethod $*SelectableChannel "register" $*Selector $*int))
(defvar $@select/0 (jmethod $*Selector "select"))
(defvar $@select/1 (jmethod $*Selector "select" $*long))
(defvar $@selectedKeys/0 (jmethod $*Selector "selectedKeys"))
(defvar $@send/1 (jmethod $*DatagramSocket "send" $*DatagramPacket))
(defvar $@setReuseAddress/1 (jmethod $*ServerSocket "setReuseAddress" $*boolean))
(defvar $@setSoTimeout/DatagramSocket/1 (jmethod $*DatagramSocket "setSoTimeout" $*int))
(defvar $@setSoTimeout/Socket/1 (jmethod $*Socket "setSoTimeout" $*int))
(defvar $@setTcpNoDelay/1 (jmethod $*Socket "setTcpNoDelay" $*boolean))
(defvar $@socket/DatagramChannel/0 (jmethod $*DatagramChannel "socket"))
(defvar $@socket/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "socket"))
(defvar $@socket/SocketChannel/0 (jmethod $*SocketChannel "socket"))
(defvar $@validOps/0 (jmethod $*SelectableChannel "validOps"))
;;; Java Field Variables ($+...)
(defvar $+op-accept (jfield $*SelectionKey "OP_ACCEPT"))
(defvar $+op-connect (jfield $*SelectionKey "OP_CONNECT"))
(defvar $+op-read (jfield $*SelectionKey "OP_READ"))
(defvar $+op-write (jfield $*SelectionKey "OP_WRITE"))
;;; Wrapper functions (return-type: java-object)
(defun %get-address (address)
(jcall $@getAddress/0 address))
(defun %get-all-by-name (string) ; return a simple vector
(jstatic $@getAllByName/1 $*InetAddress string))
(defun %get-by-name (string)
(jstatic $@getByName/1 $*InetAddress string))
(defun host-to-inet4 (host)
"USOCKET host formats to Java Inet4Address, used internally."
(%get-by-name (host-to-hostname host)))
;;; HANDLE-CONTITION
(defparameter +abcl-error-map+
`(("java.net.BindException" . operation-not-permitted-error)
("java.net.ConnectException" . connection-refused-error)
("java.net.NoRouteToHostException" . network-unreachable-error) ; untested
("java.net.PortUnreachableException" . protocol-not-supported-error) ; untested
("java.net.ProtocolException" . protocol-not-supported-error) ; untested
("java.net.SocketException" . socket-type-not-supported-error) ; untested
("java.net.SocketTimeoutException" . timeout-error)))
(defparameter +abcl-nameserver-error-map+
`(("java.net.UnknownHostException" . ns-host-not-found-error)))
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
(typecase condition
(java-exception
(let ((java-cause (java-exception-cause condition)))
(let* ((usock-error (cdr (assoc (jclass-of java-cause) +abcl-error-map+
:test #'string=)))
(usock-error (if (functionp usock-error)
(funcall usock-error condition)
usock-error))
(nameserver-error (cdr (assoc (jclass-of java-cause) +abcl-nameserver-error-map+
:test #'string=))))
(if nameserver-error
(error nameserver-error :socket socket :host-or-ip host-or-ip)
(when usock-error
(error usock-error :socket socket))))))))
;;; GET-HOSTS-BY-NAME
(defun get-address (address)
(when address
(let* ((array (%get-address address))
(length (jarray-length array)))
(labels ((jbyte (n)
(let ((byte (jarray-ref array n)))
(if (minusp byte) (+ 256 byte) byte))))
(cond
((= 4 length)
(vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)))
((= 16 length)
(vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)
(jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7)
(jbyte 8) (jbyte 9) (jbyte 10) (jbyte 11)
(jbyte 12) (jbyte 13) (jbyte 14) (jbyte 15)))
(t nil)))))) ; neither a IPv4 nor IPv6 address?!
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(map 'list #'get-address (%get-all-by-name name))))
;;; GET-HOST-BY-ADDRESS
(defun get-host-by-address (host)
(let ((inet4 (host-to-inet4 host)))
(with-mapped-conditions (nil host)
(jcall $@getHostName/0 inet4))))
;;; SOCKET-CONNECT
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-supplied-p)
local-host local-port)
(when deadline (unsupported 'deadline 'socket-connect))
(let (socket stream usocket)
(ecase protocol
(:stream ; TCP
(let ((channel (jstatic $@open/SocketChannel/0 $*SocketChannel))
(address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
(setq socket (jcall $@socket/SocketChannel/0 channel))
;; bind to local address if needed
(when (or local-host local-port)
(let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
(with-mapped-conditions (nil host)
(jcall $@bind/Socket/1 socket local-address))))
;; connect to dest address
(with-mapped-conditions (nil host)
(jcall $@connect/SocketChannel/1 channel address))
(setq stream (ext:get-socket-stream socket :element-type element-type)
usocket (make-stream-socket :stream stream :socket socket))
(when nodelay-supplied-p
(jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+
java:+true+ java:+false+)))
(when timeout
(jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout))))))
(:datagram ; UDP
(let ((channel (jstatic $@open/DatagramChannel/0 $*DatagramChannel)))
(setq socket (jcall $@socket/DatagramChannel/0 channel))
;; bind to local address if needed
(when (or local-host local-port)
(let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
(with-mapped-conditions (nil local-host)
(jcall $@bind/DatagramSocket/1 socket local-address))))
;; connect to dest address if needed
(when (and host port)
(let ((address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
(with-mapped-conditions (nil host)
(jcall $@connect/DatagramChannel/1 channel address))))
(setq usocket (make-datagram-socket socket :connected-p (if (and host port) t nil)))
(when timeout
(jcall $@setSoTimeout/DatagramSocket/1 socket (truncate (* 1000 timeout)))))))
usocket))
;;; SOCKET-LISTEN
(defun socket-listen (host port &key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5 backlog-supplied-p)
(element-type 'character))
(declare (type boolean reuse-address))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel))
(socket (jcall $@socket/ServerSocketChannel/0 channel))
(endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0))))
(jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+))
(with-mapped-conditions (socket host)
(if backlog-supplied-p
(jcall $@bind/ServerSocket/2 socket endpoint backlog)
(jcall $@bind/ServerSocket/1 socket endpoint)))
(make-stream-server-socket socket :element-type element-type)))
;;; SOCKET-ACCEPT
(defmethod socket-accept ((usocket stream-server-usocket)
&key (element-type 'character element-type-p))
(with-mapped-conditions (usocket)
(let* ((client-socket (jcall $@accept/0 (socket usocket)))
(element-type (if element-type-p
element-type
(element-type usocket)))
(stream (ext:get-socket-stream client-socket :element-type element-type)))
(make-stream-socket :stream stream :socket client-socket))))
;;; SOCKET-CLOSE
(defmethod socket-close ((usocket stream-server-usocket))
(with-mapped-conditions (usocket)
(jcall $@close/ServerSocket/0 (socket usocket))))
(defmethod socket-close ((usocket stream-usocket))
(with-mapped-conditions (usocket)
(close (socket-stream usocket))
(jcall $@close/Socket/0 (socket usocket))))
(defmethod socket-close ((usocket datagram-usocket))
(with-mapped-conditions (usocket)
(jcall $@close/DatagramSocket/0 (socket usocket))))
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(with-mapped-conditions (usocket)
(ecase direction
(:input
(jcall $@shutdownInput/Socket/0 (socket usocket)))
(:output
(jcall $@shutdownOutput/Socket/0 (socket usocket))))))
;;; GET-LOCAL/PEER-NAME/ADDRESS/PORT
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defmethod get-local-address ((usocket stream-usocket))
(get-address (jcall $@getLocalAddress/Socket/0 (socket usocket))))
(defmethod get-local-address ((usocket stream-server-usocket))
(get-address (jcall $@getInetAddress/ServerSocket/0 (socket usocket))))
(defmethod get-local-address ((usocket datagram-usocket))
(get-address (jcall $@getLocalAddress/DatagramSocket/0 (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(get-address (jcall $@getInetAddress/Socket/0 (socket usocket))))
(defmethod get-peer-address ((usocket datagram-usocket))
(get-address (jcall $@getInetAddress/DatagramSocket/0 (socket usocket))))
(defmethod get-local-port ((usocket stream-usocket))
(jcall $@getLocalPort/Socket/0 (socket usocket)))
(defmethod get-local-port ((usocket stream-server-usocket))
(jcall $@getLocalPort/ServerSocket/0 (socket usocket)))
(defmethod get-local-port ((usocket datagram-usocket))
(jcall $@getLocalPort/DatagramSocket/0 (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(jcall $@getPort/Socket/0 (socket usocket)))
(defmethod get-peer-port ((usocket datagram-usocket))
(jcall $@getPort/DatagramSocket/0 (socket usocket)))
;;; SOCKET-SEND & SOCKET-RECEIVE
(defun *->byte (data)
(declare (type (unsigned-byte 8) data)) ; required by SOCKET-SEND
(jnew $%Byte/0 (if (> data 127) (- data 256) data)))
(defun byte->* (byte &optional (element-type '(unsigned-byte 8)))
(let* ((ub8 (if (minusp byte) (+ 256 byte) byte)))
(if (eq element-type 'character)
(code-char ub8)
ub8)))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(let* ((socket (socket usocket))
(byte-array (jnew-array $*byte size))
(packet (if (and host port)
(jnew $%DatagramPacket/5 byte-array 0 size (host-to-inet4 host) port)
(jnew $%DatagramPacket/3 byte-array 0 size))))
;; prepare sending data
(loop for i from offset below (+ size offset)
do (setf (jarray-ref byte-array i) (*->byte (aref buffer i))))
(with-mapped-conditions (usocket host)
(jcall $@send/1 socket packet))))
;;; TODO: return-host and return-port cannot be get ...
(defmethod socket-receive ((usocket datagram-usocket) buffer length
&key (element-type '(unsigned-byte 8)))
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
(integer 0) ; size
(unsigned-byte 32) ; host
(unsigned-byte 16))) ; port
(let* ((socket (socket usocket))
(real-length (or length +max-datagram-packet-size+))
(byte-array (jnew-array $*byte real-length))
(packet (jnew $%DatagramPacket/3 byte-array 0 real-length)))
(with-mapped-conditions (usocket)
(jcall $@receive/1 socket packet))
(let* ((receive-length (jcall $@getLength/DatagramPacket/0 packet))
(return-buffer (or buffer (make-array receive-length :element-type element-type))))
(loop for i from 0 below receive-length
do (setf (aref return-buffer i)
(byte->* (jarray-ref byte-array i) element-type)))
(let ((return-host (if (connected-p usocket)
(get-peer-address usocket)
(get-address (jcall $@getAddress/DatagramPacket/0 packet))))
(return-port (if (connected-p usocket)
(get-peer-port usocket)
(jcall $@getPort/DatagramPacket/0 packet))))
(values return-buffer
receive-length
return-host
return-port)))))
;;; WAIT-FOR-INPUT
(defun socket-channel-class (usocket)
(cond ((stream-usocket-p usocket) $*SocketChannel)
((stream-server-usocket-p usocket) $*ServerSocketChannel)
((datagram-usocket-p usocket) $*DatagramChannel)))
(defun get-socket-channel (usocket)
(let ((method (cond ((stream-usocket-p usocket) $@getChannel/Socket/0)
((stream-server-usocket-p usocket) $@getChannel/ServerSocket/0)
((datagram-usocket-p usocket) $@getChannel/DatagramSocket/0))))
(jcall method (socket usocket))))
(defun wait-for-input-internal (wait-list &key timeout)
(let* ((sockets (wait-list-waiters wait-list))
(ops (logior $+op-read $+op-accept))
(selector (jstatic $@open/Selector/0 $*Selector))
(channels (mapcar #'get-socket-channel sockets)))
(unwind-protect
(with-mapped-conditions ()
(dolist (channel channels)
(jcall $@configureBlocking/1 channel java:+false+)
(jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel))))
(let ((ready-count (if timeout
(jcall $@select/1 selector (truncate (* timeout 1000)))
(jcall $@select/0 selector))))
(when (plusp ready-count)
(let* ((keys (jcall $@selectedKeys/0 selector))
(iterator (jcall $@iterator/0 keys))
(%wait (wait-list-%wait wait-list)))
(loop while (jcall $@hasNext/0 iterator)
do (let* ((key (jcall $@next/0 iterator))
(channel (jcall $@channel/0 key)))
(setf (state (gethash channel %wait)) :read)))))))
(jcall $@close/Selector/0 selector)
(dolist (channel channels)
(jcall $@configureBlocking/1 channel java:+true+)))))
;;; WAIT-LIST
;;; NOTE from original worker (Erik):
;;; Note that even though Java has the concept of the Selector class, which
;;; remotely looks like a wait-list, it requires the sockets to be non-blocking.
;;; usocket however doesn't make any such guarantees and is therefore unable to
;;; use the concept outside of the waiting routine itself (blergh!).
(defun %setup-wait-list (wl)
(setf (wait-list-%wait wl)
(make-hash-table :test #'equal :rehash-size 1.3d0)))
(defun %add-waiter (wl w)
(setf (gethash (get-socket-channel w) (wait-list-%wait wl)) w))
(defun %remove-waiter (wl w)
(remhash (get-socket-channel w) (wait-list-%wait wl)))

228
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/allegro.lisp Normal file
View file

@ -0,0 +1,228 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
#+cormanlisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :acl-socket))
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sock)
;; for wait-for-input:
(require :process)
;; note: the line below requires ACL 6.2+
(require :osi))
(defun get-host-name ()
;; note: the line below requires ACL 7.0+ to actually *work* on windows
#+allegro (excl.osi:gethostname)
#+cormanlisp "")
(defparameter +allegro-identifier-error-map+
'((:address-in-use . address-in-use-error)
(:address-not-available . address-not-available-error)
(:network-down . network-down-error)
(:network-reset . network-reset-error)
(:network-unreachable . network-unreachable-error)
(:connection-aborted . connection-aborted-error)
(:connection-reset . connection-reset-error)
(:no-buffer-space . no-buffers-error)
(:shutdown . shutdown-error)
(:connection-timed-out . timeout-error)
(:connection-refused . connection-refused-error)
(:host-down . host-down-error)
(:host-unreachable . host-unreachable-error)))
;; TODO: what's the error class of Corman Lisp?
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(typecase condition
#+allegro
(excl:socket-error
(let ((usock-error
(cdr (assoc (excl:stream-error-identifier condition)
+allegro-identifier-error-map+))))
(declare (type symbol usock-error))
(if usock-error
(cond ((subtypep usock-error 'ns-error)
(error usock-error :socket socket :host-or-ip host-or-ip))
(t
(error usock-error :socket socket)))
(error 'unknown-error
:real-error condition
:socket socket))))))
(defun to-format (element-type)
(if (subtypep element-type 'character)
:text
:binary))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline
(nodelay t) ;; nodelay == t is the ACL default
local-host local-port)
(when timeout (unsupported 'timeout 'socket-connect))
(when deadline (unsupported 'deadline 'socket-connect))
(when (eq nodelay :if-supported)
(setf nodelay t))
(let ((socket))
(setf socket
(with-mapped-conditions (socket (or host local-host))
(ecase protocol
(:stream
(labels ((make-socket ()
(socket:make-socket :remote-host (host-to-hostname host)
:remote-port port
:local-host (when local-host
(host-to-hostname local-host))
:local-port local-port
:format (to-format element-type)
:nodelay nodelay)))
#+allegro
(if timeout
(mp:with-timeout (timeout nil)
(make-socket))
(make-socket))
#+cormanlisp (make-socket)))
(:datagram
(apply #'socket:make-socket
(nconc (list :type protocol
:address-family :internet
:local-host (when local-host
(host-to-hostname local-host))
:local-port local-port
:format (to-format element-type))
(if (and host port)
(list :connect :active
:remote-host (host-to-hostname host)
:remote-port port)
(list :connect :passive))))))))
(ecase protocol
(:stream
(make-stream-socket :socket socket :stream socket))
(:datagram
(make-datagram-socket socket :connected-p (and host port t))))))
;; One socket close method is sufficient,
;; because socket-streams are also sockets.
(defmethod socket-close ((usocket usocket))
"Close socket."
(with-mapped-conditions (usocket)
(close (socket usocket))))
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(with-mapped-conditions (usocket)
(socket:shutdown (socket usocket) :direction direction)))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
;; Allegro and OpenMCL socket interfaces bear very strong resemblence
;; whatever you change here, change it also for OpenMCL
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(sock (with-mapped-conditions (nil host)
(apply #'socket:make-socket
(append (list :connect :passive
:reuse-address reuseaddress
:local-port port
:backlog backlog
:format (to-format element-type)
;; allegro now ignores :format
)
(when (ip/= host *wildcard-host*)
(list :local-host host)))))))
(make-stream-server-socket sock :element-type element-type)))
(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
(declare (ignore element-type)) ;; allegro streams are multivalent
(let ((stream-sock
(with-mapped-conditions (socket)
(socket:accept-connection (socket socket)))))
(make-stream-socket :socket stream-sock :stream stream-sock)))
(defmethod get-local-address ((usocket usocket))
(hbo-to-vector-quad (socket:local-host (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(hbo-to-vector-quad (socket:remote-host (socket usocket))))
(defmethod get-local-port ((usocket usocket))
(socket:local-port (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
#+allegro
(socket:remote-port (socket usocket)))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
#+allegro
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(with-mapped-conditions (usocket host)
(let ((s (socket usocket)))
(socket:send-to s
(if (zerop offset)
buffer
(subseq buffer offset (+ offset size)))
size
:remote-host host
:remote-port port))))
#+allegro
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
(integer 0) ; size
(unsigned-byte 32) ; host
(unsigned-byte 16))) ; port
(with-mapped-conditions (usocket)
(let ((s (socket usocket)))
(socket:receive-from s length :buffer buffer :extract t))))
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
(socket:ipaddr-to-hostname (host-to-hbo address))))
(defun get-hosts-by-name (name)
;;###FIXME: ACL has the acldns module which returns all A records
;; only problem: it doesn't fall back to tcp (from udp) if the returned
;; structure is too long.
(with-mapped-conditions (nil name)
(list (hbo-to-vector-quad (socket:lookup-hostname
(host-to-hostname name))))))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(push (socket waiter) (wait-list-%wait wait-list)))
(defun %remove-waiter (wait-list waiter)
(setf (wait-list-%wait wait-list)
(remove (socket waiter) (wait-list-%wait wait-list))))
#+allegro
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(let ((active-internal-sockets
(if timeout
(mp:wait-for-input-available (wait-list-%wait wait-list)
:timeout timeout)
(mp:wait-for-input-available (wait-list-%wait wait-list)))))
;; this is quadratic, but hey, the active-internal-sockets
;; list is very short and it's only quadratic in the length of that one.
;; When I have more time I could recode it to something of linear
;; complexity.
;; [Same code is also used in openmcl.lisp]
(dolist (x active-internal-sockets)
(setf (state (gethash x (wait-list-map wait-list)))
:read))
wait-list)))

158
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clasp.lisp Normal file
View file

@ -0,0 +1,158 @@
(in-package :usocket)
#-clasp
(progn
#-:wsock
(ffi:clines
"#include <errno.h>"
"#include <sys/socket.h>"
"#include <unistd.h>")
#+:wsock
(ffi:clines
"#ifndef FD_SETSIZE"
"#define FD_SETSIZE 1024"
"#endif"
"#include <winsock2.h>")
(ffi:clines
#+:msvc "#include <time.h>"
#-:msvc "#include <sys/time.h>"
"#include <ecl/ecl-inl.h>"))
(progn
#-clasp
(defun cerrno ()
(ffi:c-inline () () :int
"errno" :one-liner t))
#+clasp
(defun cerrno ()
(sockets-internal:errno))
#-clasp
(defun fd-setsize ()
(ffi:c-inline () () :fixnum
"FD_SETSIZE" :one-liner t))
#+clasp
(defun fd-setsize () (sockets-internal:fd-setsize))
#-clasp
(defun fdset-alloc ()
(ffi:c-inline () () :pointer-void
"ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
#+clasp (defun fdset-alloc () (sockets-internal::alloc-atomic-sizeof-fd-set))
#-clasp
(defun fdset-zero (fdset)
(ffi:c-inline (fdset) (:pointer-void) :void
"FD_ZERO((fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-zero (fdset) (sockets-internal:fdset-zero fdset))
#-clasp
(defun fdset-set (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_SET(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-set (fdset fd) (sockets-internal:fdset-set fd fdset))
#-clasp
(defun fdset-clr (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_CLR(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-clr (fdset fd) (sockets-internal:fdset-clr fd fdset))
#-clasp
(defun fdset-fd-isset (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
"FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-fd-isset (fdset fd) (sockets-internal:fdset-isset fd fdset))
(declaim (inline cerrno
fd-setsize
fdset-alloc
fdset-zero
fdset-set
fdset-clr
fdset-fd-isset))
#-clasp
(defun get-host-name ()
(ffi:c-inline
() () :object
"{ char *buf = (char *) ecl_alloc_atomic(257);
if (gethostname(buf,256) == 0)
@(return) = make_simple_base_string(buf);
else
@(return) = Cnil;
}" :one-liner nil :side-effects nil))
#+clasp
(defun get-host-name ()
(sockets-internal:get-host-name))
#-clasp
(defun read-select (wl to-secs &optional (to-musecs 0))
(let* ((sockets (wait-list-waiters wl))
(rfds (wait-list-%wait wl))
(max-fd (reduce #'(lambda (x y)
(let ((sy (sb-bsd-sockets:socket-file-descriptor
(socket y))))
(if (< x sy) sy x)))
(cdr sockets)
:initial-value (sb-bsd-sockets:socket-file-descriptor
(socket (car sockets))))))
(fdset-zero rfds)
(dolist (sock sockets)
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock))))
(let ((count
(ffi:c-inline (to-secs to-musecs rfds max-fd)
(t :unsigned-int :pointer-void :int)
:int
"
int count;
struct timeval tv;
if (#0 != Cnil) {
tv.tv_sec = fixnnint(#0);
tv.tv_usec = #1;
}
@(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
(#0 != Cnil) ? &tv : NULL);
" :one-liner nil)))
(cond
((= 0 count)
(values nil nil))
((< count 0)
;; check for EINTR and EAGAIN; these should not err
(values nil (cerrno)))
(t
(dolist (sock sockets)
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock)))
(setf (state sock) :READ))))))))
#+clasp
(defun read-select (wl to-secs &optional (to-musecs 0))
(let* ((sockets (wait-list-waiters wl))
(rfds (wait-list-%wait wl))
(max-fd (reduce #'(lambda (x y)
(let ((sy (sb-bsd-sockets:socket-file-descriptor
(socket y))))
(if (< x sy) sy x)))
(cdr sockets)
:initial-value (sb-bsd-sockets:socket-file-descriptor
(socket (car sockets))))))
(fdset-zero rfds)
(dolist (sock sockets)
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock))))
(let ((count (sockets-internal:do-select to-secs to-musecs rfds max-fd)))
(cond
((= 0 count)
(values nil nil))
((< count 0)
;; check for EINTR and EAGAIN; these should not err
(values nil (cerrno)))
(t
(dolist (sock sockets)
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock)))
(setf (state sock) :READ))))))))
)

715
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clisp.lisp Normal file
View file

@ -0,0 +1,715 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
(eval-when (:compile-toplevel :load-toplevel :execute)
#-ffi
(warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.")
#-(or ffi rawsock)
(warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support."))
;; utility routine for looking up the current host name
#+ffi
(ffi:def-call-out get-host-name-internal
(:name "gethostname")
(:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256))
:OUT :ALLOCA)
(len ffi:int))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(defun get-host-name ()
#+ffi
(multiple-value-bind (retcode name)
(get-host-name-internal 256)
(when (= retcode 0)
name))
#-ffi
"localhost")
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
(let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address))))
(posix:hostent-name hostent))))
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(let ((hostent (posix:resolve-host-ipaddr name)))
(mapcar #'host-to-vector-quad
(posix:hostent-addr-list hostent)))))
;; Format: ((UNIX Windows) . CONDITION)
(defparameter +clisp-error-map+
#-win32
`((:EADDRINUSE . address-in-use-error)
(:EADDRNOTAVAIL . address-not-available-error)
(:EBADF . bad-file-descriptor-error)
(:ECONNREFUSED . connection-refused-error)
(:ECONNRESET . connection-reset-error)
(:ECONNABORTED . connection-aborted-error)
(:EINVAL . invalid-argument-error)
(:ENOBUFS . no-buffers-error)
(:ENOMEM . out-of-memory-error)
(:ENOTSUP . operation-not-supported-error)
(:EPERM . operation-not-permitted-error)
(:EPROTONOSUPPORT . protocol-not-supported-error)
(:ESOCKTNOSUPPORT . socket-type-not-supported-error)
(:ENETUNREACH . network-unreachable-error)
(:ENETDOWN . network-down-error)
(:ENETRESET . network-reset-error)
(:ESHUTDOWN . already-shutdown-error)
(:ETIMEDOUT . timeout-error)
(:EHOSTDOWN . host-down-error)
(:EHOSTUNREACH . host-unreachable-error)
;; when blocked reading, and we close our socket due to a timeout.
;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values.
(:EAGAIN . timeout-error)
(:EWOULDBLOCK . timeout-error)) ;linux
#+win32
`((:WSAEADDRINUSE . address-in-use-error)
(:WSAEADDRNOTAVAIL . address-not-available-error)
(:WSAEBADF . bad-file-descriptor-error)
(:WSAECONNREFUSED . connection-refused-error)
(:WSAECONNRESET . connection-reset-error)
(:WSAECONNABORTED . connection-aborted-error)
(:WSAEINVAL . invalid-argument-error)
(:WSAENOBUFS . no-buffers-error)
(:WSAENOMEM . out-of-memory-error)
(:WSAENOTSUP . operation-not-supported-error)
(:WSAEPERM . operation-not-permitted-error)
(:WSAEPROTONOSUPPORT . protocol-not-supported-error)
(:WSAESOCKTNOSUPPORT . socket-type-not-supported-error)
(:WSAENETUNREACH . network-unreachable-error)
(:WSAENETDOWN . network-down-error)
(:WSAENETRESET . network-reset-error)
(:WSAESHUTDOWN . already-shutdown-error)
(:WSAETIMEDOUT . timeout-error)
(:WSAEHOSTDOWN . host-down-error)
(:WSAEHOSTUNREACH . host-unreachable-error)))
(defun parse-errno (condition)
"Returns a number or keyword if it can parse what is within parens, else NIL"
(let ((s (princ-to-string condition)))
(let ((pos1 (position #\( s))
(pos2 (position #\) s)))
;mac: number, linux: keyword
(ignore-errors
(if (digit-char-p (char s (1+ pos1)))
(parse-integer s :start (1+ pos1) :end pos2)
(let ((*package* (find-package "KEYWORD")))
(car (read-from-string s t nil :start pos1 :end (1+ pos2)))))))))
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch a usocket condition instead of a CLISP specific one, if we can."
(let ((errno
(cond
;clisp 2.49+
((typep condition (find-symbol "OS-STREAM-ERROR" "EXT"))
(parse-errno condition))
;clisp 2.49
((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM"))
(car (simple-condition-format-arguments condition))))))
(when errno
(let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno))))
(let ((usock-error (cdr (assoc error-keyword +clisp-error-map+))))
(when usock-error
(if (subtypep usock-error 'error)
(cond ((subtypep usock-error 'ns-error)
(error usock-error :socket socket :host-or-ip host-or-ip))
(t
(error usock-error :socket socket)))
(cond ((subtypep usock-error 'ns-condition)
(signal usock-error :socket socket :host-or-ip host-or-ip))
(t
(signal usock-error :socket socket))))))))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
local-host local-port)
(declare (ignorable timeout local-host local-port))
(when deadline (unsupported 'deadline 'socket-connect))
(when (and nodelay-specified
(not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(case protocol
(:stream
(let ((socket)
(hostname (host-to-hostname host)))
(with-mapped-conditions (socket host)
(setf socket
(if timeout
(socket:socket-connect port hostname
:element-type element-type
:buffered t
:timeout timeout)
(socket:socket-connect port hostname
:element-type element-type
:buffered t))))
(make-stream-socket :socket socket
:stream socket))) ;; the socket is a stream too
(:datagram
#+(or rawsock ffi)
(with-mapped-conditions (nil (or host local-host))
(socket-create-datagram (or local-port *auto-port*)
:local-host (or local-host *wildcard-host*)
:remote-host (and host (host-to-vector-quad host))
:remote-port port))
#-(or rawsock ffi)
(unsupported '(protocol :datagram) 'socket-connect))))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to
;; to explicitly turn it on; unfortunately, there's no way to turn it off...
(declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
(let ((sock (apply #'socket:socket-server
(append (list port
:backlog backlog)
(when (ip/= host *wildcard-host*)
(list :interface host))))))
(with-mapped-conditions (nil host)
(make-stream-server-socket sock :element-type element-type))))
(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
(let ((stream
(with-mapped-conditions (socket)
(socket:socket-accept (socket socket)
:element-type (or element-type
(element-type socket))))))
(make-stream-socket :socket stream
:stream stream)))
;; Only one close method required:
;; sockets and their associated streams
;; are the same object
(defmethod socket-close ((usocket usocket))
"Close socket."
(with-mapped-conditions (usocket)
(close (socket usocket))))
(defmethod socket-close ((usocket stream-server-usocket))
(socket:socket-server-close (socket usocket)))
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(with-mapped-conditions (usocket)
(socket:socket-stream-shutdown (socket usocket) direction)))
(defmethod get-local-name ((usocket stream-usocket))
(multiple-value-bind
(address port)
(socket:socket-stream-local (socket usocket) t)
(values (dotted-quad-to-vector-quad address) port)))
(defmethod get-local-name ((usocket stream-server-usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(multiple-value-bind
(address port)
(socket:socket-stream-peer (socket usocket) t)
(values (dotted-quad-to-vector-quad address) port)))
(defmethod get-local-address ((usocket usocket))
(nth-value 0 (get-local-name usocket)))
(defmethod get-local-address ((usocket stream-server-usocket))
(dotted-quad-to-vector-quad
(socket:socket-server-host (socket usocket))))
(defmethod get-peer-address ((usocket usocket))
(nth-value 0 (get-peer-name usocket)))
(defmethod get-local-port ((usocket usocket))
(nth-value 1 (get-local-name usocket)))
(defmethod get-local-port ((usocket stream-server-usocket))
(socket:socket-server-port (socket usocket)))
(defmethod get-peer-port ((usocket usocket))
(nth-value 1 (get-peer-name usocket)))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
;; clisp's #'socket-status takes a list whose elts look either like,
;; (socket-stream direction . x) or like,
;; (socket-server . x)
;; and it replaces the x's.
(push (cons (socket waiter)
(cond ((stream-usocket-p waiter) (cons NIL NIL))
(t NIL)))
(wait-list-%wait wait-list)))
(defun %remove-waiter (wait-list waiter)
(setf (wait-list-%wait wait-list)
(remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
(defmethod wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(dolist (x (wait-list-%wait wait-list))
(when (consp (cdr x)) ;it's a socket-stream not socket-server
(setf (cadr x) :INPUT)))
(let* ((request-list (wait-list-%wait wait-list))
(status-list (if timeout
(socket:socket-status request-list secs musecs)
(socket:socket-status request-list)))
(sockets (wait-list-waiters wait-list)))
(do* ((x (pop sockets) (pop sockets))
(y (cdr (last (pop status-list))) (cdr (last (pop status-list)))))
((null x))
(when (member y '(T :INPUT :EOF))
(setf (state x) :READ)))
wait-list))))
;;;
;;; UDP/Datagram sockets (RAWSOCK version)
;;;
#+rawsock
(progn
(defun make-sockaddr_in ()
(make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
(declaim (inline fill-sockaddr_in))
(defun fill-sockaddr_in (sockaddr_in ip port)
(port-to-octet-buffer port sockaddr_in)
(ip-to-octet-buffer ip sockaddr_in :start 2)
sockaddr_in)
(defun socket-create-datagram (local-port
&key (local-host *wildcard-host*)
remote-host
remote-port)
(let ((sock (rawsock:socket :inet :dgram 0))
(lsock_addr (fill-sockaddr_in (make-sockaddr_in)
local-host local-port))
(rsock_addr (when remote-host
(fill-sockaddr_in (make-sockaddr_in)
remote-host (or remote-port
local-port)))))
(rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr))
(when rsock_addr
(rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr)))
(make-datagram-socket sock :connected-p (if rsock_addr t nil))))
(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
"Returns the buffer, the number of octets copied into the buffer (received)
and the address of the sender as values."
(let* ((sock (socket socket))
(sockaddr (rawsock:make-sockaddr :inet))
(real-length (or length +max-datagram-packet-size+))
(real-buffer (or buffer
(make-array real-length
:element-type '(unsigned-byte 8)))))
(let ((rv (rawsock:recvfrom sock real-buffer sockaddr
:start 0 :end real-length))
(host 0) (port 0))
(unless (connected-p socket)
(let ((data (rawsock:sockaddr-data sockaddr)))
(setq host (ip-from-octet-buffer data :start 4)
port (port-from-octet-buffer data :start 2))))
(values (if buffer real-buffer (subseq real-buffer 0 rv))
rv
host
port))))
(defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0))
"Returns the number of octets sent."
(let* ((sock (socket socket))
(sockaddr (when (and host port)
(rawsock:make-sockaddr :inet
(fill-sockaddr_in
(make-sockaddr_in)
(host-byte-order host)
port))))
(real-size (min size +max-datagram-packet-size+))
(real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*)))
buffer
(make-array real-size
:element-type '(unsigned-byte 8)
:initial-contents (subseq buffer 0 real-size))))
(rv (if (and host port)
(rawsock:sendto sock real-buffer sockaddr
:start offset
:end (+ offset real-size))
(rawsock:send sock real-buffer
:start offset
:end (+ offset real-size)))))
rv))
(defmethod socket-close ((usocket datagram-usocket))
(rawsock:sock-close (socket usocket)))
(declaim (inline get-socket-name))
(defun get-socket-name (socket function)
(let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in))))
(funcall function socket sockaddr)
(let ((data (rawsock:sockaddr-data sockaddr)))
(values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2))
(port-from-octet-buffer data :start 0)))))
(defmethod get-local-name ((usocket datagram-usocket))
(get-socket-name (socket usocket) 'rawsock:getsockname))
(defmethod get-peer-name ((usocket datagram-usocket))
(get-socket-name (socket usocket) 'rawsock:getpeername))
) ; progn
;;;
;;; UDP/Datagram sockets (FFI version)
;;;
#+(and ffi (not rawsock))
(progn
;; C primitive types
(ffi:def-c-type socklen_t ffi:uint32)
;; C structures
(ffi:def-c-struct sockaddr
#+macos (sa_len ffi:uint8)
(sa_family #-macos ffi:ushort
#+macos ffi:uint8)
(sa_data (ffi:c-array ffi:char 14)))
(ffi:def-c-struct sockaddr_in
#+macos (sin_len ffi:uint8)
(sin_family #-macos ffi:short
#+macos ffi:uint8)
(sin_port #-macos ffi:ushort
#+macos ffi:uint16)
(sin_addr ffi:uint32)
(sin_zero (ffi:c-array ffi:char 8)))
(ffi:def-c-struct timeval
(tv_sec ffi:long)
(tv_usec ffi:long))
;; foreign functions
(ffi:def-call-out %sendto (:name "sendto")
(:arguments (socket ffi:int)
(buffer ffi:c-pointer)
(length ffi:int)
(flags ffi:int)
(address (ffi:c-ptr sockaddr))
(address-len ffi:int))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %send (:name "send")
(:arguments (socket ffi:int)
(buffer ffi:c-pointer)
(length ffi:int)
(flags ffi:int))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %recvfrom (:name "recvfrom")
(:arguments (socket ffi:int)
(buffer ffi:c-pointer)
(length ffi:int)
(flags ffi:int)
(address (ffi:c-ptr sockaddr) :in-out)
(address-len (ffi:c-ptr ffi:int) :in-out))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %socket (:name "socket")
(:arguments (family ffi:int)
(type ffi:int)
(protocol ffi:int))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %connect (:name "connect")
(:arguments (socket ffi:int)
(address (ffi:c-ptr sockaddr) :in)
(address_len socklen_t))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %bind (:name "bind")
(:arguments (socket ffi:int)
(address (ffi:c-ptr sockaddr) :in)
(address_len socklen_t))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket")
(:arguments (socket ffi:int))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %getsockopt (:name "getsockopt")
(:arguments (sockfd ffi:int)
(level ffi:int)
(optname ffi:int)
(optval ffi:c-pointer)
(optlen (ffi:c-ptr socklen_t) :out))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %setsockopt (:name "setsockopt")
(:arguments (sockfd ffi:int)
(level ffi:int)
(optname ffi:int)
(optval ffi:c-pointer)
(optlen socklen_t))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %htonl (:name "htonl")
(:arguments (hostlong ffi:uint32))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:uint32))
(ffi:def-call-out %htons (:name "htons")
(:arguments (hostshort ffi:uint16))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:uint16))
(ffi:def-call-out %ntohl (:name "ntohl")
(:arguments (netlong ffi:uint32))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:uint32))
(ffi:def-call-out %ntohs (:name "ntohs")
(:arguments (netshort ffi:uint16))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:uint16))
(ffi:def-call-out %getsockname (:name "getsockname")
(:arguments (sockfd ffi:int)
(localaddr (ffi:c-ptr sockaddr) :in-out)
(addrlen (ffi:c-ptr socklen_t) :in-out))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
(ffi:def-call-out %getpeername (:name "getpeername")
(:arguments (sockfd ffi:int)
(peeraddr (ffi:c-ptr sockaddr) :in-out)
(addrlen (ffi:c-ptr socklen_t) :in-out))
#+win32 (:library "WS2_32")
#-win32 (:library :default)
(:language #-win32 :stdc
#+win32 :stdc-stdcall)
(:return-type ffi:int))
;; socket constants
(defconstant +socket-af-inet+ 2)
(defconstant +socket-sock-dgram+ 2)
(defconstant +socket-ip-proto-udp+ 17)
(defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout")
(defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in))
(declaim (inline fill-sockaddr_in))
(defun fill-sockaddr_in (sockaddr host port)
(let ((hbo (host-to-hbo host)))
(ffi:with-c-place (place sockaddr)
#+macos
(setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*)
(setf (ffi:slot place 'sin_family) +socket-af-inet+
(ffi:slot place 'sin_port) (%htons port)
(ffi:slot place 'sin_addr) (%htonl hbo)))
sockaddr))
(defun socket-create-datagram (local-port
&key (local-host *wildcard-host*)
remote-host
remote-port)
(let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+))
(lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
local-host local-port))
(rsock_addr (when remote-host
(fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
remote-host (or remote-port local-port)))))
(unless (plusp sock)
(error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
(unwind-protect
(let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
*length-of-sockaddr_in*)))
(unless (zerop rv)
(error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
(when rsock_addr
(let ((rv (%connect sock
(ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
*length-of-sockaddr_in*)))
(unless (zerop rv)
(error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
(ffi:foreign-free lsock_addr)
(when remote-host
(ffi:foreign-free rsock_addr)))
(make-datagram-socket sock :connected-p (if rsock_addr t nil))))
(defun finalize-datagram-usocket (object)
(when (datagram-usocket-p object)
(socket-close object)))
(defmethod initialize-instance :after ((usocket datagram-usocket) &key)
(setf (slot-value usocket 'recv-buffer)
(ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+))
;; finalize the object
(ext:finalize usocket 'finalize-datagram-usocket))
(defmethod socket-close ((usocket datagram-usocket))
(with-slots (recv-buffer socket) usocket
(ffi:foreign-free recv-buffer)
(zerop (%close socket))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(let ((remote-address (ffi:allocate-shallow 'sockaddr_in))
(remote-address-length (ffi:allocate-shallow 'ffi:int))
nbytes (host 0) (port 0))
(setf (ffi:foreign-value remote-address-length)
*length-of-sockaddr_in*)
(unwind-protect
(multiple-value-bind (n address address-length)
(%recvfrom (socket usocket)
(ffi:foreign-address (slot-value usocket 'recv-buffer))
+max-datagram-packet-size+
0 ; flags
(ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
(ffi:foreign-value remote-address-length))
(when (minusp n)
(error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
(setq nbytes n)
(when (= address-length *length-of-sockaddr_in*)
(let ((data (sockaddr-sa_data address)))
(setq host (ip-from-octet-buffer data :start 2)
port (port-from-octet-buffer data))))
(cond ((plusp n)
(let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer))))
(if buffer ; replace exist buffer of create new return buffer
(let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+))
(end-2 (min n +max-datagram-packet-size+)))
(replace buffer return-buffer :end1 end-1 :end2 end-2))
(setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
((zerop n))))
(ffi:foreign-free remote-address)
(ffi:foreign-free remote-address-length))
(values buffer nbytes host port)))
;; implementation note: different from socket-receive, we know how many bytes we want to send everytime,
;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those
;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time.
;;
;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP.
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(declare (type sequence buffer)
(type (integer 0 *) size offset))
(let ((remote-address
(when (and host port)
(fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port)))
(send-buffer
(ffi:allocate-deep 'ffi:uint8
(if (zerop offset)
buffer
(subseq buffer offset (+ offset size)))
:count size :read-only t))
(real-size (min size +max-datagram-packet-size+))
(nbytes 0))
(unwind-protect
(let ((n (if remote-address
(%sendto (socket usocket)
(ffi:foreign-address send-buffer)
real-size
0 ; flags
(ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
*length-of-sockaddr_in*)
(%send (socket usocket)
(ffi:foreign-address send-buffer)
real-size
0))))
(cond ((plusp n)
(setq nbytes n))
((zerop n)
(setq nbytes n))
(t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
(ffi:foreign-free send-buffer)
(when remote-address
(ffi:foreign-free remote-address))
nbytes)))
(declaim (inline get-socket-name))
(defun get-socket-name (socket function)
(let ((address (ffi:allocate-shallow 'sockaddr_in))
(address-length (ffi:allocate-shallow 'ffi:int))
(host 0) (port 0))
(setf (ffi:foreign-value address-length) *length-of-sockaddr_in*)
(unwind-protect
(multiple-value-bind (rv return-address return-address-length)
(funcall function socket
(ffi:cast (ffi:foreign-value address) 'sockaddr)
(ffi:foreign-value address-length))
(declare (ignore return-address-length))
(if (zerop rv)
(let ((data (sockaddr-sa_data return-address)))
(setq host (ip-from-octet-buffer data :start 2)
port (port-from-octet-buffer data)))
(error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
(ffi:foreign-free address)
(ffi:foreign-free address-length))
(values (hbo-to-vector-quad host) port)))
(defmethod get-local-name ((usocket datagram-usocket))
(get-socket-name (socket usocket) '%getsockname))
(defmethod get-peer-name ((usocket datagram-usocket))
(get-socket-name (socket usocket) '%getpeername))
) ; progn

73
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clozure.lisp Normal file
View file

@ -0,0 +1,73 @@
;;;; See LICENSE for licensing information.
;;;; Functions for CCL 1.11 (IPv6) only, see openmcl.lisp for rest of functions.
(in-package :usocket)
#+ipv6
(defun socket-connect (host port &key (protocol :stream) element-type
timeout deadline nodelay
local-host local-port)
(when (eq nodelay :if-supported)
(setf nodelay t))
(with-mapped-conditions (nil host)
(let* ((remote (when (and host port)
(openmcl-socket:resolve-address :host (host-to-hostname host)
:port port
:socket-type protocol)))
(local (when (and local-host local-port)
(openmcl-socket:resolve-address :host (host-to-hostname local-host)
:port local-port
:socket-type protocol)))
(mcl-sock (apply #'openmcl-socket:make-socket
`(:type ,protocol
,@(when (or remote local)
`(:address-family ,(openmcl-socket:socket-address-family (or remote local))))
,@(when remote
`(:remote-address ,remote))
,@(when local
`(:local-address ,local))
:format ,(to-format element-type protocol)
:external-format ,ccl:*default-external-format*
:deadline ,deadline
:nodelay ,nodelay
:connect-timeout ,timeout
:input-timeout ,timeout))))
(ecase protocol
(:stream
(make-stream-socket :stream mcl-sock :socket mcl-sock))
(:datagram
(make-datagram-socket mcl-sock :connected-p (and remote t)))))))
#+ipv6
(defun socket-listen (host port
&key
(reuse-address nil reuse-address-supplied-p)
(reuseaddress (when reuse-address-supplied-p reuse-address))
(backlog 5)
(element-type 'character))
(let ((local-address (openmcl-socket:resolve-address :host (host-to-hostname host)
:port port :connect :passive)))
(with-mapped-conditions (nil host)
(make-stream-server-socket
(openmcl-socket:make-socket :connect :passive
:address-family (openmcl-socket:socket-address-family local-address)
:local-address local-address
:reuse-address reuseaddress
:backlog backlog
:format (to-format element-type :stream))
:element-type element-type))))
#+ipv6
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(let* ((ccl-socket (socket usocket))
(socket-keys (ccl::socket-keys ccl-socket)))
(with-mapped-conditions (usocket host)
(if (and host port)
(openmcl-socket:send-to ccl-socket buffer size
:remote-host (host-to-hostname host)
:remote-port port
:offset offset)
(openmcl-socket:send-to ccl-socket buffer size
:remote-address (getf socket-keys :remote-address)
:offset offset)))))

298
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/cmucl.lisp Normal file
View file

@ -0,0 +1,298 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
#+win32
(defun remap-for-win32 (z)
(mapcar #'(lambda (x)
(cons (mapcar #'(lambda (y)
(+ 10000 y))
(car x))
(cdr x)))
z))
(defparameter +cmucl-error-map+
#+win32
(append (remap-for-win32 +unix-errno-condition-map+)
(remap-for-win32 +unix-errno-error-map+))
#-win32
(append +unix-errno-condition-map+
+unix-errno-error-map+))
(defun cmucl-map-socket-error (err &key condition socket host-or-ip)
(let ((usock-error
(cdr (assoc err +cmucl-error-map+ :test #'member))))
(if usock-error
(if (subtypep usock-error 'error)
(cond ((subtypep usock-error 'ns-error)
(error usock-error :socket socket :host-or-ip host-or-ip))
(t
(error usock-error :socket socket)))
(cond ((subtypep usock-error 'ns-condition)
(signal usock-error :socket socket :host-or-ip host-or-ip))
(t
(signal usock-error :socket socket))))
(error 'unknown-error
:socket socket
:real-error condition))))
;; CMUCL error handling is brain-dead: it doesn't preserve any
;; information other than the OS error string from which the
;; error can be determined. The OS error string isn't good enough
;; given that it may have been localized (l10n).
;;
;; The above applies to versions pre 19b; 19d and newer are expected to
;; contain even better error reporting.
;;
;;
;; Just catch the errors and encapsulate them in an unknown-error
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(typecase condition
(ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
:socket socket
:condition condition
:host-or-ip host-or-ip))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
(local-host nil local-host-p)
(local-port nil local-port-p)
&aux
(local-bind-p (fboundp 'ext::bind-inet-socket)))
(when timeout (unsupported 'timeout 'socket-connect))
(when deadline (unsupported 'deadline 'socket-connect))
(when (and nodelay-specified
(not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(when (and local-host-p (not local-bind-p))
(unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
(when (and local-port-p (not local-bind-p))
(unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
(let ((socket))
(ecase protocol
(:stream
(setf socket
(let ((args (list (host-to-hbo host) port protocol)))
(when (and local-bind-p (or local-host-p local-port-p))
(nconc args (list :local-host (when local-host
(host-to-hbo local-host))
:local-port local-port)))
(with-mapped-conditions (socket host)
(apply #'ext:connect-to-inet-socket args))))
(if socket
(let* ((stream (sys:make-fd-stream socket :input t :output t
:element-type element-type
:buffering :full))
;;###FIXME the above line probably needs an :external-format
(usocket (make-stream-socket :socket socket
:stream stream)))
usocket)
(let ((err (unix:unix-errno)))
(when err (cmucl-map-socket-error err)))))
(:datagram
(setf socket
(if (and host port)
(let ((args (list (host-to-hbo host) port protocol)))
(when (and local-bind-p (or local-host-p local-port-p))
(nconc args (list :local-host (when local-host
(host-to-hbo local-host))
:local-port local-port)))
(with-mapped-conditions (socket (or host local-host))
(apply #'ext:connect-to-inet-socket args)))
(if (or local-host-p local-port-p)
(with-mapped-conditions (socket (or host local-host))
(apply #'ext:create-inet-listener
(nconc (list (or local-port 0) protocol)
(when (and local-host-p
(ip/= local-host *wildcard-host*))
(list :host (host-to-hbo local-host))))))
(with-mapped-conditions (socket (or host local-host))
(ext:create-inet-socket protocol)))))
(if socket
(let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
(ext:finalize usocket #'(lambda () (when (%open-p usocket)
(ext:close-socket socket))))
usocket)
(let ((err (unix:unix-errno)))
(when err (cmucl-map-socket-error err))))))))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(server-sock
(with-mapped-conditions (nil host)
(apply #'ext:create-inet-listener
(nconc (list port :stream
:backlog backlog
:reuse-address reuseaddress)
(when (ip/= host *wildcard-host*)
(list :host
(host-to-hbo host))))))))
(make-stream-server-socket server-sock :element-type element-type)))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(with-mapped-conditions (usocket)
(let* ((sock (ext:accept-tcp-connection (socket usocket)))
(stream (sys:make-fd-stream sock :input t :output t
:element-type (or element-type
(element-type usocket))
:buffering :full)))
(make-stream-socket :socket sock :stream stream))))
;; Sockets and socket streams are represented
;; by different objects. Be sure to close the
;; socket stream when closing a stream socket.
(defmethod socket-close ((usocket stream-usocket))
"Close socket."
(with-mapped-conditions (usocket)
(close (socket-stream usocket))))
(defmethod socket-close ((usocket usocket))
"Close socket."
(with-mapped-conditions (usocket)
(ext:close-socket (socket usocket))))
(defmethod socket-close :after ((socket datagram-usocket))
(setf (%open-p socket) nil))
#+unicode
(defun %unix-send (fd buffer length flags)
(alien:alien-funcall
(alien:extern-alien "send"
(function c-call:int
c-call:int
system:system-area-pointer
c-call:int
c-call:int))
fd
(system:vector-sap buffer)
length
flags))
(defmethod socket-shutdown ((usocket usocket) direction)
(with-mapped-conditions (usocket)
(ext:inet-shutdown (socket usocket) (ecase direction
(:input ext:shut-rd)
(:output ext:shut-wr)))))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
&aux (real-buffer (if (zerop offset)
buffer
(subseq buffer offset (+ offset size)))))
(with-mapped-conditions (usocket host)
(if (and host port)
(ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port)
#-unicode
(unix:unix-send (socket usocket) real-buffer size 0)
#+unicode
(%unix-send (socket usocket) real-buffer size 0))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
(integer 0) ; size
(unsigned-byte 32) ; host
(unsigned-byte 16))) ; port
(let ((real-buffer (or buffer
(make-array length :element-type '(unsigned-byte 8))))
(real-length (or length
(length buffer))))
(multiple-value-bind (nbytes remote-host remote-port)
(with-mapped-conditions (usocket)
(ext:inet-recvfrom (socket usocket) real-buffer real-length))
(values real-buffer nbytes remote-host remote-port))))
(defmethod get-local-name ((usocket usocket))
(multiple-value-bind
(address port)
(ext:get-socket-host-and-port (socket usocket))
(values (hbo-to-vector-quad address) port)))
(defmethod get-peer-name ((usocket stream-usocket))
(multiple-value-bind
(address port)
(ext:get-peer-host-and-port (socket usocket))
(values (hbo-to-vector-quad address) port)))
(defmethod get-local-address ((usocket usocket))
(nth-value 0 (get-local-name usocket)))
(defmethod get-peer-address ((usocket stream-usocket))
(nth-value 0 (get-peer-name usocket)))
(defmethod get-local-port ((usocket usocket))
(nth-value 1 (get-local-name usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(nth-value 1 (get-peer-name usocket)))
(defun lookup-host-entry (host)
(multiple-value-bind
(entry errno)
(ext:lookup-host-entry host)
(if entry
entry
;;###The constants below work on *most* OSes, but are defined as the
;; constants mentioned in C
(let ((exception
(second (assoc errno
'((1 ns-host-not-found-error) ;; HOST_NOT_FOUND
(2 ns-no-recovery-error) ;; NO_DATA
(3 ns-no-recovery-error) ;; NO_RECOVERY
(4 ns-try-again-condition)))))) ;; TRY_AGAIN
(when exception
(error exception))))))
(defun get-host-by-address (address)
(handler-case (ext:host-entry-name
(lookup-host-entry (host-byte-order address)))
(condition (condition) (handle-condition condition address))))
(defun get-hosts-by-name (name)
(handler-case (mapcar #'hbo-to-vector-quad
(ext:host-entry-addr-list
(lookup-host-entry name)))
(condition (condition) (handle-condition condition name))))
(defun get-host-name ()
(unix:unix-gethostname))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(push (socket waiter) (wait-list-%wait wait-list)))
(defun %remove-waiter (wait-list waiter)
(setf (wait-list-%wait wait-list)
(remove (socket waiter) (wait-list-%wait wait-list))))
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(alien:with-alien ((rfds (alien:struct unix:fd-set)))
(unix:fd-zero rfds)
(dolist (socket (wait-list-%wait wait-list))
(unix:fd-set socket rfds))
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(multiple-value-bind (count err)
(unix:unix-fast-select (1+ (reduce #'max
(wait-list-%wait wait-list)))
(alien:addr rfds) nil nil
(when timeout secs) musecs)
(declare (ignore err))
(if (<= 0 count)
;; process the result...
(dolist (x (wait-list-waiters wait-list))
(when (unix:fd-isset (socket x) rfds)
(setf (state x) :READ)))
(progn
;;###FIXME generate an error, except for EINTR
)))))))

152
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp Normal file
View file

@ -0,0 +1,152 @@
;;;; -*- Mode: Lisp -*-
;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
;;;; See LICENSE for licensing information.
(in-package :usocket)
#+(and ecl-bytecmp windows)
(eval-when (:load-toplevel :execute)
(ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
#+(and ecl-bytecmp windows)
(progn
(ffi:def-function ("gethostname" c-gethostname)
((name (* :unsigned-char))
(len :int))
:returning :int
:module "ws2_32")
(defun get-host-name ()
"Returns the hostname"
(ffi:with-foreign-object (name '(:array :unsigned-char 256))
(when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
(ffi:convert-from-foreign-string name))))
(ffi:def-foreign-type ws-socket :unsigned-int)
(ffi:def-foreign-type ws-dword :unsigned-long)
(ffi:def-foreign-type ws-event :unsigned-int)
(ffi:def-struct wsa-network-events
(network-events :long)
(error-code (:array :int 10)))
(ffi:def-function ("WSACreateEvent" wsa-event-create)
()
:returning ws-event
:module "ws2_32")
(ffi:def-function ("WSACloseEvent" c-wsa-event-close)
((event-object ws-event))
:returning :int
:module "ws2_32")
(defun wsa-event-close (ws-event)
(not (zerop (c-wsa-event-close ws-event))))
(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
((socket ws-socket)
(event-object ws-event)
(network-events (* wsa-network-events)))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAEventSelect" wsa-event-select)
((socket ws-socket)
(event-object ws-event)
(network-events :long))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
((number-of-events ws-dword)
(events (* ws-event))
(wait-all-p :int)
(timeout ws-dword)
(alertable-p :int))
:returning ws-dword
:module "ws2_32")
(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
(c-wsa-wait-for-multiple-events number-of-events
events
(if wait-all-p -1 0)
timeout
(if alertable-p -1 0)))
(ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
((socket ws-socket)
(cmd :long)
(argp (* :unsigned-long)))
:returning :int
:module "ws2_32")
(ffi:def-function ("WSAGetLastError" wsa-get-last-error)
()
:returning :int
:module "ws2_32")
(defun maybe-wsa-error (rv &optional socket)
(unless (zerop rv)
(raise-usock-err (wsa-get-last-error) socket)))
(defun bytes-available-for-read (socket)
(ffi:with-foreign-object (int-ptr :unsigned-long)
(maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
socket)
(let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
(prog1 int
(when (plusp int)
(setf (state socket) :read))))))
(defun map-network-events (func network-events)
(let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
(error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
(unless (zerop event-map)
(dotimes (i fd-max-events)
(unless (zerop (ldb (byte 1 i) event-map))
(funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
(defun update-ready-and-state-slots (sockets)
(dolist (socket sockets)
(if (%ready-p socket)
(progn
(setf (state socket) :READ))
(ffi:with-foreign-object (network-events 'wsa-network-events)
(let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
(if (zerop rv)
(map-network-events
#'(lambda (err-code)
(if (zerop err-code)
(progn
(setf (state socket) :READ)
(when (stream-server-usocket-p socket)
(setf (%ready-p socket) t)))
(raise-usock-err err-code socket)))
network-events)
(maybe-wsa-error rv socket)))))))
(defun os-wait-list-%wait (wait-list)
(ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
(defun (setf os-wait-list-%wait) (value wait-list)
(setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
(defun free-wait-list (wl)
(when (wait-list-p wl)
(unless (null (wait-list-%wait wl))
(wsa-event-close (os-wait-list-%wait wl))
(ffi:free-foreign-object (wait-list-%wait wl))
(setf (wait-list-%wait wl) nil))))
(defun %setup-wait-list (wait-list)
(setf (wait-list-%wait wait-list)
(ffi:allocate-foreign-object 'ws-event))
(setf (os-wait-list-%wait wait-list)
(wsa-event-create))
(ext:set-finalizer wait-list #'free-wait-list))
(defun os-socket-handle (usocket)
(socket-handle usocket))
) ; #+(and ecl-bytecmp windows)

264
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/genera.lisp Normal file
View file

@ -0,0 +1,264 @@
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*-
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defclass genera-socket ()
((foreign-address :initform 0 :initarg :foreign-address :accessor gs-foreign-address)
(foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port)
(local-address :initform 0 :initarg :local-address :accessor gs-local-address)
(local-port :initform 0 :initarg :local-port :accessor gs-local-port))
)
(defclass genera-stream-socket (genera-socket)
((stream :initform nil :initarg :stream :accessor gs-stream))
)
(defclass genera-stream-server-socket (genera-socket)
((backlog :initform nil :initarg :backlog :accessor gs-backlog)
(element-type :initform nil :initarg :element-type :accessor gs-element-type)
(pending-connections :initform nil :accessor gs-pending-connections))
)
(defclass genera-datagram-socket (genera-socket)
((connection :initform nil :initarg :connection :accessor gs-connection))
)
(defun host-to-host-object (host)
(let ((host (host-to-hostname host)))
(cond ((string-equal host "localhost")
net:*local-host*)
((ip-address-string-p host)
(let ((quad (dotted-quad-to-vector-quad host)))
;;---*** NOTE: This test is temporary until we have a loopback interface
(if (= (aref quad 0) 127)
net:*local-host*
(net:parse-host (format nil "INTERNET|~A" host)))))
(t
(net:parse-host host)))))
(defun element-type-to-format (element-type protocol)
(cond ((null element-type)
(ecase protocol
(:stream :text)
(:datagram :binary)))
((subtypep element-type 'character)
:text)
(t :binary)))
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
(typecase condition
;;---*** TODO: Add additional conditions as appropriate
(sys:connection-refused
(error 'connection-refused-error :socket socket))
((or tcp::tcp-destination-unreachable-during-connection tcp::udp-destination-unreachable)
(error 'host-unreachable-error :socket socket))
(sys:host-not-responding-during-connection
(error 'timeout-error :socket socket))
(sys:unknown-host-name
(error 'ns-host-not-found-error :host-or-ip host-or-ip))
(sys:network-error
(error 'unknown-error :socket socket :real-error condition :errno -1))))
(defun socket-connect (host port &key (protocol :stream) element-type
timeout deadline (nodelay nil nodelay-p)
local-host local-port)
(declare (ignore local-host))
(when deadline
(unsupported 'deadline 'socket-connect))
(when (and nodelay-p (not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(with-mapped-conditions (nil host)
(ecase protocol
(:stream
(let* ((host-object (host-to-host-object host))
(format (element-type-to-format element-type protocol))
(characters (eq format :text))
(timeout (if timeout
(* 60 timeout)
tcp:*tcp-connect-timeout*))
(stream (tcp:open-tcp-stream host-object port local-port
:characters characters
:ascii-translation characters
:timeout timeout))
(gs (make-instance 'genera-stream-socket
:stream stream)))
(setf (gs-foreign-address gs) (scl:send stream :foreign-address))
(setf (gs-foreign-port gs) (scl:send stream :foreign-port))
(setf (gs-local-address gs) (scl:send stream :local-address))
(setf (gs-local-port gs) (scl:send stream :local-port))
(make-stream-socket :socket gs :stream stream)))
(:datagram
;;---*** TODO
(unsupported 'datagram 'socket-connect)))))
(defmethod socket-close ((usocket usocket))
(with-mapped-conditions (usocket)
(socket-close (socket usocket))))
(defmethod socket-close ((socket genera-stream-socket))
(with-slots (stream) socket
(when stream
(scl:send (shiftf stream nil) :close nil))))
(defmethod socket-close ((socket genera-stream-server-socket))
(with-slots (local-port pending-connections) socket
(when local-port
(tcp:remove-tcp-port-listener local-port))
(dolist (tcb pending-connections)
(tcp::reject-tcb tcb))))
(defmethod socket-close ((socket genera-datagram-socket))
(with-slots (connection) socket
(when connection
(scl:send (shiftf connection nil) :close nil))
;;---*** TODO: listening?
))
;;; Cribbed from TCP::MAKE-TCB
(defun gensym-tcp-port ()
(loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*last-gensym-port-number*
do (cond ((loop for existing-tcb in tcp::*tcb-list*
thereis (= number (tcp::tcb-local-port existing-tcb))))
((and (<= #.(expt 2 10) number) (< number #.(expt 2 16)))
(return number))
(t
(setq tcp::*last-gensym-port-number* #.(expt 2 10))))))
(defun socket-listen (host port &key (reuse-address nil reuse-address-p)
(reuseaddress nil reuseaddress-p)
(backlog 5) (element-type 'character))
(let ((host-object (host-to-host-object host))
(port (if (zerop port) (gensym-tcp-port) port))
(reuse-address (cond (reuse-address-p reuse-address)
(reuseaddress-p reuseaddress)
(t nil))))
(when (<= port 1024)
;; Don't allow listening on "privileged" ports to mimic Unix/Linux semantics
(error 'operation-not-permitted-error :socket nil))
(when (tcp:tcp-port-protocol-name port)
;; Can't replace a Genera server
(error 'address-in-use-error :socket nil))
(when (tcp:tcp-port-listener port)
(unless reuse-address
(error 'address-in-use-error :socket nil)))
(let ((gs (make-instance 'genera-stream-server-socket
:backlog backlog
:element-type element-type)))
(setf (gs-local-address gs)
(loop for (network address) in (scl:send host-object :network-addresses)
when (typep network 'tcp:internet-network)
return address))
(setf (gs-local-port gs) port)
(flet ((add-to-queue (tcb)
(cond ((and (not (zerop (gs-local-address gs)))
(not (= (gs-local-address gs) (tcp::tcb-local-address tcb))))
;; Reject if not destined for the proper address
(tcp::reject-tcb tcb))
((<= (length (gs-pending-connections gs)) (gs-backlog gs))
(tcp::accept-tcb tcb)
(tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received)
(setf (gs-pending-connections gs)
(append (gs-pending-connections gs) (list tcb))))
(t
;; Reject if backlog is full
(tcp::reject-tcb tcb)))))
(tcp:add-tcp-port-listener port #'add-to-queue))
(make-stream-server-socket gs :element-type element-type))))
(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
(with-slots (pending-connections) (socket socket)
(loop
(process:process-block "Wait for connection" #'(lambda ()
(not (null pending-connections))))
(let ((tcb (pop pending-connections)))
(when tcb
(let* ((format (element-type-to-format (or element-type (element-type socket))
:stream))
(characters (eq format :text))
(stream (tcp::make-tcp-stream tcb
:characters characters
:ascii-translation characters))
(gs (make-instance 'genera-stream-socket
:stream stream)))
(setf (gs-foreign-address gs) (scl:send stream :foreign-address))
(setf (gs-foreign-port gs) (scl:send stream :foreign-port))
(setf (gs-local-address gs) (scl:send stream :local-address))
(setf (gs-local-port gs) (scl:send stream :local-port))
(return (make-stream-socket :socket gs :stream stream))))))))
(defmethod get-local-address ((usocket usocket))
(hbo-to-vector-quad (gs-local-address (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(hbo-to-vector-quad (gs-foreign-address (socket usocket))))
(defmethod get-local-port ((usocket usocket))
(gs-local-port (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(gs-foreign-port (socket usocket)))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
;;---*** TODO
(unsupported 'datagram 'socket-send))
(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
;;---*** TODO
(unsupported 'datagram 'socket-receive))
(defun get-host-by-address (address)
) ;; TODO
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(let ((host-object (host-to-host-object name)))
(loop for (network address) in (scl:send host-object :network-addresses)
when (typep network 'tcp:internet-network)
collect (hbo-to-vector-quad address)))))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun %remove-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(process:process-block-with-timeout timeout "Wait for input"
#'(lambda (wait-list)
(let ((ready-sockets nil))
(dolist (waiter (wait-list-waiters wait-list) ready-sockets)
(setf (state waiter)
(cond ((stream-usocket-p waiter)
(if (listen (socket-stream waiter))
:read
nil))
((datagram-usocket-p waiter)
(let ((connection (gs-connection (socket waiter))))
(if (and connection
(not (scl:send connection :connection-pending-p)))
:read
nil)))
((stream-server-usocket-p waiter)
(if (gs-pending-connections (socket waiter))
:read
nil))))
(when (not (null (state waiter)))
(setf ready-sockets t)))))
wait-list)
wait-list))

290
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/iolib.lisp Normal file
View file

@ -0,0 +1,290 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defparameter *backend* :iolib)
(eval-when (:load-toplevel :execute)
(shadowing-import 'iolib/sockets:socket-option)
(export 'socket-option))
(defparameter +iolib-error-map+
`((iolib/sockets:socket-address-in-use-error . address-in-use-error)
(iolib/sockets:socket-address-family-not-supported-error . socket-type-not-supported-error)
(iolib/sockets:socket-address-not-available-error . address-not-available-error)
(iolib/sockets:socket-network-down-error . network-down-error)
(iolib/sockets:socket-network-reset-error . network-reset-error)
(iolib/sockets:socket-network-unreachable-error . network-unreachable-error)
;; (iolib/sockets:socket-no-network-error . ?)
(iolib/sockets:socket-connection-aborted-error . connection-aborted-error)
(iolib/sockets:socket-connection-reset-error . connection-reset-error)
(iolib/sockets:socket-connection-refused-error . connection-refused-error)
(iolib/sockets:socket-connection-timeout-error . timeout-error)
;; (iolib/sockets:socket-connection-in-progress-error . ?)
(iolib/sockets:socket-endpoint-shutdown-error . network-down-error)
(iolib/sockets:socket-no-buffer-space-error . no-buffers-error)
(iolib/sockets:socket-host-down-error . host-down-error)
(iolib/sockets:socket-host-unreachable-error . host-unreachable-error)
;; (iolib/sockets:socket-already-connected-error . ?)
(iolib/sockets:socket-not-connected-error . connection-refused-error)
(iolib/sockets:socket-option-not-supported-error . operation-not-permitted-error)
(iolib/syscalls:eacces . operation-not-permitted-error)
(iolib/sockets:socket-operation-not-supported-error . operation-not-supported-error)
(iolib/sockets:unknown-protocol . protocol-not-supported-error)
;; (iolib/sockets:unknown-interface . ?)
(iolib/sockets:unknown-service . protocol-not-supported-error)
(iolib/sockets:socket-error . socket-error)
;; Nameservice errors (src/sockets/dns/conditions.lisp)
(iolib/sockets:resolver-error . ns-error)
(iolib/sockets:resolver-fail-error . ns-host-not-found-error)
(iolib/sockets:resolver-again-error . ns-try-again-condition)
(iolib/sockets:resolver-no-name-error . ns-no-recovery-error)
(iolib/sockets:resolver-unknown-error . ns-unknown-error)
))
;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 addresses,
;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)). Here we do the
;; conversion.
(defun iolib-vector-to-vector-quad (host)
(etypecase host
((or (vector t 4) ; IPv4
(array (unsigned-byte 8) (4)))
host)
((or (vector t 8) ; IPv6
(array (unsigned-byte 16) (8)))
(loop with vector = (make-array 16 :element-type '(unsigned-byte 8))
for i below 16 by 2
for word = (aref host (/ i 2))
do (setf (aref vector i) (ldb (byte 8 8) word)
(aref vector (1+ i)) (ldb (byte 8 0) word))
finally (return vector)))))
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(let* ((usock-error (cdr (assoc (type-of condition) +iolib-error-map+)))
(usock-error (if (functionp usock-error)
(funcall usock-error condition)
usock-error)))
(if usock-error
(if (typep usock-error 'socket-error)
(cond ((subtypep usock-error 'ns-error)
(error usock-error :socket socket :host-or-ip host-or-ip))
(t
(error usock-error :socket socket)))
(cond ((subtypep usock-error 'ns-condition)
(signal usock-error :socket socket :host-or-ip host-or-ip))
(t
(signal usock-error :socket socket))))
(error 'unknown-error
:real-error condition
:socket socket))))
(defun ipv6-address-p (host)
(iolib/sockets:ipv6-address-p (iolib/sockets:ensure-hostname host)))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline
(nodelay t) ;; nodelay == t is the ACL default
local-host local-port)
(declare (ignore element-type deadline nodelay))
(with-mapped-conditions (nil host)
(let* ((remote (when (and host port) (iolib/sockets:ensure-hostname host)))
(local (when (and local-host local-port)
(iolib/sockets:ensure-hostname local-host)))
(ipv6-p (or (and remote (ipv6-address-p remote)
(and local (ipv6-address-p local)))))
(socket (apply #'iolib/sockets:make-socket
`(:type ,protocol
:address-family :internet
:ipv6 ,ipv6-p
:connect ,(cond ((eq protocol :stream) :active)
((and host port) :active)
(t :passive))
,@(when local
`(:local-host ,local :local-port ,local-port))
:nodelay nodelay))))
(when remote
(apply #'iolib/sockets:connect
`(,socket ,remote :port ,port ,@(when timeout `(:wait ,timeout))))
(unless (iolib/sockets:socket-connected-p socket)
(close socket)
(error 'iolib/sockets:socket-error)))
(ecase protocol
(:stream
(make-stream-socket :stream socket :socket socket))
(:datagram
(make-datagram-socket socket :connected-p (and remote t)))))))
(defmethod socket-close ((usocket usocket))
(close (socket usocket)))
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(with-mapped-conditions ()
(case direction
(:input
(iolib/sockets:shutdown (socket usocket) :read t))
(:output
(iolib/sockets:shutdown (socket usocket) :write t))
(t ; :io by default
(iolib/sockets:shutdown (socket usocket) :read t :write t)))))
(defun socket-listen (host port
&key reuseaddress reuse-address
(backlog 5)
(element-type 'character))
(declare (ignore element-type))
(with-mapped-conditions (nil host)
(make-stream-server-socket
(iolib/sockets:make-socket :connect :passive
:address-family :internet
:local-host (iolib/sockets:ensure-hostname host)
:local-port port
:backlog backlog
:reuse-address (or reuse-address reuseaddress)))))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(declare (ignore element-type))
(with-mapped-conditions (usocket)
(let ((socket (iolib/sockets:accept-connection (socket usocket))))
(make-stream-socket :socket socket :stream socket))))
(defmethod get-local-address ((usocket usocket))
(iolib-vector-to-vector-quad
(iolib/sockets:address-to-vector (iolib/sockets:local-host (socket usocket)))))
(defmethod get-peer-address ((usocket stream-usocket))
(iolib-vector-to-vector-quad
(iolib/sockets:address-to-vector (iolib/sockets:remote-host (socket usocket)))))
(defmethod get-local-port ((usocket usocket))
(iolib/sockets:local-port (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(iolib/sockets:remote-port (socket usocket)))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(apply #'iolib/sockets:send-to
`(,(socket usocket) ,buffer :start ,offset :end ,(+ offset size)
,@(when (and host port)
`(:remote-host ,(iolib/sockets:ensure-hostname host)
:remote-port ,port)))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key start end)
(multiple-value-bind (buffer size host port)
(iolib/sockets:receive-from (socket usocket)
:buffer buffer :size length :start start :end end)
(values buffer size (iolib-vector-to-vector-quad host) port)))
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(multiple-value-bind (address more-addresses)
(iolib/sockets:lookup-hostname name :ipv6 iolib/sockets:*ipv6*)
(mapcar #'(lambda (x) (iolib-vector-to-vector-quad
(iolib/sockets:address-name x)))
(cons address more-addresses)))))
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
nil)) ;; TODO
(defvar *event-base*
(make-instance 'iolib/multiplex:event-base))
(defun %setup-wait-list (wait-list)
(setf (wait-list-%wait wait-list)
(or *event-base*
;; iolib/multiplex:*default-multiplexer* is used here
(make-instance 'iolib/multiplex:event-base))))
(defun make-usocket-read-handler (usocket disconnector)
(lambda (fd event exception)
(declare (ignore fd event exception))
(handler-case
(if (eq (state usocket) :write)
(setf (state usocket) :read-write)
(setf (state usocket) :read))
(end-of-file ()
(funcall disconnector :close)))))
(defun make-usocket-write-handler (usocket disconnector)
(lambda (fd event exception)
(declare (ignore fd event exception))
(handler-case
(if (eq (state usocket) :read)
(setf (state usocket) :read-write)
(setf (state usocket) :write))
(end-of-file ()
(funcall disconnector :close))
(iolib/streams:hangup ()
(funcall disconnector :close)))))
(defun make-usocket-error-handler (usocket disconnector)
(lambda (fd event exception)
(declare (ignore fd event exception))
(handler-case
(setf (state usocket) nil)
(end-of-file ()
(funcall disconnector :close))
(iolib/streams:hangup ()
(funcall disconnector :close)))))
(defun make-usocket-disconnector (event-base usocket)
(declare (ignore event-base))
(lambda (&rest events)
(let ((socket (socket usocket)))
;; if were asked to close the socket, we do so here
(when (member :close events)
(close socket :abort t)))))
(defun %add-waiter (wait-list waiter)
(let ((event-base (wait-list-%wait wait-list))
(fd (iolib/sockets:socket-os-fd (socket waiter))))
;; reset socket state
(setf (state waiter) nil)
;; set read handler
(unless (iolib/multiplex::fd-monitored-p event-base fd :read)
(iolib/multiplex:set-io-handler
event-base fd :read
(make-usocket-read-handler waiter
(make-usocket-disconnector event-base waiter))))
;; set write handler
#+ignore
(unless (iolib/multiplex::fd-monitored-p event-base fd :write)
(iolib/multiplex:set-io-handler
event-base fd :write
(make-usocket-write-handler waiter
(make-usocket-disconnector event-base waiter))))
;; set error handler
(unless (iolib/multiplex::fd-has-error-handler-p event-base fd)
(iolib/multiplex:set-error-handler
event-base fd
(make-usocket-error-handler waiter
(make-usocket-disconnector event-base waiter))))))
(defun %remove-waiter (wait-list waiter)
(let ((event-base (wait-list-%wait wait-list)))
(iolib/multiplex:remove-fd-handlers event-base
(iolib/sockets:socket-os-fd (socket waiter))
:read t
:write nil
:error t)))
;; NOTE: `wait-list-waiters` returns all usockets
(defun wait-for-input-internal (wait-list &key timeout)
(let ((event-base (wait-list-%wait wait-list)))
(handler-case
(iolib/multiplex:event-dispatch event-base :timeout timeout)
(iolib/streams:hangup ())
(end-of-file ()))
;; close the event-base after use
(unless (eq event-base *event-base*)
(close event-base))))

1001
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/lispworks.lisp Normal file
View file

File diff suppressed because it is too large Load diff

271
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mcl.lisp Normal file
View file

@ -0,0 +1,271 @@
;; MCL backend for USOCKET 0.4.1
;; Terje Norderhaug <terje@in-progress.com>, January 1, 2009
(in-package :usocket)
(defun handle-condition (condition &optional socket (host-or-ip nil))
; incomplete, needs to handle additional conditions
(flet ((raise-error (&optional socket-condition host-or-ip)
(if socket-condition
(cond ((typep socket-condition ns-error)
(error socket-condition :socket socket :host-or-ip host-or-ip))
(t
(error socket-condition :socket socket)))
(error 'unknown-error :socket socket :real-error condition))))
(typecase condition
(ccl:host-stopped-responding
(raise-error 'host-down-error host-or-ip))
(ccl:host-not-responding
(raise-error 'host-unreachable-error host-or-ip))
(ccl:connection-reset
(raise-error 'connection-reset-error))
(ccl:connection-timed-out
(raise-error 'timeout-error))
(ccl:opentransport-protocol-error
(raise-error 'protocol-not-supported-error))
(otherwise
(raise-error condition host-or-ip)))))
(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
local-host local-port (protocol :stream))
(when (eq nodelay :if-supported)
(setf nodelay t))
(ecase protocol
(:stream
(with-mapped-conditions (nil host)
(let* ((socket
(make-instance 'active-socket
:remote-host (when host (host-to-hostname host))
:remote-port port
:local-host (when local-host (host-to-hostname local-host))
:local-port local-port
:deadline deadline
:nodelay nodelay
:connect-timeout (and timeout (round (* timeout 60)))
:element-type element-type))
(stream (socket-open-stream socket)))
(make-stream-socket :socket socket :stream stream))))
(:datagram
(with-mapped-conditions (nil (or host local-host))
(make-datagram-socket
(ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host))
:local-port local-port))))))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(socket (with-mapped-conditions ()
(make-instance 'passive-socket
:local-port port
:local-host (host-to-hbo host)
:reuse-address reuseaddress
:backlog backlog))))
(make-stream-server-socket socket :element-type element-type)))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(let* ((socket (socket usocket))
(stream (with-mapped-conditions (usocket)
(socket-accept socket :element-type element-type))))
(make-stream-socket :socket socket :stream stream)))
(defmethod socket-close ((usocket usocket))
(with-mapped-conditions (usocket)
(socket-close (socket usocket))))
(defmethod socket-shutdown ((usocket usocket) direction)
(declare (ignore usocket direction))
;; As far as I can tell there isn't a way to shutdown a socket in mcl.
(unsupported "shutdown" 'socket-shutdown))
(defmethod ccl::stream-close ((usocket usocket))
(socket-close usocket))
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(list (hbo-to-vector-quad (ccl::get-host-address
(host-to-hostname name))))))
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
(ccl::inet-host-name (host-to-hbo address))))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defmethod get-local-address ((usocket usocket))
(hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) ""))))
(defmethod get-local-port ((usocket usocket))
(local-port (socket usocket)))
(defmethod get-peer-address ((usocket stream-usocket))
(hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket)))))
(defmethod get-peer-port ((usocket stream-usocket))
(remote-port (socket usocket)))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun %remove-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BASIC MCL SOCKET IMPLEMENTATION
(defclass socket ()
((local-port :reader local-port :initarg :local-port)
(local-host :reader local-host :initarg :local-host)
(element-type :reader element-type :initform 'ccl::base-character :initarg :element-type)))
(defclass active-socket (socket)
((remote-host :reader remote-host :initarg :remote-host)
(remote-port :reader remote-port :initarg :remote-port)
(deadline :initarg :deadline)
(nodelay :initarg :nodelay)
(connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout
:type (or null fixnum) :documentation "ticks (60th of a second)")))
(defmethod socket-open-stream ((socket active-socket))
(ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket)
:element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte)
:connect-timeout (connect-timeout socket)))
(defmethod socket-close ((socket active-socket))
NIL)
(defclass passive-socket (socket)
((streams :accessor socket-streams :type list :initform NIL
:documentation "Circular list of streams with first element the next to open")
(reuse-address :reader reuse-address :initarg :reuse-address)
(lock :reader socket-lock :initform (ccl:make-lock "Socket"))))
(defmethod initialize-instance :after ((socket passive-socket) &key backlog)
(loop repeat backlog
collect (socket-open-listener socket) into streams
finally (setf (socket-streams socket)
(cdr (rplacd (last streams) streams))))
(when (zerop (local-port socket))
(setf (slot-value socket 'local-port)
(or (ccl::process-wait-with-timeout "binding port" (* 10 60)
#'ccl::stream-local-port (car (socket-streams socket)))
(error "timeout")))))
(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket)))
(flet ((connection-established-p (stream)
(ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
(let ((state (ccl::opentransport-stream-connection-state stream)))
(not (eq :unbnd state))))))
(with-mapped-conditions ()
(ccl:with-lock-grabbed (lock nil "Socket Lock")
(let ((connection (shiftf (car (socket-streams socket))
(socket-open-listener socket element-type))))
(pop (socket-streams socket))
(ccl:process-wait "Accepting" #'connection-established-p connection)
connection)))))
(defmethod socket-close ((socket passive-socket))
(loop
with streams = (socket-streams socket)
for (stream tail) on streams
do (close stream :abort T)
until (eq tail streams)
finally (setf (socket-streams socket) NIL)))
(defmethod socket-open-listener (socket &optional element-type)
; see http://code.google.com/p/mcl/issues/detail?id=28
(let* ((ccl::*passive-interface-address* (local-host socket))
(new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress)
:reuse-local-port-p (reuse-address socket)
:element-type (if (subtypep (or element-type (element-type socket))
'character)
'ccl::base-character
'unsigned-byte))))
(declare (special ccl::*passive-interface-address*))
new))
(defmethod input-available-p ((stream ccl::opentransport-stream))
(macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body)
"Evaluates the body if and only if the lock is successfully grabbed"
;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock
(let ((needs-unlocking-p (gensym))
(lock-var (gensym)))
`(let* ((,lock-var ,lock)
(ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*))
(,needs-unlocking-p (needs-unlocking-p ,lock-var)))
(declare (dynamic-extent ccl::*grabbed-io-buffer-locks*))
(when ,needs-unlocking-p
(,(if multiple-value-p 'multiple-value-prog1 'prog1)
(progn ,@body)
(ccl::%release-io-buffer-lock ,lock-var)))))))
(labels ((needs-unlocking-p (lock)
(declare (type ccl::lock lock))
;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line:
(ccl::%io-buffer-lock-really-grabbed-p lock)
(ccl:store-conditional lock nil ccl:*current-process*)))
"similar to stream-listen on buffered-input-stream-mixin but without waiting for lock"
(let ((io-buffer (ccl::stream-io-buffer stream)))
(or (not (eql 0 (ccl::io-buffer-incount io-buffer)))
(ccl::io-buffer-untyi-char io-buffer)
(locally (declare (optimize (speed 3) (safety 0)))
(when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer))
(funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer))))))))
(defmethod connection-established-p ((stream ccl::opentransport-stream))
(ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
(let ((state (ccl::opentransport-stream-connection-state stream)))
(not (eq :unbnd state)))))
(defun wait-for-input-internal (wait-list &key timeout &aux result)
(labels ((ready-sockets (sockets)
(dolist (sock sockets result)
(when (cond ((stream-usocket-p sock)
(input-available-p (socket-stream sock)))
((stream-server-usocket-p sock)
(let ((ot-stream (first (socket-streams (socket sock)))))
(or (input-available-p ot-stream)
(connection-established-p ot-stream)))))
(push sock result)))))
(with-mapped-conditions ()
(ccl:process-wait-with-timeout
"socket input"
(when timeout (truncate (* timeout 60)))
#'ready-sockets
(wait-list-waiters wait-list)))
(nreverse result)))
;;; datagram socket methods
(defmethod initialize-instance :after ((usocket datagram-usocket) &key)
(with-slots (socket send-buffer recv-buffer) usocket
(setq send-buffer
(ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))
(setq recv-buffer
(ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(with-mapped-conditions (usocket host)
(with-slots (socket send-buffer) usocket
(unless (and host port)
(unsupported 'host 'socket-send))
(ccl::send-message socket send-buffer buffer size host port offset))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(with-mapped-conditions (usocket)
(with-slots (socket recv-buffer) usocket
(ccl::receive-message socket recv-buffer buffer length))))
(defmethod socket-close ((socket datagram-usocket))
nil) ; TODO

99
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mezzano.lisp Normal file
View file

@ -0,0 +1,99 @@
;;;; -*- Mode: Common-Lisp -*-
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defun handle-condition (condition &optional (socket nil))
(typecase condition
;; TODO: Add additional conditions as appropriate
(mezzano.network.tcp:connection-timed-out
(error 'timeout-error :socket socket))))
(defun socket-connect (host port &key (protocol :stream) element-type
timeout deadline (nodelay nil nodelay-p)
local-host local-port)
(declare (ignore local-host local-port))
(when deadline
(unsupported 'deadline 'socket-connect))
(when (and nodelay-p (not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(when timeout
(unsupported 'timeout 'socket-connect))
(with-mapped-conditions ()
(ecase protocol
(:stream
(let ((s (mezzano.network.tcp:tcp-stream-connect host port :element-type element-type)))
(make-stream-socket :socket s
:stream s)))
(:datagram
;; TODO:
(unsupported 'datagram 'socket-connect)))))
(defun socket-listen (host port &key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
(let ((ip (mezzano.network.ip:make-ipv4-address host)))
(make-stream-server-socket (mezzano.network.tcp:tcp-listen ip port :backlog backlog)
:element-type element-type)))
(defun get-hosts-by-name (name)
(declare (ignore name)))
(defun get-host-by-address (address)
(declare (ignore address)))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun %remove-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun wait-for-input-internal (wait-list &key timeout)
(declare (ignore wait-list timeout)))
(defmethod socket-close ((usocket stream-usocket))
(with-mapped-conditions ()
(close (socket-stream usocket))))
(defmethod socket-close ((usocket stream-server-usocket))
(with-mapped-conditions ()
(mezzano.network.tcp:close-tcp-listener (socket usocket))))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(declare (ignore element-type))
(with-mapped-conditions (usocket)
(let ((s (mezzano.network.tcp:tcp-accept (socket usocket))))
(make-stream-socket :socket s
:stream s))))
(defmethod get-local-name ((usocket stream-usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defmethod get-local-address ((usocket stream-usocket))
(mezzano.network.ip:ipv4-address-to-string
(mezzano.network.tcp:tcp-connection-local-ip
(mezzano.network.tcp:tcp-stream-connection (socket usocket)))))
(defmethod get-local-port ((usocket stream-usocket))
(mezzano.network.tcp:tcp-connection-local-port
(mezzano.network.tcp:tcp-stream-connection (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(mezzano.network.ip:ipv4-address-to-string
(mezzano.network.tcp:tcp-connection-remote-ip
(mezzano.network.tcp:tcp-stream-connection (socket usocket)))))
(defmethod get-peer-port ((usocket stream-usocket))
(mezzano.network.tcp:tcp-connection-remote-port
(mezzano.network.tcp:tcp-stream-connection (socket usocket))))

155
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mocl.lisp Normal file
View file

@ -0,0 +1,155 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(declare (ignore socket))
(signal condition))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
(local-host nil local-host-p)
(local-port nil local-port-p))
(when (and nodelay-specified
(not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(when deadline (unsupported 'deadline 'socket-connect))
(when timeout (unimplemented 'timeout 'socket-connect))
(when local-host-p
(unimplemented 'local-host 'socket-connect))
(when local-port-p
(unimplemented 'local-port 'socket-connect))
(let (socket)
(ecase protocol
(:stream
(setf socket (rt::socket-connect host port))
(let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character)))))
(make-stream-socket :socket socket :stream stream)))
(:datagram
(error 'unsupported
:feature '(protocol :datagram)
:context 'socket-connect)))))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(unimplemented 'socket-listen 'mocl))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(unimplemented 'socket-accept 'mocl))
;; Sockets and their associated streams are modelled as
;; different objects. Be sure to close the socket stream
;; when closing stream-sockets; it makes sure buffers
;; are flushed and the socket is closed correctly afterwards.
(defmethod socket-close ((usocket usocket))
"Close socket."
(rt::socket-shutdown usocket)
(rt::c-fclose usocket))
(defmethod socket-close ((usocket stream-usocket))
"Close socket."
(close (socket-stream usocket)))
;; (defmethod socket-close :after ((socket datagram-usocket))
;; (setf (%open-p socket) nil))
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(declare (ignore usocket direction))
;; sure would be nice if there was some documentation for mocl...
(unimplemented "shutdown" 'socket-shutdown))
;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
;; (let ((s (socket usocket))
;; (host (if host (host-to-hbo host)))
;; (real-buffer (if (zerop offset)
;; buffer
;; (subseq buffer offset (+ offset size)))))
;; (multiple-value-bind (result errno)
;; (ext:inet-socket-send-to s real-buffer size
;; :remote-host host :remote-port port)
;; (or result
;; (mocl-map-socket-error errno :socket usocket)))))
;; (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
;; (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
;; (integer 0) ; size
;; (unsigned-byte 32) ; host
;; (unsigned-byte 16))) ; port
;; (let ((s (socket socket)))
;; (let ((real-buffer (or buffer
;; (make-array length :element-type '(unsigned-byte 8))))
;; (real-length (or length
;; (length buffer))))
;; (multiple-value-bind (result errno remote-host remote-port)
;; (ext:inet-socket-receive-from s real-buffer real-length)
;; (if result
;; (values real-buffer result remote-host remote-port)
;; (mocl-map-socket-error errno :socket socket))))))
;; (defmethod get-local-name ((usocket usocket))
;; (multiple-value-bind (address port)
;; (with-mapped-conditions (usocket)
;; (ext:get-socket-host-and-port (socket usocket)))
;; (values (hbo-to-vector-quad address) port)))
;; (defmethod get-peer-name ((usocket stream-usocket))
;; (multiple-value-bind (address port)
;; (with-mapped-conditions (usocket)
;; (ext:get-peer-host-and-port (socket usocket)))
;; (values (hbo-to-vector-quad address) port)))
;; (defmethod get-local-address ((usocket usocket))
;; (nth-value 0 (get-local-name usocket)))
;; (defmethod get-peer-address ((usocket stream-usocket))
;; (nth-value 0 (get-peer-name usocket)))
;; (defmethod get-local-port ((usocket usocket))
;; (nth-value 1 (get-local-name usocket)))
;; (defmethod get-peer-port ((usocket stream-usocket))
;; (nth-value 1 (get-peer-name usocket)))
;; (defun get-host-by-address (address)
;; (multiple-value-bind (host errno)
;; (ext:lookup-host-entry (host-byte-order address))
;; (cond (host
;; (ext:host-entry-name host))
;; (t
;; (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
;; (cond (condition
;; (error condition :host-or-ip address))
;; (t
;; (error 'ns-unknown-error :host-or-ip address
;; :real-error errno))))))))
(defun get-hosts-by-name (name)
(rt::lookup-host name))
;; (defun get-host-name ()
;; (unix:unix-gethostname))
;;
;;
;; WAIT-LIST part
;;
(defun %add-waiter (wl waiter)
(declare (ignore wl waiter)))
(defun %remove-waiter (wl waiter)
(declare (ignore wl waiter)))
(defun %setup-wait-list (wl)
(declare (ignore wl)))
(defun wait-for-input-internal (wait-list &key timeout)
(unimplemented 'wait-for-input-internal 'mocl))

268
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/openmcl.lisp Normal file
View file

@ -0,0 +1,268 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defun get-host-name ()
(ccl::%stack-block ((resultbuf 256))
(when (zerop (#_gethostname resultbuf 256))
(ccl::%get-cstring resultbuf))))
(defparameter +openmcl-error-map+
'((:address-in-use . address-in-use-error)
(:connection-aborted . connection-aborted-error)
(:no-buffer-space . no-buffers-error)
(:connection-timed-out . timeout-error)
(:connection-refused . connection-refused-error)
(:host-unreachable . host-unreachable-error)
(:host-down . host-down-error)
(:network-down . network-down-error)
(:address-not-available . address-not-available-error)
(:network-reset . network-reset-error)
(:connection-reset . connection-reset-error)
(:shutdown . shutdown-error)
(:access-denied . operation-not-permitted-error)))
(defparameter +openmcl-nameserver-error-map+
'((:no-recovery . ns-no-recovery-error)
(:try-again . ns-try-again-condition)
(:host-not-found . ns-host-not-found-error)))
;; we need something which the openmcl implementors 'forgot' to do:
;; wait for more than one socket-or-fd
(defun input-available-p (sockets &optional ticks-to-wait)
(ccl::rletz ((tv :timeval))
(ccl::ticks-to-timeval ticks-to-wait tv)
;;### The trickery below can be moved to the wait-list now...
(ccl::%stack-block ((infds ccl::*fd-set-size*))
(ccl::fd-zero infds)
(let ((max-fd -1))
(dolist (sock sockets)
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
(when fd ;; may be NIL if closed
(setf max-fd (max max-fd fd))
(ccl::fd-set fd infds))))
(let ((res (#_select (1+ max-fd)
infds (ccl::%null-ptr) (ccl::%null-ptr)
(if ticks-to-wait tv (ccl::%null-ptr)))))
(when (> res 0)
(dolist (sock sockets)
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
(when (and fd (ccl::fd-is-set fd infds))
(setf (state sock) :READ)))))
sockets)))))
(defun raise-error-from-id (condition-id socket real-condition)
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
(if usock-err
(error usock-err :socket socket)
(error 'unknown-error :socket socket :real-error real-condition))))
(defun handle-condition (condition &optional socket (host-or-ip nil))
(typecase condition
(openmcl-socket:socket-error
(raise-error-from-id (openmcl-socket:socket-error-identifier condition)
socket condition))
(ccl:input-timeout
(error 'timeout-error :socket socket))
(ccl:communication-deadline-expired
(error 'deadline-timeout-error :socket socket))
(ccl::socket-creation-error #| ugh! |#
(let* ((condition-id (ccl::socket-creation-error-identifier condition))
(nameserver-error (cdr (assoc condition-id
+openmcl-nameserver-error-map+))))
(if nameserver-error
(if (typep nameserver-error 'serious-condition)
(error nameserver-error :host-or-ip host-or-ip)
(signal nameserver-error :host-or-ip host-or-ip))
(raise-error-from-id condition-id socket condition))))))
(defun to-format (element-type protocol)
(cond ((null element-type)
(ecase protocol ; default value of different protocol
(:stream :text)
(:datagram :binary)))
((subtypep element-type 'character)
:text)
(t :binary)))
#-ipv6
(defun socket-connect (host port &key (protocol :stream) element-type
timeout deadline nodelay
local-host local-port)
(when (eq nodelay :if-supported)
(setf nodelay t))
(with-mapped-conditions (nil host)
(ecase protocol
(:stream
(let ((mcl-sock
(openmcl-socket:make-socket :remote-host (host-to-hostname host)
:remote-port port
:local-host local-host
:local-port local-port
:format (to-format element-type protocol)
:external-format ccl:*default-external-format*
:deadline deadline
:nodelay nodelay
:connect-timeout timeout)))
(make-stream-socket :stream mcl-sock :socket mcl-sock)))
(:datagram
(let* ((mcl-sock
(openmcl-socket:make-socket :address-family :internet
:type :datagram
:local-host local-host
:local-port local-port
:input-timeout timeout
:format (to-format element-type protocol)
:external-format ccl:*default-external-format*))
(usocket (make-datagram-socket mcl-sock)))
(when (and host port)
(ccl::inet-connect (ccl::socket-device mcl-sock)
(ccl::host-as-inet-host host)
(ccl::port-as-inet-port port "udp")))
(setf (connected-p usocket) t)
usocket)))))
#-ipv6
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(real-host (host-to-hostname host))
(sock (with-mapped-conditions (nil host)
(apply #'openmcl-socket:make-socket
(append (list :connect :passive
:reuse-address reuseaddress
:local-port port
:backlog backlog
:format (to-format element-type :stream))
(unless (eq host *wildcard-host*)
(list :local-host real-host)))))))
(make-stream-server-socket sock :element-type element-type)))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(declare (ignore element-type)) ;; openmcl streams are bi/multivalent
(let ((sock (with-mapped-conditions (usocket)
(openmcl-socket:accept-connection (socket usocket)))))
(make-stream-socket :socket sock :stream sock)))
;; One close method is sufficient because sockets
;; and their associated objects are represented
;; by the same object.
(defmethod socket-close ((usocket usocket))
(with-mapped-conditions (usocket)
(close (socket usocket))))
(defmethod socket-shutdown ((usocket usocket) direction)
(with-mapped-conditions (usocket)
(openmcl-socket:shutdown (socket usocket) :direction direction)))
#-ipv6
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(with-mapped-conditions (usocket host)
(if (and host port)
(openmcl-socket:send-to (socket usocket) buffer size
:remote-host (host-to-hbo host)
:remote-port port
:offset offset)
;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
;; so we have to define our own.
(let* ((socket (socket usocket))
(fd (ccl::socket-device socket)))
(multiple-value-setq (buffer offset)
(ccl::verify-socket-buffer buffer offset size))
(ccl::%stack-block ((bufptr size))
(ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
(ccl::socket-call socket "send"
(ccl::with-eagain fd :output
(ccl::ignoring-eintr
(ccl::check-socket-error (#_send fd bufptr size 0))))))))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(with-mapped-conditions (usocket)
(openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
(defun usocket-host-address (address)
(cond
((integerp address)
(hbo-to-vector-quad address))
((and (arrayp address)
(= (length address) 16)
(every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
(make-array 4 :displaced-to address :displaced-index-offset 12))
(t
address)))
(defmethod get-local-address ((usocket usocket))
(usocket-host-address (openmcl-socket:local-host (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(usocket-host-address (openmcl-socket:remote-host (socket usocket))))
(defmethod get-local-port ((usocket usocket))
(openmcl-socket:local-port (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(openmcl-socket:remote-port (socket usocket)))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
(openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
(host-to-hostname name))))))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun %remove-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(let* ((ticks-timeout (truncate (* (or timeout 1)
ccl::*ticks-per-second*))))
(input-available-p (wait-list-waiters wait-list)
(when timeout ticks-timeout))
wait-list)))
;;; Helper functions for option.lisp
(defun get-socket-option-reuseaddr (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_REUSEADDR))
(defun set-socket-option-reuseaddr (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_REUSEADDR value))
(defun get-socket-option-broadcast (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_BROADCAST))
(defun set-socket-option-broadcast (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_BROADCAST value))
(defun get-socket-option-tcp-nodelay (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$IPPROTO_TCP #$TCP_NODELAY))
(defun set-socket-option-tcp-nodelay (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$IPPROTO_TCP #$TCP_NODELAY value))

935
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/sbcl.lisp Normal file
View file

@ -0,0 +1,935 @@
;;;; -*- Mode: Common-Lisp -*-
;;;; See LICENSE for licensing information.
(in-package :usocket)
#+sbcl
(progn
#-win32
(defun get-host-name ()
(sb-unix:unix-gethostname))
;; we assume winsock has already been loaded, after all,
;; we already loaded sb-bsd-sockets and sb-alien
#+win32
(defun get-host-name ()
(sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
(let ((result (sb-alien:alien-funcall
(sb-alien:extern-alien "gethostname"
(sb-alien:function sb-alien:int
(* sb-alien:char)
sb-alien:int))
(sb-alien:cast buf (* sb-alien:char))
256)))
(when (= result 0)
(sb-alien:cast buf sb-alien:c-string))))))
#+(and ecl (not ecl-bytecmp))
(progn
#-:wsock
(ffi:clines
"#include <errno.h>"
"#include <sys/socket.h>"
"#include <unistd.h>")
#+:wsock
(ffi:clines
"#ifndef FD_SETSIZE"
"#define FD_SETSIZE 1024"
"#endif"
"#include <winsock2.h>")
(ffi:clines
#+:msvc "#include <time.h>"
#-:msvc "#include <sys/time.h>"
"#include <ecl/ecl-inl.h>")
#|
#+:prefixed-api
(ffi:clines
"#define CONS(x, y) ecl_cons((x), (y))"
"#define MAKE_INTEGER(x) ecl_make_integer((x))")
#-:prefixed-api
(ffi:clines
"#define CONS(x, y) make_cons((x), (y))"
"#define MAKE_INTEGER(x) make_integer((x))")
|#
(defun cerrno ()
(ffi:c-inline () () :int
"errno" :one-liner t))
(defun fd-setsize ()
(ffi:c-inline () () :fixnum
"FD_SETSIZE" :one-liner t))
(defun fdset-alloc ()
(ffi:c-inline () () :pointer-void
"ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
(defun fdset-zero (fdset)
(ffi:c-inline (fdset) (:pointer-void) :void
"FD_ZERO((fd_set*)#0)" :one-liner t))
(defun fdset-set (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_SET(#1,(fd_set*)#0)" :one-liner t))
(defun fdset-clr (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_CLR(#1,(fd_set*)#0)" :one-liner t))
(defun fdset-fd-isset (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
"FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
(declaim (inline cerrno
fd-setsize
fdset-alloc
fdset-zero
fdset-set
fdset-clr
fdset-fd-isset))
(defun get-host-name ()
(ffi:c-inline
() () :object
"{ char *buf = (char *) ecl_alloc_atomic(257);
if (gethostname(buf,256) == 0)
@(return) = make_simple_base_string(buf);
else
@(return) = Cnil;
}" :one-liner nil :side-effects nil))
(defun read-select (wl to-secs &optional (to-musecs 0))
(let* ((sockets (wait-list-waiters wl))
(rfds (wait-list-%wait wl))
(max-fd (reduce #'(lambda (x y)
(let ((sy (sb-bsd-sockets:socket-file-descriptor
(socket y))))
(if (< x sy) sy x)))
(cdr sockets)
:initial-value (sb-bsd-sockets:socket-file-descriptor
(socket (car sockets))))))
(fdset-zero rfds)
(dolist (sock sockets)
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock))))
(let ((count
(ffi:c-inline (to-secs to-musecs rfds max-fd)
(t :unsigned-int :pointer-void :int)
:int
"
int count;
struct timeval tv;
struct timeval tvs;
struct timeval tve;
unsigned long elapsed;
unsigned long remaining;
int retval = -1;
if (#0 != Cnil) {
tv.tv_sec = fixnnint(#0);
tv.tv_usec = #1;
}
remaining = ((tv.tv_sec*1000000) + tv.tv_usec);
do {
(void)gettimeofday(&tvs, NULL); // start time
retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,
(#0 != Cnil) ? &tv : NULL);
if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) {
(void)gettimeofday(&tve, NULL); // end time
elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);
remaining = remaining - elapsed;
if ( remaining < 0 ) { // already past timeout, just exit
retval = 0;
break;
}
tv.tv_sec = remaining / 1000000;
tv.tv_usec = remaining - (tv.tv_sec * 1000000);
}
} while ((retval < 0) && (errno == EINTR));
@(return) = retval;
" :one-liner nil)))
(cond
((= 0 count)
(values nil nil))
((< count 0)
;; check for EAGAIN; these should not err
(values nil (cerrno)))
(t
(dolist (sock sockets)
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock)))
(setf (state sock) :READ))))))))
) ; progn
(defun map-socket-error (sock-err)
(map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
(defparameter +sbcl-condition-map+
'((interrupted-error . interrupted-condition)))
(defparameter +sbcl-error-map+
`((sb-bsd-sockets:address-in-use-error . address-in-use-error)
(sb-bsd-sockets::no-address-error . address-not-available-error)
(sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)
(sb-bsd-sockets:connection-refused-error . connection-refused-error)
(sb-bsd-sockets:invalid-argument-error . invalid-argument-error)
(sb-bsd-sockets:no-buffers-error . no-buffers-error)
(sb-bsd-sockets:operation-not-supported-error
. operation-not-supported-error)
(sb-bsd-sockets:operation-not-permitted-error
. operation-not-permitted-error)
(sb-bsd-sockets:protocol-not-supported-error
. protocol-not-supported-error)
#-(or ecl clasp)
(sb-bsd-sockets:unknown-protocol
. protocol-not-supported-error)
(sb-bsd-sockets:socket-type-not-supported-error
. socket-type-not-supported-error)
(sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
(sb-bsd-sockets:operation-timeout-error . timeout-error)
#-(or ecl clasp)
(sb-sys:io-timeout . timeout-error)
#+sbcl
(sb-ext:timeout . timeout-error)
(sb-bsd-sockets:socket-error . ,#'map-socket-error)
;; Nameservice errors: mapped to unknown-error
#-(or ecl clasp)
(sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
#-(or ecl clasp)
(sb-bsd-sockets:try-again-error . ns-try-again-condition)
#-(or ecl clasp)
(sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
;; this function servers as a general template for other backends
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(typecase condition
(serious-condition
(let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+)))
(usock-error (if (functionp usock-error)
(funcall usock-error condition)
usock-error)))
(declare (type symbol usock-error))
(if usock-error
(cond ((subtypep usock-error 'ns-error)
(error usock-error :socket socket :host-or-ip host-or-ip))
(t
(error usock-error :socket socket)))
(error 'unknown-error
:real-error condition
:socket socket))))
(condition
(let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+)))
(usock-cond (if (functionp usock-cond)
(funcall usock-cond condition)
usock-cond)))
(if usock-cond
(cond ((subtypep usock-cond 'ns-condition)
(signal usock-cond :socket socket :host-or-ip host-or-ip))
(t
(signal usock-cond :socket socket)))
(signal 'unknown-condition
:real-condition condition
:socket socket))))))
;;; "The socket stream ends up with a bogus name as it is created before
;;; the socket is connected, making things harder to debug than they need
;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>
(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 <nikodemus@random-state.net>
#+(and sbcl (not win32))
(defmacro %with-timeout ((seconds timeout-form) &body body)
"Runs BODY as an implicit PROGN with timeout of SECONDS. If
timeout occurs before BODY has finished, BODY is unwound and
TIMEOUT-FORM is executed with its values returned instead.
Note that BODY is unwound asynchronously when a timeout occurs,
so unless all code executed during it -- including anything
down the call chain -- is asynch unwind safe, bad things will
happen. Use with care."
(let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
(timeout (gensym)) (block (gensym)))
`(block ,block
(tagbody
(flet ((,unwind ()
(go ,timeout))
(,exec ()
,@body))
(declare (dynamic-extent #',exec #',unwind))
(let ((,timer (sb-ext:make-timer #',unwind)))
(declare (dynamic-extent ,timer))
(sb-sys:without-interrupts
(unwind-protect
(progn
(sb-ext:schedule-timer ,timer ,seconds)
(return-from ,block
(sb-sys:with-local-interrupts
(,exec))))
(sb-ext:unschedule-timer ,timer)))))
,timeout
(return-from ,block ,timeout-form)))))
(defun get-hosts-by-name (name)
(with-mapped-conditions (nil name)
(multiple-value-bind (host4 host6)
(sb-bsd-sockets:get-host-by-name name)
(let ((addr4 (when host4
(sb-bsd-sockets::host-ent-addresses host4)))
(addr6 (when host6
(sb-bsd-sockets::host-ent-addresses host6))))
(append addr4 addr6)))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
local-host local-port
&aux
(sockopt-tcp-nodelay-p
(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
(when deadline (unsupported 'deadline 'socket-connect))
#+(or ecl clasp)
(when timeout (unsupported 'timeout 'socket-connect))
(when (and nodelay-specified
;; 20080802: ECL added this function to its sockets
;; package today. There's no guarantee the functions
;; we need are available, but we can make sure not to
;; call them if they aren't
(not (eq nodelay :if-supported))
(not sockopt-tcp-nodelay-p))
(unsupported 'nodelay 'socket-connect))
(when (eq nodelay :if-supported)
(setf nodelay t))
(let* ((remote (when host
(car (get-hosts-by-name (host-to-hostname host)))))
(local (when local-host
(car (get-hosts-by-name (host-to-hostname local-host)))))
(ipv6 (or (and remote (= 16 (length remote)))
(and local (= 16 (length local)))))
(socket (make-instance #+sbcl (if ipv6
'sb-bsd-sockets::inet6-socket
'sb-bsd-sockets:inet-socket)
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
:type protocol
:protocol (case protocol
(:stream :tcp)
(:datagram :udp))))
usocket
ok)
(unwind-protect
(progn
(ecase protocol
(:stream
;; If make a real socket stream before the socket is
;; connected, it gets a misleading name so supply a
;; dummy value to start with.
(setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
;; to pass compilation on ECL without it.
(when (and nodelay-specified sockopt-tcp-nodelay-p)
(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
(when (or local-host local-port)
(sb-bsd-sockets:socket-bind socket
(if ipv6
(or local (ipv6-host-to-vector "::0"))
(or local (host-to-vector-quad *wildcard-host*)))
(or local-port *auto-port*)))
(with-mapped-conditions (usocket host)
#+(and sbcl (not win32))
(labels ((connect ()
(sb-bsd-sockets:socket-connect socket remote port)))
(if timeout
(%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
(connect)))
#+(or ecl clasp (and sbcl win32))
(sb-bsd-sockets:socket-connect socket remote port)
;; Now that we're connected make the stream.
(setf (socket-stream usocket)
(sb-bsd-sockets:socket-make-stream socket
:input t :output t :buffering :full
:element-type element-type
;; Robert Brown <robert.brown@gmail.com> 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 <nikodemus@random-state.net> said on Aug 8, 2011:
;; It's set to T for purely historical reasons, and will soon change to
;; NIL in SBCL. (The docstring has warned of T being a temporary default
;; for as long as the :SERVE-EVENTS keyword argument has existed.)
:serve-events nil))))
(:datagram
(when (or local-host local-port)
(sb-bsd-sockets:socket-bind socket
(if ipv6
(or local (ipv6-host-to-vector "::0"))
(or local (host-to-vector-quad *wildcard-host*)))
(or local-port *auto-port*)))
(setf usocket (make-datagram-socket socket))
(when (and host port)
(with-mapped-conditions (usocket)
(sb-bsd-sockets:socket-connect socket remote port)
(setf (connected-p usocket) t)))))
(setf ok t))
;; Clean up in case of an error.
(unless ok
(sb-bsd-sockets:socket-close socket :abort t)))
usocket))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* (#+sbcl
(local (when host
(car (get-hosts-by-name (host-to-hostname host)))))
#+sbcl
(ipv6 (and local (= 16 (length local))))
(reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
local
(hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
#+(or ecl clasp) (host-to-vector-quad host))
(sock (make-instance #+sbcl (if ipv6
'sb-bsd-sockets::inet6-socket
'sb-bsd-sockets:inet-socket)
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(handler-case
(with-mapped-conditions (nil host)
(setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)
(sb-bsd-sockets:socket-bind sock ip port)
(sb-bsd-sockets:socket-listen sock backlog)
(make-stream-server-socket sock :element-type element-type))
(t (c)
;; Make sure we don't leak filedescriptors
(sb-bsd-sockets:socket-close sock)
(error c)))))
;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
;;; instead of raising a condition. It's always possible for
;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
;;; was detected to be ready: connection might be reset, for example.
;;;
;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(with-mapped-conditions (usocket)
(let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))
(when socket
(prog1
(make-stream-socket
:socket socket
:stream (sb-bsd-sockets:socket-make-stream
socket
:input t :output t :buffering :full
:element-type (or element-type
(element-type usocket))))
;; next time wait for event again if we had EAGAIN/EINTR
;; or else we'd enter a tight loop of failed accepts
#+win32
(setf (%ready-p usocket) nil))))))
;; Sockets and their associated streams are modelled as
;; different objects. Be sure to close the stream (which
;; closes the socket too) when closing a stream-socket.
(defmethod socket-close ((usocket usocket))
(with-mapped-conditions (usocket)
(sb-bsd-sockets:socket-close (socket usocket))))
(defmethod socket-close ((usocket stream-usocket))
(with-mapped-conditions (usocket)
(close (socket-stream usocket))))
#+sbcl
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(with-mapped-conditions (usocket)
(sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))
#+ecl
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
(direction-flag (ecase direction
(:input 0)
(:output 1))))
(unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int
"shutdown(#0, #1)" :one-liner t))
(error (map-errno-error (cerrno))))))
#+clasp
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
(direction-flag (ecase direction
(:input 0)
(:output 1))))
(unless (zerop (sockets-internal:shutdown sock-fd direction-flag))
(error (map-errno-error (cerrno))))))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(let ((remote (when host
(car (get-hosts-by-name (host-to-hostname host))))))
(with-mapped-conditions (usocket host)
(let* ((s (socket usocket))
(dest (if (and host port) (list remote port) nil))
(real-buffer (if (zerop offset)
buffer
(subseq buffer offset (+ offset size)))))
(sb-bsd-sockets:socket-send s real-buffer size :address dest)))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length
&key (element-type '(unsigned-byte 8)))
#+sbcl
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
(integer 0) ; size
(simple-array (unsigned-byte 8) (*)) ; host
(unsigned-byte 16))) ; port
(with-mapped-conditions (usocket)
(let ((s (socket usocket)))
(sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
(defmethod get-local-name ((usocket usocket))
(sb-bsd-sockets:socket-name (socket usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(sb-bsd-sockets:socket-peername (socket usocket)))
(defmethod get-local-address ((usocket usocket))
(nth-value 0 (get-local-name usocket)))
(defmethod get-peer-address ((usocket stream-usocket))
(nth-value 0 (get-peer-name usocket)))
(defmethod get-local-port ((usocket usocket))
(nth-value 1 (get-local-name usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(nth-value 1 (get-peer-name usocket)))
(defun get-host-by-address (address)
(with-mapped-conditions (nil address)
(sb-bsd-sockets::host-ent-name
(sb-bsd-sockets:get-host-by-address address))))
#+(and sbcl (not win32))
(progn
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(push (socket waiter) (wait-list-%wait wait-list)))
(defun %remove-waiter (wait-list waiter)
(setf (wait-list-%wait wait-list)
(remove (socket waiter) (wait-list-%wait wait-list))))
(defun wait-for-input-internal (sockets &key timeout)
(with-mapped-conditions ()
(sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
(sb-unix:fd-zero rfds)
(dolist (socket (wait-list-%wait sockets))
(sb-unix:fd-set
(sb-bsd-sockets:socket-file-descriptor socket)
rfds))
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(let* ((wait-list (wait-list-%wait sockets))
count err)
(if (null wait-list)
(setq count 0) ;; no need to call
(multiple-value-setq (count err)
(sb-unix:unix-fast-select
;; "invalid number of arguments: 0" if wait-list is null.
(1+ (reduce #'max wait-list
:key #'sb-bsd-sockets:socket-file-descriptor))
(sb-alien:addr rfds) nil nil
(when timeout secs) (when timeout musecs))))
(if (null count) ; something wrong in #'sb-unix:unix-fast-select
(unless (= err sb-unix:eintr)
(error (map-errno-error err)))
(when (< 0 count) ; do nothing if count = 0
;; process the result...
(dolist (x (wait-list-waiters sockets))
(when (sb-unix:fd-isset
(sb-bsd-sockets:socket-file-descriptor
(socket x))
rfds)
(setf (state x) :READ))))))))))
) ; progn
;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
;;; Based on LispWorks version written by Erik Huelsmann.
#+win32 ; shared by ECL and SBCL
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +wsa-wait-failed+ #xffffffff)
(defconstant +wsa-infinite+ #xffffffff)
(defconstant +wsa-wait-event-0+ 0)
(defconstant +wsa-wait-timeout+ 258))
#+win32 ; shared by ECL and SBCL
(progn
(defconstant fd-read 1)
(defconstant fd-read-bit 0)
(defconstant fd-write 2)
(defconstant fd-write-bit 1)
(defconstant fd-oob 4)
(defconstant fd-oob-bit 2)
(defconstant fd-accept 8)
(defconstant fd-accept-bit 3)
(defconstant fd-connect 16)
(defconstant fd-connect-bit 4)
(defconstant fd-close 32)
(defconstant fd-close-bit 5)
(defconstant fd-qos 64)
(defconstant fd-qos-bit 6)
(defconstant fd-group-qos 128)
(defconstant fd-group-qos-bit 7)
(defconstant fd-routing-interface 256)
(defconstant fd-routing-interface-bit 8)
(defconstant fd-address-list-change 512)
(defconstant fd-address-list-change-bit 9)
(defconstant fd-max-events 10)
(defconstant fionread 1074030207)
;; Note: for ECL, socket-handle will return raw Windows Handle,
;; while SBCL returns OSF Handle instead.
(defun socket-handle (usocket)
(sb-bsd-sockets:socket-file-descriptor (socket usocket)))
(defun socket-ready-p (socket)
(if (typep socket 'stream-usocket)
(plusp (bytes-available-for-read socket))
(%ready-p socket)))
(defun waiting-required (sockets)
(notany #'socket-ready-p sockets))
(defun raise-usock-err (errno &optional socket)
(error 'unknown-error
:socket socket
:real-error errno))
(defun wait-for-input-internal (wait-list &key timeout)
(when (waiting-required (wait-list-waiters wait-list))
(let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
nil
(if timeout
(truncate (* 1000 timeout))
+wsa-infinite+)
nil)))
(ecase rv
((#.+wsa-wait-event-0+)
(update-ready-and-state-slots wait-list))
((#.+wsa-wait-timeout+)) ; do nothing here
((#.+wsa-wait-failed+)
(maybe-wsa-error rv))))))
(defun %add-waiter (wait-list waiter)
(let ((events (etypecase waiter
(stream-server-usocket (logior fd-connect fd-accept fd-close))
(stream-usocket (logior fd-read))
(datagram-usocket (logior fd-read)))))
(maybe-wsa-error
(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)
waiter)))
(defun %remove-waiter (wait-list waiter)
(maybe-wsa-error
(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
waiter))
) ; progn
#+(and sbcl win32)
(progn
;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It
;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
;; which is always machine word-sized (exactly as intptr_t;
;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
;; enough -- potentially)."
;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
(sb-alien:define-alien-type ws-socket sb-alien:signed)
(sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
(sb-alien:define-alien-type ws-event sb-alien::hinstance)
(sb-alien:define-alien-type nil
(sb-alien:struct wsa-network-events
(network-events sb-alien:long)
(error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
(sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
ws-event) ; return type only
(sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
(boolean #.sb-vm::n-machine-word-bits)
(event-object ws-event))
;; not used
(sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)
(boolean #.sb-vm::n-machine-word-bits)
(event-object ws-event))
(sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
sb-alien:int
(socket ws-socket)
(event-object ws-event)
(network-events (* (sb-alien:struct wsa-network-events))))
(sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
sb-alien:int
(socket ws-socket)
(event-object ws-event)
(network-events sb-alien:long))
(sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
ws-dword
(number-of-events ws-dword)
(events (* ws-event))
(wait-all-p (boolean #.sb-vm::n-machine-word-bits))
(timeout ws-dword)
(alertable-p (boolean #.sb-vm::n-machine-word-bits)))
(sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
sb-alien:int
(socket ws-socket)
(cmd sb-alien:long)
(argp (* sb-alien:unsigned-long)))
(defun maybe-wsa-error (rv &optional socket)
(unless (zerop rv)
(raise-usock-err (sockint::wsa-get-last-error) socket)))
(defun os-socket-handle (usocket)
(sb-bsd-sockets:socket-file-descriptor (socket usocket)))
(defun bytes-available-for-read (socket)
(sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
(maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
socket)
(prog1 int-ptr
(when (plusp int-ptr)
(setf (state socket) :read)))))
(defun map-network-events (func network-events)
(let ((event-map (sb-alien:slot network-events 'network-events))
(error-array (sb-alien:slot network-events 'error-code)))
(unless (zerop event-map)
(dotimes (i fd-max-events)
(unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
(funcall func (sb-alien:deref error-array i)))))))
(defun update-ready-and-state-slots (wait-list)
(loop with sockets = (wait-list-waiters wait-list)
for socket in sockets do
(if (%ready-p socket)
(progn
(setf (state socket) :READ))
(sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))
(let ((rv (wsa-enum-network-events (os-socket-handle socket)
(os-wait-list-%wait wait-list)
(sb-alien:addr network-events))))
(if (zerop rv)
(map-network-events
#'(lambda (err-code)
(if (zerop err-code)
(progn
(setf (state socket) :READ)
(when (stream-server-usocket-p socket)
(setf (%ready-p socket) t)))
(raise-usock-err err-code socket)))
network-events)
(maybe-wsa-error rv socket)))))))
(defun os-wait-list-%wait (wait-list)
(sb-alien:deref (wait-list-%wait wait-list)))
(defun (setf os-wait-list-%wait) (value wait-list)
(setf (sb-alien:deref (wait-list-%wait wait-list)) value))
;; "Event handles are leaking in current SBCL backend implementation,
;; because of SBCL-unfriendly usage of finalizers.
;;
;; "SBCL never calls a finalizer that closes over a finalized object: a
;; reference from that closure prevents its collection forever. That's
;; the case with USOCKET in %SETUP-WAIT-LIST.
;;
;; "I use the following redefinition of %SETUP-WAIT-LIST:
;;
;; "Of course it may be rewritten with more clarity, but you can see the
;; core idea: I'm closing over those components of WAIT-LIST that I need
;; for finalization, not the wait-list itself. With the original
;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
;;
;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
(defun %setup-wait-list (wait-list)
(setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
(setf (os-wait-list-%wait wait-list) (wsa-event-create))
(sb-ext:finalize wait-list
(let ((event-handle (os-wait-list-%wait wait-list))
(alien (wait-list-%wait wait-list)))
#'(lambda ()
(wsa-event-close event-handle)
(unless (null alien)
(sb-alien:free-alien alien))))))
) ; progn
#+(and (or ecl clasp) (not win32))
(progn
(defun wait-for-input-internal (wl &key timeout)
(with-mapped-conditions ()
(multiple-value-bind (secs usecs)
(split-timeout (or timeout 1))
(multiple-value-bind (result-fds err)
(read-select wl (when timeout secs) usecs)
(declare (ignore result-fds))
(unless (null err)
(error (map-errno-error err)))))))
(defun %setup-wait-list (wl)
(setf (wait-list-%wait wl)
(fdset-alloc)))
(defun %add-waiter (wl w)
(declare (ignore wl w)))
(defun %remove-waiter (wl w)
(declare (ignore wl w)))
) ; progn
#+(and (or ecl clasp) win32 (not ecl-bytecmp))
(progn
(defun maybe-wsa-error (rv &optional syscall)
(unless (zerop rv)
(sb-bsd-sockets::socket-error syscall)))
(defun %setup-wait-list (wl)
(setf (wait-list-%wait wl)
(ffi:c-inline () () :int
"WSAEVENT event;
event = WSACreateEvent();
@(return) = event;")))
(defun %add-waiter (wait-list waiter)
(let ((events (etypecase waiter
(stream-server-usocket (logior fd-connect fd-accept fd-close))
(stream-usocket (logior fd-read))
(datagram-usocket (logior fd-read)))))
(maybe-wsa-error
(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
(:fixnum :fixnum :fixnum) :fixnum
"int result;
result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
@(return) = result;")
'%add-waiter)))
(defun %remove-waiter (wait-list waiter)
(maybe-wsa-error
(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
(:fixnum :fixnum) :fixnum
"int result;
result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
@(return) = result;")
'%remove-waiter))
;; TODO: how to handle error (result) in this call?
(declaim (inline %bytes-available-for-read))
(defun %bytes-available-for-read (socket)
(ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
"u_long nbytes;
int result;
nbytes = 0L;
result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
@(return) = nbytes;"))
(defun bytes-available-for-read (socket)
(let ((nbytes (%bytes-available-for-read socket)))
(when (plusp nbytes)
(setf (state socket) :read))
nbytes))
(defun update-ready-and-state-slots (wait-list)
(loop with sockets = (wait-list-waiters wait-list)
for socket in sockets do
(if (%ready-p socket)
(setf (state socket) :READ)
(let ((events (etypecase socket
(stream-server-usocket (logior fd-connect fd-accept fd-close))
(stream-usocket (logior fd-read))
(datagram-usocket (logior fd-read)))))
;; TODO: check the iErrorCode array
(multiple-value-bind (valid-p ready-p)
(ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)
(values :bool :bool)
;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list)
"WSANETWORKEVENTS network_events;
int i, result;
result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
if (!result) {
@(return 0) = Ct;
@(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
} else {
@(return 0) = Cnil;
@(return 1) = Cnil;
}")
(if valid-p
(when ready-p
(setf (state socket) :READ)
(when (stream-server-usocket-p socket)
(setf (%ready-p socket) t)))
(sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))
(defun wait-for-input-internal (wait-list &key timeout)
(when (waiting-required (wait-list-waiters wait-list))
(let ((rv (ffi:c-inline ((wait-list-%wait wait-list)
(if timeout
(truncate (* 1000 timeout))
+wsa-infinite+))
(:fixnum :fixnum) :fixnum
"DWORD result;
WSAEVENT events[1];
events[0] = (WSAEVENT)#0;
result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
@(return) = result;")))
(ecase rv
((#.+wsa-wait-event-0+)
(update-ready-and-state-slots (wait-list-waiters wait-list)))
((#.+wsa-wait-timeout+)) ; do nothing here
((#.+wsa-wait-failed+)
(sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
) ; progn

266
sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/scl.lisp Normal file
View file

@ -0,0 +1,266 @@
;;;; See LICENSE for licensing information.
(in-package :usocket)
(defparameter +scl-error-map+
(append +unix-errno-condition-map+
+unix-errno-error-map+))
(defun scl-map-socket-error (err &key condition socket)
(let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member))))
(cond (usock-err
(if (subtypep usock-err 'error)
(error usock-err :socket socket)
(signal usock-err :socket socket)))
(t
(error 'unknown-error
:socket socket
:real-error condition)))))
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
"Dispatch correct usocket condition."
(typecase condition
(ext::socket-error
(scl-map-socket-error (ext::socket-errno condition)
:socket socket
:condition condition))))
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
(local-host nil local-host-p)
(local-port nil local-port-p)
&aux
(patch-udp-p (fboundp 'ext::inet-socket-send-to)))
(when (and nodelay-specified
(not (eq nodelay :if-supported)))
(unsupported 'nodelay 'socket-connect))
(when deadline (unsupported 'deadline 'socket-connect))
(when timeout (unsupported 'timeout 'socket-connect))
(when (and local-host-p (not patch-udp-p))
(unsupported 'local-host 'socket-connect :minimum "1.3.9"))
(when (and local-port-p (not patch-udp-p))
(unsupported 'local-port 'socket-connect :minimum "1.3.9"))
(let ((socket))
(ecase protocol
(:stream
(setf socket (let ((args (list (host-to-hbo host) port :kind protocol)))
(when (and patch-udp-p (or local-host-p local-port-p))
(nconc args (list :local-host (when local-host
(host-to-hbo local-host))
:local-port local-port)))
(with-mapped-conditions (socket)
(apply #'ext:connect-to-inet-socket args))))
(let ((stream (sys:make-fd-stream socket :input t :output t
:element-type element-type
:buffering :full)))
(make-stream-socket :socket socket :stream stream)))
(:datagram
(when (not patch-udp-p)
(error 'unsupported
:feature '(protocol :datagram)
:context 'socket-connect
:minumum "1.3.9"))
(setf socket
(if (and host port)
(let ((args (list (host-to-hbo host) port :kind protocol)))
(when (and patch-udp-p (or local-host-p local-port-p))
(nconc args (list :local-host (when local-host
(host-to-hbo local-host))
:local-port local-port)))
(with-mapped-conditions (socket)
(apply #'ext:connect-to-inet-socket args)))
(if (or local-host-p local-port-p)
(with-mapped-conditions ()
(ext:create-inet-listener (or local-port 0)
protocol
:host (when local-host
(if (ip= local-host *wildcard-host*)
0
(host-to-hbo local-host)))))
(with-mapped-conditions ()
(ext:create-inet-socket protocol)))))
(let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
(ext:finalize usocket #'(lambda ()
(when (%open-p usocket)
(ext:close-socket socket))))
usocket)))))
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(host (if (ip= host *wildcard-host*)
0
(host-to-hbo host)))
(server-sock
(with-mapped-conditions ()
(ext:create-inet-listener port :stream
:host host
:reuse-address reuseaddress
:backlog backlog))))
(make-stream-server-socket server-sock :element-type element-type)))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(with-mapped-conditions (usocket)
(let* ((sock (ext:accept-tcp-connection (socket usocket)))
(stream (sys:make-fd-stream sock :input t :output t
:element-type (or element-type
(element-type usocket))
:buffering :full)))
(make-stream-socket :socket sock :stream stream))))
;; Sockets and their associated streams are modelled as
;; different objects. Be sure to close the socket stream
;; when closing stream-sockets; it makes sure buffers
;; are flushed and the socket is closed correctly afterwards.
(defmethod socket-close ((usocket usocket))
"Close socket."
(with-mapped-conditions (usocket)
(ext:close-socket (socket usocket))))
(defmethod socket-close ((usocket stream-usocket))
"Close socket."
(with-mapped-conditions (usocket)
(close (socket-stream usocket))))
(defmethod socket-close :after ((socket datagram-usocket))
(setf (%open-p socket) nil))
(defmethod socket-shutdown ((usocket usocket) direction)
(declare (ignore usocket direction))
(unsupported "shutdown" 'socket-shutdown))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
(let ((s (socket usocket))
(host (if host (host-to-hbo host)))
(real-buffer (if (zerop offset)
buffer
(subseq buffer offset (+ offset size)))))
(multiple-value-bind (result errno)
(ext:inet-socket-send-to s real-buffer size
:remote-host host :remote-port port)
(or result
(scl-map-socket-error errno :socket usocket)))))
(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
(integer 0) ; size
(unsigned-byte 32) ; host
(unsigned-byte 16))) ; port
(let ((s (socket socket)))
(let ((real-buffer (or buffer
(make-array length :element-type '(unsigned-byte 8))))
(real-length (or length
(length buffer))))
(multiple-value-bind (result errno remote-host remote-port)
(ext:inet-socket-receive-from s real-buffer real-length)
(if result
(values real-buffer result remote-host remote-port)
(scl-map-socket-error errno :socket socket))))))
(defmethod get-local-name ((usocket usocket))
(multiple-value-bind (address port)
(with-mapped-conditions (usocket)
(ext:get-socket-host-and-port (socket usocket)))
(values (hbo-to-vector-quad address) port)))
(defmethod get-peer-name ((usocket stream-usocket))
(multiple-value-bind (address port)
(with-mapped-conditions (usocket)
(ext:get-peer-host-and-port (socket usocket)))
(values (hbo-to-vector-quad address) port)))
(defmethod get-local-address ((usocket usocket))
(nth-value 0 (get-local-name usocket)))
(defmethod get-peer-address ((usocket stream-usocket))
(nth-value 0 (get-peer-name usocket)))
(defmethod get-local-port ((usocket usocket))
(nth-value 1 (get-local-name usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(nth-value 1 (get-peer-name usocket)))
(defun get-host-by-address (address)
(multiple-value-bind (host errno)
(ext:lookup-host-entry (host-byte-order address))
(cond (host
(ext:host-entry-name host))
(t
(let ((condition (cdr (assoc errno +unix-ns-error-map+))))
(cond (condition
(error condition :host-or-ip address))
(t
(error 'ns-unknown-error :host-or-ip address
:real-error errno))))))))
(defun get-hosts-by-name (name)
(multiple-value-bind (host errno)
(ext:lookup-host-entry name)
(cond (host
(mapcar #'hbo-to-vector-quad
(ext:host-entry-addr-list host)))
(t
(let ((condition (cdr (assoc errno +unix-ns-error-map+))))
(cond (condition
(error condition :host-or-ip name))
(t
(error 'ns-unknown-error :host-or-ip name
:real-error errno))))))))
(defun get-host-name ()
(unix:unix-gethostname))
;;
;;
;; WAIT-LIST part
;;
(defun %add-waiter (wl waiter)
(declare (ignore wl waiter)))
(defun %remove-waiter (wl waiter)
(declare (ignore wl waiter)))
(defun %setup-wait-list (wl)
(declare (ignore wl)))
(defun wait-for-input-internal (wait-list &key timeout)
(let* ((sockets (wait-list-waiters wait-list))
(pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
(nfds (length sockets))
(bytes (* nfds pollfd-size)))
(alien:with-bytes (fds-sap bytes)
(do ((sockets sockets (rest sockets))
(base 0 (+ base 8)))
((endp sockets))
(let ((fd (socket (first sockets))))
(setf (sys:sap-ref-32 fds-sap base) fd)
(setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin)))
(multiple-value-bind (result errno)
(let ((thread:*thread-whostate* "Poll wait")
(timeout (if timeout
(truncate (* timeout 1000))
-1)))
(declare (inline unix:unix-poll))
(unix:unix-poll (alien:sap-alien fds-sap
(* (alien:struct unix::pollfd)))
nfds timeout))
(cond ((not result)
(error "~@<Polling error: ~A~:@>"
(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))))))))))