cmucl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) LICENSE --- cmucl.lisp (11553B) --- 1 ;;;; See LICENSE for licensing information. 2 3 (in-package :usocket) 4 5 #+win32 6 (defun remap-for-win32 (z) 7 (mapcar #'(lambda (x) 8 (cons (mapcar #'(lambda (y) 9 (+ 10000 y)) 10 (car x)) 11 (cdr x))) 12 z)) 13 14 (defparameter +cmucl-error-map+ 15 #+win32 16 (append (remap-for-win32 +unix-errno-condition-map+) 17 (remap-for-win32 +unix-errno-error-map+)) 18 #-win32 19 (append +unix-errno-condition-map+ 20 +unix-errno-error-map+)) 21 22 (defun cmucl-map-socket-error (err &key condition socket host-or-ip) 23 (let ((usock-error 24 (cdr (assoc err +cmucl-error-map+ :test #'member)))) 25 (if usock-error 26 (if (subtypep usock-error 'error) 27 (cond ((subtypep usock-error 'ns-error) 28 (error usock-error :socket socket :host-or-ip host-or-ip)) 29 (t 30 (error usock-error :socket socket))) 31 (cond ((subtypep usock-error 'ns-condition) 32 (signal usock-error :socket socket :host-or-ip host-or-ip)) 33 (t 34 (signal usock-error :socket socket)))) 35 (error 'unknown-error 36 :socket socket 37 :real-error condition)))) 38 39 ;; CMUCL error handling is brain-dead: it doesn't preserve any 40 ;; information other than the OS error string from which the 41 ;; error can be determined. The OS error string isn't good enough 42 ;; given that it may have been localized (l10n). 43 ;; 44 ;; The above applies to versions pre 19b; 19d and newer are expected to 45 ;; contain even better error reporting. 46 ;; 47 ;; 48 ;; Just catch the errors and encapsulate them in an unknown-error 49 (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) 50 "Dispatch correct usocket condition." 51 (typecase condition 52 (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) 53 :socket socket 54 :condition condition 55 :host-or-ip host-or-ip)))) 56 57 (defun socket-connect (host port &key (protocol :stream) (element-type 'character) 58 timeout deadline (nodelay t nodelay-specified) 59 (local-host nil local-host-p) 60 (local-port nil local-port-p) 61 &aux 62 (local-bind-p (fboundp 'ext::bind-inet-socket))) 63 (when timeout (unsupported 'timeout 'socket-connect)) 64 (when deadline (unsupported 'deadline 'socket-connect)) 65 (when (and nodelay-specified 66 (not (eq nodelay :if-supported))) 67 (unsupported 'nodelay 'socket-connect)) 68 (when (and local-host-p (not local-bind-p)) 69 (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)")) 70 (when (and local-port-p (not local-bind-p)) 71 (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)")) 72 73 (let ((socket)) 74 (ecase protocol 75 (:stream 76 (setf socket 77 (let ((args (list (host-to-hbo host) port protocol))) 78 (when (and local-bind-p (or local-host-p local-port-p)) 79 (nconc args (list :local-host (when local-host 80 (host-to-hbo local-host)) 81 :local-port local-port))) 82 (with-mapped-conditions (socket host) 83 (apply #'ext:connect-to-inet-socket args)))) 84 (if socket 85 (let* ((stream (sys:make-fd-stream socket :input t :output t 86 :element-type element-type 87 :buffering :full)) 88 ;;###FIXME the above line probably needs an :external-format 89 (usocket (make-stream-socket :socket socket 90 :stream stream))) 91 usocket) 92 (let ((err (unix:unix-errno))) 93 (when err (cmucl-map-socket-error err))))) 94 (:datagram 95 (setf socket 96 (if (and host port) 97 (let ((args (list (host-to-hbo host) port protocol))) 98 (when (and local-bind-p (or local-host-p local-port-p)) 99 (nconc args (list :local-host (when local-host 100 (host-to-hbo local-host)) 101 :local-port local-port))) 102 (with-mapped-conditions (socket (or host local-host)) 103 (apply #'ext:connect-to-inet-socket args))) 104 (if (or local-host-p local-port-p) 105 (with-mapped-conditions (socket (or host local-host)) 106 (apply #'ext:create-inet-listener 107 (nconc (list (or local-port 0) protocol) 108 (when (and local-host-p 109 (ip/= local-host *wildcard-host*)) 110 (list :host (host-to-hbo local-host)))))) 111 (with-mapped-conditions (socket (or host local-host)) 112 (ext:create-inet-socket protocol))))) 113 (if socket 114 (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) 115 (ext:finalize usocket #'(lambda () (when (%open-p usocket) 116 (ext:close-socket socket)))) 117 usocket) 118 (let ((err (unix:unix-errno))) 119 (when err (cmucl-map-socket-error err)))))))) 120 121 (defun socket-listen (host port 122 &key reuseaddress 123 (reuse-address nil reuse-address-supplied-p) 124 (backlog 5) 125 (element-type 'character)) 126 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) 127 (server-sock 128 (with-mapped-conditions (nil host) 129 (apply #'ext:create-inet-listener 130 (nconc (list port :stream 131 :backlog backlog 132 :reuse-address reuseaddress) 133 (when (ip/= host *wildcard-host*) 134 (list :host 135 (host-to-hbo host)))))))) 136 (make-stream-server-socket server-sock :element-type element-type))) 137 138 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) 139 (with-mapped-conditions (usocket) 140 (let* ((sock (ext:accept-tcp-connection (socket usocket))) 141 (stream (sys:make-fd-stream sock :input t :output t 142 :element-type (or element-type 143 (element-type usocket)) 144 :buffering :full))) 145 (make-stream-socket :socket sock :stream stream)))) 146 147 ;; Sockets and socket streams are represented 148 ;; by different objects. Be sure to close the 149 ;; socket stream when closing a stream socket. 150 (defmethod socket-close ((usocket stream-usocket)) 151 "Close socket." 152 (with-mapped-conditions (usocket) 153 (close (socket-stream usocket)))) 154 155 (defmethod socket-close ((usocket usocket)) 156 "Close socket." 157 (with-mapped-conditions (usocket) 158 (ext:close-socket (socket usocket)))) 159 160 (defmethod socket-close :after ((socket datagram-usocket)) 161 (setf (%open-p socket) nil)) 162 163 #+unicode 164 (defun %unix-send (fd buffer length flags) 165 (alien:alien-funcall 166 (alien:extern-alien "send" 167 (function c-call:int 168 c-call:int 169 system:system-area-pointer 170 c-call:int 171 c-call:int)) 172 fd 173 (system:vector-sap buffer) 174 length 175 flags)) 176 177 (defmethod socket-shutdown ((usocket usocket) direction) 178 (with-mapped-conditions (usocket) 179 (ext:inet-shutdown (socket usocket) (ecase direction 180 (:input ext:shut-rd) 181 (:output ext:shut-wr))))) 182 183 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0) 184 &aux (real-buffer (if (zerop offset) 185 buffer 186 (subseq buffer offset (+ offset size))))) 187 (with-mapped-conditions (usocket host) 188 (if (and host port) 189 (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port) 190 #-unicode 191 (unix:unix-send (socket usocket) real-buffer size 0) 192 #+unicode 193 (%unix-send (socket usocket) real-buffer size 0)))) 194 195 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) 196 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer 197 (integer 0) ; size 198 (unsigned-byte 32) ; host 199 (unsigned-byte 16))) ; port 200 (let ((real-buffer (or buffer 201 (make-array length :element-type '(unsigned-byte 8)))) 202 (real-length (or length 203 (length buffer)))) 204 (multiple-value-bind (nbytes remote-host remote-port) 205 (with-mapped-conditions (usocket) 206 (ext:inet-recvfrom (socket usocket) real-buffer real-length)) 207 (values real-buffer nbytes remote-host remote-port)))) 208 209 (defmethod get-local-name ((usocket usocket)) 210 (multiple-value-bind 211 (address port) 212 (ext:get-socket-host-and-port (socket usocket)) 213 (values (hbo-to-vector-quad address) port))) 214 215 (defmethod get-peer-name ((usocket stream-usocket)) 216 (multiple-value-bind 217 (address port) 218 (ext:get-peer-host-and-port (socket usocket)) 219 (values (hbo-to-vector-quad address) port))) 220 221 (defmethod get-local-address ((usocket usocket)) 222 (nth-value 0 (get-local-name usocket))) 223 224 (defmethod get-peer-address ((usocket stream-usocket)) 225 (nth-value 0 (get-peer-name usocket))) 226 227 (defmethod get-local-port ((usocket usocket)) 228 (nth-value 1 (get-local-name usocket))) 229 230 (defmethod get-peer-port ((usocket stream-usocket)) 231 (nth-value 1 (get-peer-name usocket))) 232 233 234 (defun lookup-host-entry (host) 235 (multiple-value-bind 236 (entry errno) 237 (ext:lookup-host-entry host) 238 (if entry 239 entry 240 ;;###The constants below work on *most* OSes, but are defined as the 241 ;; constants mentioned in C 242 (let ((exception 243 (second (assoc errno 244 '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND 245 (2 ns-no-recovery-error) ;; NO_DATA 246 (3 ns-no-recovery-error) ;; NO_RECOVERY 247 (4 ns-try-again-condition)))))) ;; TRY_AGAIN 248 (when exception 249 (error exception)))))) 250 251 252 (defun get-host-by-address (address) 253 (handler-case (ext:host-entry-name 254 (lookup-host-entry (host-byte-order address))) 255 (condition (condition) (handle-condition condition address)))) 256 257 (defun get-hosts-by-name (name) 258 (handler-case (mapcar #'hbo-to-vector-quad 259 (ext:host-entry-addr-list 260 (lookup-host-entry name))) 261 (condition (condition) (handle-condition condition name)))) 262 263 (defun get-host-name () 264 (unix:unix-gethostname)) 265 266 (defun %setup-wait-list (wait-list) 267 (declare (ignore wait-list))) 268 269 (defun %add-waiter (wait-list waiter) 270 (push (socket waiter) (wait-list-%wait wait-list))) 271 272 (defun %remove-waiter (wait-list waiter) 273 (setf (wait-list-%wait wait-list) 274 (remove (socket waiter) (wait-list-%wait wait-list)))) 275 276 (defun wait-for-input-internal (wait-list &key timeout) 277 (with-mapped-conditions () 278 (alien:with-alien ((rfds (alien:struct unix:fd-set))) 279 (unix:fd-zero rfds) 280 (dolist (socket (wait-list-%wait wait-list)) 281 (unix:fd-set socket rfds)) 282 (multiple-value-bind 283 (secs musecs) 284 (split-timeout (or timeout 1)) 285 (multiple-value-bind (count err) 286 (unix:unix-fast-select (1+ (reduce #'max 287 (wait-list-%wait wait-list))) 288 (alien:addr rfds) nil nil 289 (when timeout secs) musecs) 290 (declare (ignore err)) 291 (if (<= 0 count) 292 ;; process the result... 293 (dolist (x (wait-list-waiters wait-list)) 294 (when (unix:fd-isset (socket x) rfds) 295 (setf (state x) :READ))) 296 (progn 297 ;;###FIXME generate an error, except for EINTR 298 )))))))