/usr/share/common-lisp/source/usocket/backend/openmcl.lisp is in cl-usocket 0.6.3.2-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | ;;;; See LICENSE for licensing information.
(in-package :usocket)
(defun get-host-name ()
(ccl::%stack-block ((resultbuf 256))
(when (zerop (#_gethostname resultbuf 256))
(ccl::%get-cstring resultbuf))))
(defparameter +openmcl-error-map+
'((:address-in-use . address-in-use-error)
(:connection-aborted . connection-aborted-error)
(:no-buffer-space . no-buffers-error)
(:connection-timed-out . timeout-error)
(:connection-refused . connection-refused-error)
(:host-unreachable . host-unreachable-error)
(:host-down . host-down-error)
(:network-down . network-down-error)
(:address-not-available . address-not-available-error)
(:network-reset . network-reset-error)
(:connection-reset . connection-reset-error)
(:shutdown . shutdown-error)
(:access-denied . operation-not-permitted-error)))
(defparameter +openmcl-nameserver-error-map+
'((:no-recovery . ns-no-recovery-error)
(:try-again . ns-try-again-condition)
(:host-not-found . ns-host-not-found-error)))
;; we need something which the openmcl implementors 'forgot' to do:
;; wait for more than one socket-or-fd
(defun input-available-p (sockets &optional ticks-to-wait)
(ccl::rletZ ((tv :timeval))
(ccl::ticks-to-timeval ticks-to-wait tv)
;;### The trickery below can be moved to the wait-list now...
(ccl::%stack-block ((infds ccl::*fd-set-size*))
(ccl::fd-zero infds)
(let ((max-fd -1))
(dolist (sock sockets)
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
(when fd ;; may be NIL if closed
(setf max-fd (max max-fd fd))
(ccl::fd-set fd infds))))
(let ((res (#_select (1+ max-fd)
infds (ccl::%null-ptr) (ccl::%null-ptr)
(if ticks-to-wait tv (ccl::%null-ptr)))))
(when (> res 0)
(dolist (sock sockets)
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
(when (and fd (ccl::fd-is-set fd infds))
(setf (state sock) :READ)))))
sockets)))))
(defun raise-error-from-id (condition-id socket real-condition)
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
(if usock-err
(error usock-err :socket socket)
(error 'unknown-error :socket socket :real-error real-condition))))
(defun handle-condition (condition &optional socket)
(typecase condition
(openmcl-socket:socket-error
(raise-error-from-id (openmcl-socket:socket-error-identifier condition)
socket condition))
(ccl:input-timeout
(error 'timeout-error :socket socket))
(ccl:communication-deadline-expired
(error 'deadline-timeout-error :socket socket))
(ccl::socket-creation-error #| ugh! |#
(let* ((condition-id (ccl::socket-creation-error-identifier condition))
(nameserver-error (cdr (assoc condition-id
+openmcl-nameserver-error-map+))))
(if nameserver-error
(if (typep nameserver-error 'serious-condition)
(error nameserver-error :host-or-ip nil)
(signal nameserver-error :host-or-ip nil))
(raise-error-from-id condition-id socket condition))))))
(defun to-format (element-type protocol)
(cond ((null element-type)
(ecase protocol ; default value of different protocol
(:stream :text)
(:datagram :binary)))
((subtypep element-type 'character)
:text)
(t :binary)))
#-ipv6
(defun socket-connect (host port &key (protocol :stream) element-type
timeout deadline nodelay
local-host local-port)
(when (eq nodelay :if-supported)
(setf nodelay t))
(with-mapped-conditions ()
(ecase protocol
(:stream
(let ((mcl-sock
(openmcl-socket:make-socket :remote-host host
:remote-port port
:local-host local-host
:local-port local-port
:format (to-format element-type protocol)
:external-format ccl:*default-external-format*
:deadline deadline
:nodelay nodelay
:connect-timeout timeout)))
(make-stream-socket :stream mcl-sock :socket mcl-sock)))
(:datagram
(let* ((mcl-sock
(openmcl-socket:make-socket :address-family :internet
:type :datagram
:local-host local-host
:local-port local-port
:input-timeout timeout
:format (to-format element-type protocol)
:external-format ccl:*default-external-format*))
(usocket (make-datagram-socket mcl-sock)))
(when (and host port)
(ccl::inet-connect (ccl::socket-device mcl-sock)
(ccl::host-as-inet-host host)
(ccl::port-as-inet-port port "udp")))
(setf (connected-p usocket) t)
usocket)))))
#-ipv6
(defun socket-listen (host port
&key reuseaddress
(reuse-address nil reuse-address-supplied-p)
(backlog 5)
(element-type 'character))
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
(real-host (host-to-hostname host))
(sock (with-mapped-conditions ()
(apply #'openmcl-socket:make-socket
(append (list :connect :passive
:reuse-address reuseaddress
:local-port port
:backlog backlog
:format (to-format element-type :stream))
(unless (eq host *wildcard-host*)
(list :local-host real-host)))))))
(make-stream-server-socket sock :element-type element-type)))
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
(declare (ignore element-type)) ;; openmcl streams are bi/multivalent
(let ((sock (with-mapped-conditions (usocket)
(openmcl-socket:accept-connection (socket usocket)))))
(make-stream-socket :socket sock :stream sock)))
;; One close method is sufficient because sockets
;; and their associated objects are represented
;; by the same object.
(defmethod socket-close ((usocket usocket))
(when (wait-list usocket)
(remove-waiter (wait-list usocket) usocket))
(with-mapped-conditions (usocket)
(close (socket usocket))))
#-ipv6
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(with-mapped-conditions (usocket)
(if (and host port)
(openmcl-socket:send-to (socket usocket) buffer size
:remote-host (host-to-hbo host)
:remote-port port
:offset offset)
;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
;; so we have to define our own.
(let* ((socket (socket usocket))
(fd (ccl::socket-device socket)))
(multiple-value-setq (buffer offset)
(ccl::verify-socket-buffer buffer offset size))
(ccl::%stack-block ((bufptr size))
(ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
(ccl::socket-call socket "send"
(ccl::with-eagain fd :output
(ccl::ignoring-eintr
(ccl::check-socket-error (#_send fd bufptr size 0))))))))))
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
(with-mapped-conditions (usocket)
(openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
(defun usocket-host-address (address)
(cond
((integerp address)
(hbo-to-vector-quad address))
((and (arrayp address)
(= (length address) 16)
(every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
(make-array 4 :displaced-to address :displaced-index-offset 12))
(t
address)))
(defmethod get-local-address ((usocket usocket))
(usocket-host-address (openmcl-socket:local-host (socket usocket))))
(defmethod get-peer-address ((usocket stream-usocket))
(usocket-host-address (openmcl-socket:remote-host (socket usocket))))
(defmethod get-local-port ((usocket usocket))
(openmcl-socket:local-port (socket usocket)))
(defmethod get-peer-port ((usocket stream-usocket))
(openmcl-socket:remote-port (socket usocket)))
(defmethod get-local-name ((usocket usocket))
(values (get-local-address usocket)
(get-local-port usocket)))
(defmethod get-peer-name ((usocket stream-usocket))
(values (get-peer-address usocket)
(get-peer-port usocket)))
(defun get-host-by-address (address)
(with-mapped-conditions ()
(openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
(defun get-hosts-by-name (name)
(with-mapped-conditions ()
(list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
(host-to-hostname name))))))
(defun %setup-wait-list (wait-list)
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun %remove-waiter (wait-list waiter)
(declare (ignore wait-list waiter)))
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(let* ((ticks-timeout (truncate (* (or timeout 1)
ccl::*ticks-per-second*))))
(input-available-p (wait-list-waiters wait-list)
(when timeout ticks-timeout))
wait-list)))
;;; Helper functions for option.lisp
(defun get-socket-option-reuseaddr (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_REUSEADDR))
(defun set-socket-option-reuseaddr (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_REUSEADDR value))
(defun get-socket-option-broadcast (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_BROADCAST))
(defun set-socket-option-broadcast (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$SOL_SOCKET #$SO_BROADCAST value))
(defun get-socket-option-tcp-nodelay (socket)
(ccl::int-getsockopt (ccl::socket-device socket)
#$IPPROTO_TCP #$TCP_NODELAY))
(defun set-socket-option-tcp-nodelay (socket value)
(ccl::int-setsockopt (ccl::socket-device socket)
#$IPPROTO_TCP #$TCP_NODELAY value))
|